subroutine get_unit ( unit )

c*********************************************************************72
c
cc GET_UNIT returns a free FORTRAN unit number.
c
c  Discussion:
c
c    A "free" FORTRAN unit number is an integer between 1 and 99 which
c    is not currently associated with an I/O device.  A free FORTRAN unit
c    number is needed in order to open a file with the OPEN command.
c
c    If UNIT = 0, then no free FORTRAN unit could be found, although
c    all 99 units were checked (except for units 5, 6 and 9, which
c    are commonly reserved for console I/O).
c
c    Otherwise, UNIT is an integer between 1 and 99, representing a
c    free FORTRAN unit.  Note that GET_UNIT assumes that units 5 and 6
c    are special, and will never return those values.
c
c  Licensing:
c
c    This code is distributed under the GNU LGPL license.
c
c  Modified:
c
c    26 October 2008
c
c  Author:
c
c    John Burkardt
c
c  Parameters:
c
c    Output, integer UNIT, the free unit number.
c
      implicit none

      integer i
      integer unit

      unit = 0

      do i = 1, 99

        if ( i .ne. 5 .and. i .ne. 6 .and. i .ne. 9 ) then

          open ( unit = i, err = 10, status = 'scratch' )
          close ( unit = i )

          unit = i

          return
        end if

10      continue

      end do

      return
      end
      function i4_log_10 ( i )

c*********************************************************************72
c
cc I4_LOG_10 returns the integer part of the logarithm base 10 of ABS(X).
c
c  Discussion:
c
c    I4_LOG_10 ( I ) + 1 is the number of decimal digits in I.
c
c  Example:
c
c        I  I4_LOG_10
c    -----  --------
c        0    0
c        1    0
c        2    0
c        9    0
c       10    1
c       11    1
c       99    1
c      100    2
c      101    2
c      999    2
c     1000    3
c     1001    3
c     9999    3
c    10000    4
c
c  Licensing:
c
c    This code is distributed under the GNU LGPL license.
c
c  Modified:
c
c    03 January 2007
c
c  Author:
c
c    John Burkardt
c
c  Parameters:
c
c    Input, integer I, the number whose logarithm base 10 is desired.
c
c    Output, integer I4_LOG_10, the integer part of the logarithm base 10 of
c    the absolute value of X.
c
      implicit none

      integer i
      integer i_abs
      integer i4_log_10
      integer ten_pow

      if ( i .eq. 0 ) then

        i4_log_10 = 0

      else

        i4_log_10 = 0
        ten_pow = 10

        i_abs = abs ( i )

10      continue

        if ( ten_pow .le. i_abs ) then
          i4_log_10 = i4_log_10 + 1
          ten_pow = ten_pow * 10
          go to 10
        end if

      end if

      return
      end
      function i4_modp ( i, j )

c*********************************************************************72
c
cc I4_MODP returns the nonnegative remainder of integer division.
c
c  Discussion:
c
c    If
c      NREM = I4_MODP ( I, J )
c      NMULT = ( I - NREM ) / J
c    then
c      I = J * NMULT + NREM
c    where NREM is always nonnegative.
c
c    The MOD function computes a result with the same sign as the
c    quantity being divided.  Thus, suppose you had an angle A,
c    and you wanted to ensure that it was between 0 and 360.
c    Then mod(A,360) would do, if A was positive, but if A
c    was negative, your result would be between -360 and 0.
c
c    On the other hand, I4_MODP(A,360) is between 0 and 360, always.
c
c  Example:
c
c        I     J     MOD I4_MODP    Factorization
c
c      107    50       7       7    107 =  2 *  50 + 7
c      107   -50       7       7    107 = -2 * -50 + 7
c     -107    50      -7      43   -107 = -3 *  50 + 43
c     -107   -50      -7      43   -107 =  3 * -50 + 43
c
c  Licensing:
c
c    This code is distributed under the GNU LGPL license.
c
c  Modified:
c
c    30 December 2006
c
c  Author:
c
c    John Burkardt
c
c  Parameters:
c
c    Input, integer I, the number to be divided.
c
c    Input, integer J, the number that divides I.
c
c    Output, integer I4_MODP, the nonnegative remainder when I is
c    divided by J.
c
      implicit none

      integer i
      integer i4_modp
      integer j
      integer value

      if ( j .eq. 0 ) then
        write ( *, '(a)' ) ' '
        write ( *, '(a)' ) 'I4_MODP - Fatal error!'
        write ( *, '(a,i8)' ) '  Illegal divisor J = ', j
        stop
      end if

      value = mod ( i, j )

      if ( value .lt. 0 ) then
        value = value + abs ( j )
      end if

      i4_modp = value

      return
      end
      function i4_uniform_ab ( a, b, seed )

c*********************************************************************72
c
cc I4_UNIFORM_AB returns a scaled pseudorandom I4.
c
c  Discussion:
c
c    An I4 is an integer value.
c
c    The pseudorandom number should be uniformly distributed
c    between A and B.
c
c  Licensing:
c
c    This code is distributed under the GNU LGPL license.
c
c  Modified:
c
c    12 November 2006
c
c  Author:
c
c    John Burkardt
c
c  Reference:
c
c    Paul Bratley, Bennett Fox, Linus Schrage,
c    A Guide to Simulation,
c    Springer Verlag, pages 201-202, 1983.
c
c    Pierre L'Ecuyer,
c    Random Number Generation,
c    in Handbook of Simulation,
c    edited by Jerry Banks,
c    Wiley Interscience, page 95, 1998.
c
c    Bennett Fox,
c    Algorithm 647:
c    Implementation and Relative Efficiency of Quasirandom
c    Sequence Generators,
c    ACM Transactions on Mathematical Software,
c    Volume 12, Number 4, pages 362-376, 1986.
c
c    Peter Lewis, Allen Goodman, James Miller
c    A Pseudo-Random Number Generator for the System/360,
c    IBM Systems Journal,
c    Volume 8, pages 136-143, 1969.
c
c  Parameters:
c
c    Input, integer A, B, the limits of the interval.
c
c    Input/output, integer SEED, the "seed" value, which should NOT be 0.
c    On output, SEED has been updated.
c
c    Output, integer I4_UNIFORM_AB, a number between A and B.
c
      implicit none

      integer a
      integer b
      integer i4_uniform_ab
      integer k
      real r
      integer seed
      integer value

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

      k = seed / 127773

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

      if ( seed .lt. 0 ) then
        seed = seed + 2147483647
      end if

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

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

      i4_uniform_ab = value

      return
      end
      function i4_wrap ( ival, ilo, ihi )

c*********************************************************************72
c
cc I4_WRAP forces an I4 to lie between given limits by wrapping.
c
c  Example:
c
c    ILO = 4, IHI = 8
c
c    I  Value
c
c    -2     8
c    -1     4
c     0     5
c     1     6
c     2     7
c     3     8
c     4     4
c     5     5
c     6     6
c     7     7
c     8     8
c     9     4
c    10     5
c    11     6
c    12     7
c    13     8
c    14     4
c
c  Licensing:
c
c    This code is distributed under the GNU LGPL license.
c
c  Modified:
c
c    31 December 2006
c
c  Author:
c
c    John Burkardt
c
c  Parameters:
c
c    Input, integer IVAL, an integer value.
c
c    Input, integer ILO, IHI, the desired bounds for the integer value.
c
c    Output, integer I4_WRAP, a "wrapped" version of IVAL.
c
      implicit none

      integer i4_modp
      integer i4_wrap
      integer ihi
      integer ilo
      integer ival
      integer jhi
      integer jlo
      integer value
      integer wide

      jlo = min ( ilo, ihi )
      jhi = max ( ilo, ihi )

      wide = jhi - jlo + 1

      if ( wide .eq. 1 ) then
        value = jlo
      else
        value = jlo + i4_modp ( ival - jlo, wide )
      end if

      i4_wrap = value

      return
      end
      subroutine i4int_to_r8int ( imin, imax, i, rmin, rmax, r )

c*********************************************************************72
c
cc I4INT_TO_R8INT maps an I4INT to an R8INT.
c
c  Discussion:
c
c    The formula used is:
c
c      R := RMIN + ( RMAX - RMIN ) * ( I - IMIN ) / ( IMAX - IMIN )
c
c  Licensing:
c
c    This code is distributed under the GNU LGPL license.
c
c  Modified:
c
c    04 September 2011
c
c  Author:
c
c    John Burkardt
c
c  Parameters:
c
c    Input, integer IMIN, IMAX, the range.
c
c    Input, integer I, the integer to be converted.
c
c    Input, double precision RMIN, RMAX, the range.
c
c    Output, double precision R, the corresponding value in [RMIN,RMAX].
c
      implicit none

      integer i
      integer imax
      integer imin
      double precision r
      double precision rmax
      double precision rmin

      if ( imax .eq. imin ) then

        r = 0.5D+00 * ( rmin + rmax )

      else

        r = ( dble ( imax - i        ) * rmin   
     &      + dble (        i - imin ) * rmax ) 
     &      / dble ( imax     - imin )

      end if

      return
      end
      subroutine i4vec_indicator ( n, a )

c*********************************************************************72
c
cc I4VEC_INDICATOR sets an I4VEC to the indicator vector.
c
c  Discussion:
c
c    An I4VEC is a vector of I4's.
c
c  Licensing:
c
c    This code is distributed under the GNU LGPL license.
c
c  Modified:
c
c    02 January 2007
c
c  Author:
c
c    John Burkardt
c
c  Parameters:
c
c    Input, integer N, the number of elements of A.
c
c    Output, integer A(N), the array to be initialized.
c
      implicit none

      integer n

      integer a(n)
      integer i

      do i = 1, n
        a(i) = i
      end do

      return
      end
      subroutine i4vec_permute ( n, p, a )

c*********************************************************************72
c
cc I4VEC_PERMUTE permutes an I4VEC in place.
c
c  Discussion:
c
c    An I4VEC is a vector of I4's.
c
c    This routine permutes an array of integer "objects", but the same
c    logic can be used to permute an array of objects of any arithmetic
c    type, or an array of objects of any complexity.  The only temporary
c    storage required is enough to store a single object.  The number
c    of data movements made is N + the number of cycles of order 2 or more,
c    which is never more than N + N/2.
c
c  Example:
c
c    Input:
c
c      N = 5
c      P = (   2,   4,   5,   1,   3 )
c      A = (   1,   2,   3,   4,   5 )
c
c    Output:
c
c      A    = (   2,   4,   5,   1,   3 ).
c
c  Licensing:
c
c    This code is distributed under the GNU LGPL license.
c
c  Modified:
c
c    18 July 2010
c
c  Author:
c
c    John Burkardt
c
c  Parameters:
c
c    Input, integer N, the number of objects.
c
c    Input, integer P(N), the permutation.  P(I) = J means
c    that the I-th element of the output array should be the J-th
c    element of the input array.
c
c    Input/output, integer A(N), the array to be permuted.
c
      implicit none

      integer n

      integer a(n)
      integer a_temp
      integer base
      parameter ( base = 1 )
      integer i
      integer ierror
      integer iget
      integer iput
      integer istart
      integer p(n)

      call perm_check ( n, p, base, ierror )

      if ( ierror .ne. 0 ) then
        write ( *, '(a)' ) ' '
        write ( *, '(a)' ) 'I4VEC_PERMUTE - Fatal error!'
        write ( *, '(a)' ) '  PERM_CHECK rejects this permutation.'
        stop
      end if
c
c  Search for the next element of the permutation that has not been used.
c
      do istart = 1, n

        if ( p(istart) .lt. 0 ) then

          go to 20

        else if ( p(istart) .eq. istart ) then

          p(istart) = - p(istart)
          go to 20

        else

          a_temp = a(istart)
          iget = istart
c
c  Copy the new value into the vacated entry.
c
10        continue

            iput = iget
            iget = p(iget)

            p(iput) = - p(iput)

            if ( iget .lt. 1 .or. n .lt. iget ) then
              write ( *, '(a)' ) ' '
              write ( *, '(a)' ) 'I4VEC_PERMUTE - Fatal error!'
              write ( *, '(a)' ) '  An index is out of range.'
              write ( *, '(a,i8,a,i8)' ) '  P(', iput, ') = ', iget
              stop
            end if

            if ( iget .eq. istart ) then
              a(iput) = a_temp
              go to 20
            end if

            a(iput) = a(iget)

          go to 10

        end if

20      continue

      end do
c
c  Restore the signs of the entries.
c
      do i = 1, n
        p(1:n) = - p(1:n)
      end do

      return
      end
      subroutine i4vec_print ( n, a, title )

c*********************************************************************72
c
cc I4VEC_PRINT prints an I4VEC.
c
c  Discussion:
c
c    An I4VEC is a vector of integer values.
c
c  Licensing:
c
c    This code is distributed under the GNU LGPL license.
c
c  Modified:
c
c    27 November 2006
c
c  Author:
c
c    John Burkardt
c
c  Parameters:
c
c    Input, integer N, the number of components of the vector.
c
c    Input, integer A(N), the vector to be printed.
c
c    Input, character*(*) TITLE, a title.
c
      implicit none

      integer n

      integer a(n)
      integer i
      character*(*) title

      write ( *, '(a)' ) ' '
      write ( *, '(a)' ) trim ( title )
      write ( *, '(a)' ) ' '
      do i = 1, n
        write ( *, '(2x,i8,a,1x,i12)' ) i, ':', a(i)
      end do

      return
      end
      subroutine legendre_zeros ( n, x )

c*********************************************************************72
c
cc LEGENDRE_ZEROS computes the zeros of the Legendre polynomial of degree N.
c
c  Licensing:
c
c    This code is distributed under the GNU LGPL license.
c
c  Modified:
c
c    17 June 2011
c
c  Author:
c
c    Original FORTRAN77 version by Philip Davis, Philip Rabinowitz.
c    This FORTRAN77 version by John Burkardt.
c
c  Reference:
c
c    Philip Davis, Philip Rabinowitz,
c    Methods of Numerical Integration,
c    Second Edition,
c    Dover, 2007,
c    ISBN: 0486453391,
c    LC: QA299.3.D28.
c
c  Parameters:
c
c    Input, integer N, the order.
c    0 .lt. N.
c
c    Output, double precision X(N), the abscissas.
c
      implicit none

      integer n

      double precision d1
      double precision d2pn
      double precision d3pn
      double precision d4pn
      double precision dp
      double precision dpn
      double precision e1
      double precision fx
      double precision h
      integer i
      integer iback
      integer k
      integer m
      integer mp1mi
      integer ncopy
      integer nmove
      double precision p
      double precision pi
      parameter ( pi = 3.141592653589793D+00 )
      double precision pk
      double precision pkm1
      double precision pkp1
      double precision t
      double precision u
      double precision v
      double precision x(n)
      double precision x0
      double precision xtemp

      e1 = dble ( n * ( n + 1 ) )

      m = ( n + 1 ) / 2

      do i = 1, m

        mp1mi = m + 1 - i

        t = dble ( 4 * i - 1 ) * pi 
     &    / dble ( 4 * n + 2 )

        x0 = cos ( t ) * ( 1.0D+00 - ( 1.0D+00 - 1.0D+00 
     &    / dble ( n ) ) 
     &    / dble ( 8 * n * n ) )

        pkm1 = 1.0D+00
        pk = x0

        do k = 2, n
          pkp1 = 2.0D+00 * x0 * pk - pkm1 - ( x0 * pk - pkm1 ) 
     &      / dble ( k )
          pkm1 = pk
          pk = pkp1
        end do

        d1 = dble ( n ) * ( pkm1 - x0 * pk )

        dpn = d1 / ( 1.0D+00 - x0 ) / ( 1.0D+00 + x0 )

        d2pn = ( 2.0D+00 * x0 * dpn - e1 * pk ) / ( 1.0D+00 - x0 ) 
     &    / ( 1.0D+00 + x0 )

        d3pn = ( 4.0D+00 * x0 * d2pn + ( 2.0D+00 - e1 ) * dpn ) 
     &    / ( 1.0D+00 - x0 ) / ( 1.0D+00 + x0 )

        d4pn = ( 6.0D+00 * x0 * d3pn + ( 6.0D+00 - e1 ) * d2pn ) 
     &    / ( 1.0D+00 - x0 ) / ( 1.0D+00 + x0 )

        u = pk / dpn
        v = d2pn / dpn
c
c  Initial approximation H:
c
        h = - u * ( 1.0D+00 + 0.5D+00 * u * ( v + u * ( v * v - d3pn / 
     &    ( 3.0D+00 * dpn ) ) ) )
c
c  Refine H using one step of Newton's method:
c
        p = pk + h * ( dpn + 0.5D+00 * h * ( d2pn + h / 3.0D+00 
     &    * ( d3pn + 0.25D+00 * h * d4pn ) ) )

        dp = dpn + h * ( d2pn + 0.5D+00 * h * 
     &    ( d3pn + h * d4pn / 3.0D+00 ) )

        h = h - p / dp

        xtemp = x0 + h

        x(mp1mi) = xtemp

        fx = d1 - h * e1 * ( pk + 0.5D+00 * h * ( dpn + h / 3.0D+00 
     &    * ( d2pn + 0.25D+00 * h 
     &    * ( d3pn + 0.2D+00 * h * d4pn ) ) ) )

      end do

      if ( mod ( n, 2 ) .eq. 1 ) then
        x(1) = 0.0D+00
      end if
c
c  Shift the data up.
c
      nmove = ( n + 1 ) / 2
      ncopy = n - nmove

      do i = 1, nmove
        iback = n + 1 - i
        x(iback) = x(iback-ncopy)
      end do
c
c  Reflect values for the negative abscissas.
c
      do i = 1, n - nmove
        x(i) = - x(n+1-i)
      end do

      return
      end
      subroutine perm_check ( n, p, base, ierror )

c*********************************************************************72
c
cc PERM_CHECK checks that a vector represents a permutation.
c
c  Discussion:
c
c    The routine verifies that each of the integers from BASE to
c    to BASE+N-1 occurs among the N entries of the permutation.
c
c    Set the input quantity BASE to 0, if P is a 0-based permutation,
c    or to 1 if P is a 1-based permutation.
c
c  Licensing:
c
c    This code is distributed under the GNU LGPL license.
c
c  Modified:
c
c    03 June 2009
c
c  Author:
c
c    John Burkardt
c
c  Parameters:
c
c    Input, integer N, the number of entries.
c
c    Input, integer P(N), the array to check.
c
c    Input, integer BASE, the index base.
c
c    Output, integer IERROR, error flag.
c    0, the array represents a permutation.
c    nonzero, the array does not represent a permutation.  The smallest
c    missing value is equal to IERROR.
c
      implicit none

      integer n

      integer base
      integer find
      integer ierror
      integer p(n)
      integer seek

      ierror = 0

      do seek = base, base + n - 1

        ierror = 1

        do find = 1, n
          if ( p(find) .eq. seek ) then
            ierror = 0
            go to 10
          end if
        end do

10      continue

        if ( ierror .ne. 0 ) then
          write ( *, '(a)' ) ' '
          write ( *, '(a)' ) 'PERM_CHECK - Fatal error!'
          write ( *, '(a)' ) '  The input array does not represent'
          write ( *, '(a)' ) '  a proper permutation.'
          stop
        end if

      end do

      return
      end
      subroutine perm_uniform ( n, seed, p )

c*********************************************************************72
c
cc PERM_UNIFORM selects a random permutation of N objects.
c
c  Discussion:
c
c    The routine assumes the objects are labeled 1, 2, ... N.
c
c  Licensing:
c
c    This code is distributed under the GNU LGPL license.
c
c  Modified:
c
c    25 January 2007
c
c  Author:
c
c    John Burkardt
c
c  Reference:
c
c    Albert Nijenhuis, Herbert Wilf,
c    Combinatorial Algorithms for Computers and Calculators,
c    Academic Press, 1978,
c    ISBN: 0-12-519260-6,
c    LC: QA164.N54.
c
c  Parameters:
c
c    Input, integer N, the number of objects to be permuted.
c
c    Input/output, integer SEED, a seed for the random number generator.
c
c    Output, integer P(N), a permutation of ( 1, 2, ..., N ), in standard
c    index form.
c
      implicit none

      integer n

      integer i
      integer i4_uniform_ab
      integer j
      integer p(n)
      integer pk
      integer seed

      do i = 1, n
        p(i) = i
      end do

      do i = 1, n
        j = i4_uniform_ab ( i, n, seed )
        pk = p(i)
        p(i) = p(j)
        p(j) = pk
      end do

      return
      end
      function r8_abs ( x )

c*********************************************************************72
c
cc R8_ABS returns the absolute value of an R8.
c
c  Discussion:
c
c    FORTRAN90 supplies the ABS function, which should be used instead
c    of this function!
c
c  Licensing:
c
c    This code is distributed under the GNU LGPL license.
c
c  Modified:
c
c    06 September 2005
c
c  Author:
c
c    John Burkardt
c
c  Parameters:
c
c    Input, double precision X, the number whose absolute value is desired.
c
c    Output, double precision R8_ABS, the absolute value of X.
c
      implicit none

      double precision r8_abs
      double precision x

      if ( 0.0D+00 .le. x ) then
        r8_abs = + x
      else
        r8_abs = - x
      end if

      return
      end
      function r8_acos ( c )

c*********************************************************************72
c
cc R8_ACOS computes the arc cosine function, with argument truncation.
c
c  Discussion:
c
c    If you call your system ACOS routine with an input argument that is
c    even slightly outside the range [-1.0, 1.0 ], you may get an unpleasant
c    surprise (I did).
c
c    This routine simply truncates arguments outside the range.
c
c  Licensing:
c
c    This code is distributed under the GNU LGPL license.
c
c  Modified:
c
c    19 October 2012
c
c  Author:
c
c    John Burkardt
c
c  Parameters:
c
c    Input, double precision C, the argument.
c
c    Output, double precision R8_ACOS, an angle whose cosine is C.
c
      implicit none

      double precision c
      double precision c2
      double precision r8_acos

      c2 = c
      c2 = max ( c2, -1.0D+00 )
      c2 = min ( c2, +1.0D+00 )

      r8_acos = acos ( c2 )

      return
      end
      function r8_add ( x, y )

c*********************************************************************72
c
cc R8_ADD adds two R8's.
c
c  Licensing:
c
c    This code is distributed under the GNU LGPL license.
c
c  Modified:
c
c    11 August 2010
c
c  Author:
c
c    John Burkardt
c
c  Parameters:
c
c    Input, double precision X, Y, the numbers to be added.
c
c    Output, double precision R8_ADD, the sum of X and Y.
c
      implicit none

      double precision r8_add
      double precision x
      double precision y

      r8_add = x + y

      return
      end
      function r8_aint ( x )

c********************************************************************72
c
cc R8_AINT truncates an R8 argument to an integer.
c
c  Licensing:
c
c    This code is distributed under the GNU LGPL license. 
c
c  Modified:
c
c    18 October 2011
c
c  Author:
c
c    John Burkardt.
c
c  Parameters:
c
c    Input, double precision X, the argument.
c
c    Output, double precision VALUE, the truncated version of X.
c
      implicit none

      double precision r8_aint
      double precision value
      double precision x

      if ( x .lt. 0.0D+00 ) then
        value = - int ( abs ( x ) )
      else
        value =   int ( abs ( x ) )
      end if

      r8_aint = value

      return
      end
      function r8_asin ( s )

c*********************************************************************72
c
cc R8_ASIN computes the arc sine function, with argument truncation.
c
c  Discussion:
c
c    If you call your system ASIN routine with an input argument that is
c    even slightly outside the range [-1.0, 1.0 ], you may get an unpleasant
c    surprise (I did).
c
c    This routine simply truncates arguments outside the range.
c
c  Licensing:
c
c    This code is distributed under the GNU LGPL license.
c
c  Modified:
c
c    06 December 2008
c
c  Author:
c
c    John Burkardt
c
c  Parameters:
c
c    Input, double precision S, the argument.
c
c    Output, double precision R8_ASIN, an angle whose sine is S.
c
      implicit none

      double precision r8_asin
      double precision s
      double precision s2

      s2 = s
      s2 = max ( s2, -1.0D+00 )
      s2 = min ( s2, +1.0D+00 )

      r8_asin = asin ( s2 )

      return
      end
      function r8_atan ( y, x )

c*********************************************************************72
c
cc R8_ATAN computes the inverse tangent of the ratio Y / X.
c
c  Discussion:
c
c    R8_ATAN returns an angle whose tangent is ( Y / X ), a job which
c    the built in functions ATAN and ATAN2 already do.
c
c    However:
c
c    * R8_ATAN always returns a positive angle, between 0 and 2 PI,
c      while ATAN and ATAN2 return angles in the interval [-PI/2,+PI/2]
c      and [-PI,+PI] respectively;
c
c    * R8_ATAN accounts for the signs of X and Y, (as does ATAN2).  The ATAN
c     function by contrast always returns an angle in the first or fourth
c     quadrants.
c
c  Licensing:
c
c    This code is distributed under the GNU LGPL license.
c
c  Modified:
c
c    14 August 2008
c
c  Author:
c
c    John Burkardt
c
c  Parameters:
c
c    Input, double precision Y, X, two quantities which represent the
c    tangent of an angle.  If Y is not zero, then the tangent is (Y/X).
c
c    Output, double precision R8_ATAN, an angle between 0 and 2 * PI, whose
c    tangent is (Y/X), and which lies in the appropriate quadrant so that
c    the signs of its cosine and sine match those of X and Y.
c
      implicit none

      double precision abs_x
      double precision abs_y
      double precision pi
      parameter ( pi = 3.141592653589793D+00 )
      double precision r8_atan
      double precision theta
      double precision theta_0
      double precision x
      double precision y
c
c  Special cases:
c
      if ( x .eq. 0.0D+00 ) then

        if ( 0.0D+00 .lt. y ) then
          theta = pi / 2.0D+00
        else if ( y .lt. 0.0D+00 ) then
          theta = 3.0D+00 * pi / 2.0D+00
        else if ( y .eq. 0.0D+00 ) then
          theta = 0.0D+00
        end if

      else if ( y .eq. 0.0D+00 ) then

        if ( 0.0D+00 .lt. x ) then
          theta = 0.0D+00
        else if ( x .lt. 0.0D+00 ) then
          theta = pi
        end if
c
c  We assume that ATAN2 is correct when both arguments are positive.
c
      else

        abs_y = dabs ( y )
        abs_x = dabs ( x )

        theta_0 = atan2 ( abs_y, abs_x )

        if ( 0.0D+00 .lt. x .and. 0.0D+00 .lt. y ) then
          theta = theta_0
        else if ( x .lt. 0.0D+00 .and. 0.0D+00 .lt. y ) then
          theta = pi - theta_0
        else if ( x .lt. 0.0D+00 .and. y .lt. 0.0D+00 ) then
          theta = pi + theta_0
        else if ( 0.0D+00 .lt. x .and. y .lt. 0.0D+00 ) then
          theta = 2.0D+00 * pi - theta_0
        end if

      end if

      r8_atan = theta

      return
      end
      function r8_cas ( x )

c*********************************************************************72
c
cc R8_CAS returns the "casine" of an R8 value.
c
c  Discussion:
c
c    The "casine", used in the discrete Hartley transform, is abbreviated
c    CAS(X), and defined by:
c
c      CAS(X) = cos ( X ) + sin( X )
c             = sqrt ( 2 ) * sin ( X + pi/4 )
c             = sqrt ( 2 ) * cos ( X - pi/4 )
c
c  Licensing:
c
c    This code is distributed under the GNU LGPL license.
c
c  Modified:
c
c    01 January 2007
c
c  Author:
c
c    John Burkardt
c
c  Reference:
c
c    Ralph Hartley,
c    A More Symmetrical Fourier Analysis Applied to Transmission Problems,
c    Proceedings of the Institute of Radio Engineers,
c    Volume 30, pages 144-150, 1942.
c
c  Parameters:
c
c    Input, double precision X, the number whose casine is desired.
c
c    Output, double precision R8_CAS, the casine of X, which will be between
c    plus or minus the square root of 2.
c
      implicit none

      double precision r8_cas
      double precision x

      r8_cas = cos ( x ) + sin ( x )

      return
      end
      function r8_ceiling ( r )

c*********************************************************************72
c
cc R8_CEILING rounds an R8 "up" to the nearest integral R8.
c
c  Example:
c
c     R     Value
c
c    -1.1  -1.0
c    -1.0  -1.0
c    -0.9   0.0
c     0.0   0.0
c     5.0   5.0
c     5.1   6.0
c     5.9   6.0
c     6.0   6.0
c
c  Licensing:
c
c    This code is distributed under the GNU LGPL license.
c
c  Modified:
c
c    10 November 2011
c
c  Author:
c
c    John Burkardt
c
c  Parameters:
c
c    Input, double precision R, the value to be rounded up.
c
c    Output, double precision R8_CEILING, the rounded value.
c
      implicit none

      double precision r
      double precision r8_ceiling
      double precision value

      value = dble ( int ( r ) )
      if ( value .lt. r ) then
        value = value + 1.0D+00
      end if

      r8_ceiling = value

      return
      end
      function r8_choose ( n, k )

c*********************************************************************72
c
cc R8_CHOOSE computes the binomial coefficient C(N,K) as an R8.
c
c  Discussion:
c
c    The value is calculated in such a way as to avoid overflow and
c    roundoff.  The calculation is done in R8 arithmetic.
c
c    The formula used is:
c
c      C(N,K) = N! / ( K! * (N-K)! )
c
c  Licensing:
c
c    This code is distributed under the GNU LGPL license.
c
c  Modified:
c
c    07 June 2008
c
c  Author:
c
c    John Burkardt
c
c  Reference:
c
c    ML Wolfson, HV Wright,
c    Algorithm 160:
c    Combinatorial of M Things Taken N at a Time,
c    Communications of the ACM,
c    Volume 6, Number 4, April 1963, page 161.
c
c  Parameters:
c
c    Input, integer N, K, are the values of N and K.
c
c    Output, double precision R8_CHOOSE, the number of combinations of N
c    things taken K at a time.
c
      implicit none

      integer i
      integer k
      integer mn
      integer mx
      integer n
      double precision r8_choose
      double precision value

      mn = min ( k, n - k )

      if ( mn .lt. 0 ) then

        value = 0.0D+00

      else if ( mn .eq. 0 ) then

        value = 1.0D+00

      else

        mx = max ( k, n - k )
        value = dble ( mx + 1 )

        do i = 2, mn
          value = ( value * dble ( mx + i ) ) / dble ( i )
        end do

      end if

      r8_choose = value

      return
      end
      function r8_chop ( place, x )

c*********************************************************************72
c
cc R8_CHOP chops an R8 to a given number of binary places.
c
c  Example:
c
c    3.875 = 2 + 1 + 1/2 + 1/4 + 1/8.
c
c    The following values would be returned for the 'chopped' value of
c    3.875:
c
c    PLACE  Value
c
c       1      2
c       2      3     = 2 + 1
c       3      3.5   = 2 + 1 + 1/2
c       4      3.75  = 2 + 1 + 1/2 + 1/4
c       5+     3.875 = 2 + 1 + 1/2 + 1/4 + 1/8
c
c  Licensing:
c
c    This code is distributed under the GNU LGPL license.
c
c  Modified:
c
c    16 January 2007
c
c  Author:
c
c    John Burkardt
c
c  Parameters:
c
c    Input, integer PLACE, the number of binary places to preserve.
c    PLACE = 0 means return the integer part of X.
c    PLACE = 1 means return the value of X, correct to 1/2.
c    PLACE = 2 means return the value of X, correct to 1/4.
c    PLACE = -1 means return the value of X, correct to 2.
c
c    Input, double precision X, the number to be chopped.
c
c    Output, double precision R8_CHOP, the chopped number.
c
      implicit none

      double precision fac
      integer place
      double precision r8_chop
      double precision r8_log_2
      double precision r8_sign
      double precision s
      integer temp
      double precision x

      s = r8_sign ( x )
      temp = int ( r8_log_2 ( abs ( x ) ) )
      fac = 2.0D+00**( temp - place + 1 )
      r8_chop = s * dble ( int ( abs ( x ) / fac ) ) * fac

      return
      end
      function r8_csc ( theta )

c*********************************************************************72
c
cc R8_CSC returns the cosecant of X.
c
c  Discussion:
c
c    R8_CSC ( THETA ) = 1.0 / SIN ( THETA )
c
c    The cosecant is not a built-in function in FORTRAN, and occasionally it
c    is handier, or more concise, to be able to refer to it directly
c    rather than through its definition in terms of the sine function.
c
c  Licensing:
c
c    This code is distributed under the GNU LGPL license.
c
c  Modified:
c
c    05 March 2012
c
c  Author:
c
c    John Burkardt
c
c  Parameters:
c
c    Input, double precision THETA, the angle, in radians, whose
c    cosecant is desired.  It must be the case that SIN ( THETA ) is not zero.
c
c    Output, double precision R8_CSC, the cosecant of THETA.
c
      implicit none

      double precision r8_csc
      double precision theta
      double precision value

      value = sin ( theta )

      if ( value .eq. 0.0D+00 ) then
        write ( *, '(a)' ) ' '
        write ( *, '(a)' ) 'R8_CSC - Fatal error!'
        write ( *, '(a,g14.6)' ) 
     &    '  Cosecant undefined for THETA = ', theta
        stop
      end if

      r8_csc = 1.0D+00 / value

      return
      end
      function r8_csqrt ( x )

c*********************************************************************72
c
cc R8_CSQRT returns the complex square root of an R8.
c
c  Licensing:
c
c    This code is distributed under the GNU LGPL license.
c
c  Modified:
c
c    23 August 20008
c
c  Author:
c
c    John Burkardt
c
c  Parameters:
c
c    Input, double precision X, the number whose square root is desired.
c
c    Output, double complex R8_CSQRT, the square root of X:
c
      implicit none

      double precision argument
      double precision magnitude
      double precision pi
      parameter ( pi = 3.141592653589793D+00 )
      double complex r8_csqrt
      double precision x

      if ( 0.0D+00 .lt. x ) then
        magnitude = x
        argument = 0.0D+00
      else if ( 0.0D+00 .eq. x ) then
        magnitude = 0.0D+00
        argument = 0.0D+00
      else if ( x .lt. 0.0D+00 ) then
        magnitude = -x
        argument = pi
      end if

      magnitude = sqrt ( magnitude )
      argument = argument / 2.0D+00

      r8_csqrt = magnitude
     &  * dcmplx ( cos ( argument ), sin ( argument ) )

      return
      end
      function r8_cube_root ( x )

c*********************************************************************72
c
cc R8_CUBE_ROOT returns the cube root of an R8.
c
c  Discussion:
c
c    This routine is designed to avoid the possible problems that can occur
c    when formulas like 0.0**(1/3) or (-1.0)**(1/3) are to be evaluated.
c
c  Licensing:
c
c    This code is distributed under the GNU LGPL license.
c
c  Modified:
c
c    16 January 2007
c
c  Author:
c
c    John Burkardt
c
c  Parameters:
c
c    Input, double precision X, the number whose cube root is desired.
c
c    Output, double precision R8_CUBE_ROOT, the cube root of X.
c
      implicit none

      double precision r8_cube_root
      double precision value
      double precision x

      if ( 0.0D+00 .lt. x ) then
        value = x**(1.0D+00/3.0D+00)
      else if ( x .eq. 0.0D+00 ) then
        value = 0.0D+00
      else
        value = - ( abs ( x ) )**(1.0D+00/3.0D+00)
      end if

      r8_cube_root = value

      return
      end
      function r8_diff ( x, y, n )

c*********************************************************************72
c
cc R8_DIFF computes the difference of two R8's to a specified accuracy.
c
c  Discussion:
c
c    The user controls how many binary digits of accuracy
c    are to be used.
c
c    N determines the accuracy of the value of the result.  If N = 10,
c    for example, only 11 binary places will be used in the arithmetic.
c    In general, only N+1 binary places will be used.
c
c    N may be zero.  However, a negative value of N should
c    not be used, since this will cause both X and Y to look like 0.
c
c  Licensing:
c
c    This code is distributed under the GNU LGPL license.
c
c  Modified:
c
c    04 April 2010
c
c  Author:
c
c    John Burkardt
c
c  Parameters:
c
c    Input, double precision X, Y, the two values whose difference is desired.
c
c    Input, integer N, the number of binary digits to use.
c
c    Output, double precision R8_DIFF, the value of X-Y.
c
      implicit none

      double precision cx
      double precision cy
      integer n
      double precision pow2
      double precision r8_diff
      double precision size
      double precision x
      double precision y

      if ( x .eq. y ) then
        r8_diff = 0.0D+00
        return
      end if

      pow2 = 2.0D+00**n
c
c  Compute the magnitude of X and Y, and take the larger of the
c  two.  At least one of the two values is not zero!
c
      size = max ( abs ( x ), abs ( y ) )
c
c  Make normalized copies of X and Y.  One of the two values will
c  actually be equal to 1.
c
      cx = x / size
      cy = y / size
c
c  Here's where rounding comes in.  We know that the larger of the
c  the two values equals 1.  We multiply both values by 2**N,
c  where N+1 is the number of binary digits of accuracy we want
c  to use, truncate the values, and divide back by 2**N.
c
      cx = dble ( int ( cx * pow2 + sign ( 0.5D+00, cx ) ) ) / pow2
      cy = dble ( int ( cy * pow2 + sign ( 0.5D+00, cy ) ) ) / pow2
c
c  Take the difference now.
c
      r8_diff = cx - cy
c
c  Undo the scaling.
c
      r8_diff = r8_diff * size

      return
      end
      subroutine r8_digit ( x, idigit, digit )

c*********************************************************************72
c
cc R8_DIGIT returns a particular decimal digit of an R8.
c
c  Licensing:
c
c    This code is distributed under the GNU LGPL license.
c
c  Modified:
c
c    04 April 2010
c
c  Author:
c
c    John Burkardt
c
c  Parameters:
c
c    Input, real double precision X, the number whose NDIG-th decimal digit
c    is desired.  If X is zero, all digits will be returned as 0.
c
c    Input, integer IDIGIT, the position of the desired decimal
c    digit.  A value of 1 means the leading digit, a value of 2 the second digit
c    and so on.
c
c    Output, integer DIGIT, the value of the IDIGIT-th decimal
c    digit of X.
c
      implicit none

      integer digit
      integer i
      integer idigit
      integer ival
      double precision x
      double precision xcopy

      if ( x .eq. 0.0D+00 ) then
        digit = 0
        return
      end if

      if ( idigit .le. 0 ) then
        digit = 0
        return
      end if
c
c  Set XCOPY = X, and then force XCOPY to lie between 1 and 10.
c
      xcopy = abs ( x )

10    continue

      if ( xcopy .lt. 1.0D+00 ) then
        xcopy = xcopy * 10.0D+00
        go to 10
      end if

20    continue

      if ( 10.0D+00 .le. xcopy ) then
        xcopy = xcopy / 10.0D+00
        go to 20
      end if

      do i = 1, idigit
        ival = int ( xcopy )
        xcopy = ( xcopy - ival ) * 10.0D+00
      end do

      digit = ival

      return
      end
      function r8_divide_i4 ( i, j )

c*********************************************************************72
c
cc R8_DIVIDE_I4 returns an I4 fraction as an R8.
c
c  Licensing:
c
c    This code is distributed under the GNU LGPL license. 
c
c  Modified:
c
c    05 June 2012
c
c  Author:
c
c    John Burkardt
c
c  Parameters:
c
c    Input, integer I, J, the numerator and denominator.
c
c    Output, double precision R8_DIVIDE_I4, the value of (I/J).
c
      implicit none

      integer i
      integer j
      double precision r8_divide_i4

      r8_divide_i4 = dble ( i ) / dble ( j )

      return
      end
      function r8_epsilon ( )

c*********************************************************************72
c
cc R8_EPSILON returns the R8 roundoff unit.
c
c  Discussion:
c
c    The roundoff unit is a number R which is a power of 2 with the
c    property that, to the precision of the computer's arithmetic,
c      1 .lt. 1 + R
c    but
c      1 = ( 1 + R / 2 )
c
c    FORTRAN90 provides the superior library routine
c
c      EPSILON ( X )
c
c  Licensing:
c
c    This code is distributed under the GNU LGPL license.
c
c  Modified:
c
c    01 September 2012
c
c  Author:
c
c    John Burkardt
c
c  Parameters:
c
c    Output, double precision R8_EPSILON, the R8 roundoff unit.
c
      implicit none

      double precision r8_epsilon

      r8_epsilon = 2.220446049250313D-016

      return
      end
      function r8_epsilon_compute ( )

c*********************************************************************72
c
cc R8_EPSILON_COMPUTE computes the R8 roundoff unit.
c
c  Discussion:
c
c    The roundoff unit is a number R which is a power of 2 with the
c    property that, to the precision of the computer's arithmetic,
c      1 .lt. 1 + R
c    but
c      1 = ( 1 + R / 2 )
c
c    FORTRAN90 provides the superior library routine
c
c      EPSILON ( X )
c
c  Licensing:
c
c    This code is distributed under the GNU LGPL license.
c
c  Modified:
c
c    01 September 2012
c
c  Author:
c
c    John Burkardt
c
c  Parameters:
c
c    Output, double precision R8_EPSILON_COMPUTE, the R8 roundoff unit.
c
      implicit none

      double precision one
      double precision r8_add
      double precision r8_epsilon_compute
      double precision temp
      double precision test
      double precision value

      save value

      data value / 0.0D+00 /

      if ( value .ne. 0.0D+00 ) then
        r8_epsilon_compute = value
        return
      end if

      one = dble ( 1 )

      value = one
      temp = value / 2.0D+00
      test = r8_add ( one, temp )

10    continue

      if ( one .lt. test ) then
        value = temp
        temp = value / 2.0D+00
        test = r8_add ( one, temp )
        go to 10
      end if

      r8_epsilon_compute = value

      return
      end
      function r8_exp ( x )

c*********************************************************************72
c
cc R8_EXP computes the exponential function, avoiding overflow and underflow.
c
c  Discussion:
c
c    My experience with the G95 compiler has included many unpleasant
c    floating point exceptions when very small arguments are given to
c    the exponential function.
c
c    This routine is designed to avoid such problems.
c
c    Ideally, the rule would be:
c
c                    X <= log ( TINY ) => R8_EXP ( X ) = 0
c    log ( HUGE ) <= X                 => R8_EXP ( X ) = HUGE
c
c    However, the G95 math library seems to produce infinity for
c    EXP ( LOG ( HUGE ( X ) ), rather than HUGE ( X ), so we've
c    included a fudge factor.
c
c  Licensing:
c
c    This code is distributed under the GNU LGPL license.
c
c  Modified:
c
c    23 August 2008
c
c  Author:
c
c    John Burkardt
c
c  Parameters:
c
c    Input, double precision X, the argument of the exponential function.
c
c    Output, double precision R8_EXP, the value of exp ( X ).
c
      implicit none

      double precision log_max
      parameter ( log_max = 709.711D+00 )
      double precision log_min
      parameter ( log_min = -708.467D+00 )
      double precision r8_exp
      double precision r8_huge
      double precision x

      if ( x .le. log_min ) then
        r8_exp = 0.0D+00
      else if ( x .lt. log_max ) then
        r8_exp = exp ( x )
      else
        r8_exp = r8_huge ( )
      end if

      return
      end
      function r8_factorial ( n )

c*********************************************************************72
c
cc R8_FACTORIAL computes the factorial of N.
c
c  Discussion:
c
c    factorial ( N ) = product ( 1 <= I <= N ) I
c
c  Licensing:
c
c    This code is distributed under the GNU LGPL license.
c
c  Modified:
c
c    07 June 2008
c
c  Author:
c
c    John Burkardt
c
c  Parameters:
c
c    Input, integer N, the argument of the factorial function.
c    If N is less than 1, the function value is returned as 1.
c
c    Output, double precision R8_FACTORIAL, the factorial of N.
c
      implicit none

      integer i
      integer n
      double precision r8_factorial

      r8_factorial = 1.0D+00

      do i = 1, n
        r8_factorial = r8_factorial * dble ( i )
      end do

      return
      end
      function r8_factorial2 ( n )

c*********************************************************************72
c
cc R8_FACTORIAL2 computes the double factorial function.
c
c  Discussion:
c
c    FACTORIAL2( N ) = Product ( N * (N-2) * (N-4) * ... * 2 )  (N even)
c                    = Product ( N * (N-2) * (N-4) * ... * 1 )  (N odd)
c
c  Example:
c
c     N   Value
c
c     0     1
c     1     1
c     2     2
c     3     3
c     4     8
c     5    15
c     6    48
c     7   105
c     8   384
c     9   945
c    10  3840
c
c  Licensing:
c
c    This code is distributed under the GNU LGPL license.
c
c  Modified:
c
c    02 June 2010
c
c  Author:
c
c    John Burkardt
c
c  Parameters:
c
c    Input, integer N, the argument of the double factorial
c    function.  If N is less than 1, R8_FACTORIAL2 is returned as 1.0.
c
c    Output, double precision R8_FACTORIAL2, the value.
c
      implicit none

      integer n
      double precision r8_factorial2
      double precision r8_n

      if ( n .lt. 1 ) then
        r8_factorial2 = 1.0D+00
        return
      end if

      r8_n = dble ( n )
      r8_factorial2 = 1.0D+00

10    continue

      if ( 1.0D+00 .lt. r8_n ) then
        r8_factorial2 = r8_factorial2 * r8_n
        r8_n = r8_n - 2.0D+00
        go to 10
      end if

      return
      end
      function r8_floor ( r )

c*********************************************************************72
c
cc R8_FLOOR rounds an R8 "down" (towards -infinity) to the nearest integral R8.
c
c  Example:
c
c    R     Value
c
c   -1.1  -2.0
c   -1.0  -1.0
c   -0.9  -1.0
c    0.0   0.0
c    5.0   5.0
c    5.1   5.0
c    5.9   5.0
c    6.0   6.0
c
c  Licensing:
c
c    This code is distributed under the GNU LGPL license.
c
c  Modified:
c
c    10 Noember 2011
c
c  Author:
c
c    John Burkardt
c
c  Parameters:
c
c    Input, double precision R, the value to be rounded down.
c
c    Output, double precision R8_FLOOR, the rounded value.
c
      implicit none

      double precision r
      double precision r8_floor
      double precision value

      value = dble ( int ( r ) )
      if ( r .lt. value ) then
        value = value - 1.0D+00
      end if

      r8_floor = value

      return
      end
      function r8_fraction ( i, j )

c*********************************************************************72
c
cc R8_FRACTION uses real arithmetic on an integer ratio.
c
c  Discussion:
c
c    Given integer variables I and J, both FORTRAN and C will evaluate
c    an expression such as "I/J" using what is called "integer division",
c    with the result being an integer.  It is often convenient to express
c    the parts of a fraction as integers but expect the result to be computed
c    using real arithmetic.  This function carries out that operation.
c
c  Example:
c
c       I     J   I/J  R8_FRACTION
c
c       1     2     0  0.5
c       7     4     1  1.75
c       8     4     2  2.00
c       9     4     2  2.25
c
c  Licensing:
c
c    This code is distributed under the GNU LGPL license.
c
c  Modified:
c
c    05 October 2010
c
c  Author:
c
c    John Burkardt
c
c  Parameters:
c
c    Input, integer I, J, the arguments.
c
c    Output, double precision R8_FRACTION, the value of the ratio.
c
      implicit none

      integer i
      integer j
      double precision r8_fraction

      r8_fraction = dble ( i ) / dble ( j )

      return
      end
      function r8_fractional ( x )

c*********************************************************************72
c
cc R8_FRACTIONAL returns the fractional part of an R8.
c
c  Licensing:
c
c    This code is distributed under the GNU LGPL license.
c
c  Modified:
c
c    16 January 2007
c
c  Author:
c
c    John Burkardt
c
c  Parameters:
c
c    Input, double precision X, the argument.
c
c    Output, double precision R8_FRACTIONAL, the fractional part of X.
c
      implicit none

      double precision r8_fractional
      double precision x

      r8_fractional = abs ( x ) - dble ( int ( abs ( x ) ) )

      return
      end
      function r8_gamma ( x )

c*********************************************************************72
c
cc R8_GAMMA evaluates Gamma(X) for a real argument.
c
c  Discussion:
c
c    This routine calculates the gamma function for a real argument X.
c    Computation is based on an algorithm outlined in reference 1.
c    The program uses rational functions that approximate the gamma
c    function to at least 20 significant decimal digits.  Coefficients
c    for the approximation over the interval (1,2) are unpublished.
c    Those for the approximation for 12 <= X are from reference 2.
c
c  Licensing:
c
c    This code is distributed under the GNU LGPL license. 
c
c  Modified:
c
c    18 January 2008
c
c  Author:
c
c    Original FORTRAN77 version by William Cody, Laura Stoltz.
c    This FORTRAN77 version by John Burkardt.
c
c  Reference:
c
c    William Cody,
c    An Overview of Software Development for Special Functions,
c    in Numerical Analysis Dundee, 1975,
c    edited by GA Watson,
c    Lecture Notes in Mathematics 506,
c    Springer, 1976.
c
c    John Hart, Ward Cheney, Charles Lawson, Hans Maehly, 
c    Charles Mesztenyi, John Rice, Henry Thatcher, 
c    Christoph Witzgall,
c    Computer Approximations,
c    Wiley, 1968,
c    LC: QA297.C64.
c
c  Parameters:
c
c    Input, double precision X, the argument of the function.
c
c    Output, double precision R8_GAMMA, the value of the function.
c
      implicit none

      double precision c(7)
      double precision eps
      double precision fact
      integer i
      integer n
      double precision p(8)
      logical parity
      double precision pi
      double precision q(8)
      double precision r8_gamma
      double precision res
      double precision sqrtpi
      double precision sum
      double precision x
      double precision xbig
      double precision xden
      double precision xinf
      double precision xminin
      double precision xnum
      double precision y
      double precision y1
      double precision ysq
      double precision z
c
c  Mathematical constants
c
      data sqrtpi /0.9189385332046727417803297D+00/
      data pi /3.1415926535897932384626434D+00/
c
c  Machine dependent parameters
c
      data xbig / 171.624D+00 /
      data xminin / 2.23D-308 /
      data eps /2.22D-16/
      data xinf /1.79D+308/
c
c  Numerator and denominator coefficients for rational minimax
c  approximation over (1,2).
c
      data p/
     & -1.71618513886549492533811d+00,
     &  2.47656508055759199108314d+01,
     & -3.79804256470945635097577d+02,
     &  6.29331155312818442661052d+02,
     &  8.66966202790413211295064d+02,
     & -3.14512729688483675254357d+04,
     & -3.61444134186911729807069d+04,
     &  6.64561438202405440627855d+04/

      data q/
     & -3.08402300119738975254353d+01,
     &  3.15350626979604161529144d+02,
     & -1.01515636749021914166146d+03,
     & -3.10777167157231109440444d+03,
     &  2.25381184209801510330112d+04,
     &  4.75584627752788110767815d+03,
     & -1.34659959864969306392456d+05,
     & -1.15132259675553483497211d+05/
c
c  Coefficients for minimax approximation over (12, INF).
c
      data c/
     & -1.910444077728D-03,
     &  8.4171387781295D-04,
     & -5.952379913043012D-04,
     &  7.93650793500350248D-04,
     & -2.777777777777681622553D-03,
     &  8.333333333333333331554247D-02,
     &  5.7083835261D-03/

      parity = .false.
      fact = 1.0D+00
      n = 0
      y = x
c
c  Argument is negative.
c
      if ( y .le. 0.0D+00 ) then

        y = - x
        y1 = aint ( y )
        res = y - y1

        if ( res .ne. 0.0D+00 ) then

          if ( y1 .ne. aint ( y1 * 0.5D+00 ) * 2.0D+00 ) then
            parity = .true.
          end if

          fact = - pi / sin ( pi * res )
          y = y + 1.0D+00

        else

          res = xinf
          r8_gamma = res
          return

        end if

      end if
c
c  Argument is positive.
c
      if ( y .lt. eps ) then
c
c  Argument < EPS.
c
        if ( xminin .le. y ) then
          res = 1.0D+00 / y
        else
          res = xinf
          r8_gamma = res
          return
        end if

      else if ( y .lt. 12.0D+00 ) then

        y1 = y
c
c  0.0 < argument < 1.0.
c
        if ( y .lt. 1.0D+00 ) then

          z = y
          y = y + 1.0D+00
c
c  1.0 < argument < 12.0.
c  Reduce argument if necessary.
c
        else

          n = int ( y ) - 1
          y = y - dble ( n )
          z = y - 1.0D+00

        end if
c
c  Evaluate approximation for 1.0 < argument < 2.0.
c
        xnum = 0.0D+00
        xden = 1.0D+00
        do i = 1, 8
          xnum = ( xnum + p(i) ) * z
          xden = xden * z + q(i)
        end do

        res = xnum / xden + 1.0D+00
c
c  Adjust result for case  0.0 < argument < 1.0.
c
        if ( y1 .lt. y ) then

          res = res / y1
c
c  Adjust result for case 2.0 < argument < 12.0.
c
        else if ( y .lt. y1 ) then

          do i = 1, n
            res = res * y
            y = y + 1.0D+00
          end do

        end if

      else
c
c  Evaluate for 12.0 <= argument.
c
        if ( y .le. xbig ) then

          ysq = y * y
          sum = c(7)
          do i = 1, 6
            sum = sum / ysq + c(i)
          end do
          sum = sum / y - y + sqrtpi
          sum = sum + ( y - 0.5D+00 ) * log ( y )
          res = exp ( sum )

        else

          res = xinf
          r8_gamma = res
          return

        end if

      end if
c
c  Final adjustments and return.
c
      if ( parity ) then
        res = - res
      end if

      if ( fact .ne. 1.0D+00 ) then
        res = fact / res
      end if

      r8_gamma = res

      return
      end
      function r8_huge ( )

c*********************************************************************72
c
cc R8_HUGE returns a "huge" R8.
c
c  Discussion:
c
c    The value returned by this function is NOT required to be the
c    maximum representable R8.  This value varies from machine to machine,
c    from compiler to compiler, and may cause problems when being printed.
c    We simply want a "very large" but non-infinite number.
c
c    FORTRAN90 provides a built-in routine HUGE ( X ) that
c    can return the maximum representable number of the same datatype
c    as X, if that is what is really desired.
c
c  Licensing:
c
c    This code is distributed under the GNU LGPL license.
c
c  Modified:
c
c    13 April 2004
c
c  Author:
c
c    John Burkardt
c
c  Parameters:
c
c    Output, double precision R8_HUGE, a huge number.
c
      implicit none

      double precision r8_huge

      r8_huge = 1.0D+30

      return
      end
      function r8_hypot ( x, y )

c*********************************************************************72
c
cc R8_HYPOT returns the value of sqrt ( X^2 + Y^2 ).
c
c  Licensing:
c
c    This code is distributed under the GNU LGPL license.
c
c  Modified:
c
c    26 March 2012
c
c  Author:
c
c    John Burkardt
c
c  Parameters:
c
c    Input, double precision X, Y, the arguments.
c
c    Output, double precision R8_HYPOT, the value of sqrt ( X^2 + Y^2 ).
c
      implicit none

      double precision a
      double precision b
      double precision c
      double precision r8_hypot
      double precision x
      double precision y

      if ( abs ( x ) .lt. abs ( y ) ) then
        a = abs ( y )
        b = abs ( x )
      else
        a = abs ( x )
        b = abs ( y )
      end if
c
c  A contains the larger value.
c
      if ( a .eq. 0.0D+00 ) then
        c = 0.0D+00
      else
        c = a * sqrt ( 1.0D+00 + ( b / a )**2 )
      end if

      r8_hypot = c

      return
      end
      function r8_in_01 ( a )

c*********************************************************************72
c
cc R8_IN_01 is TRUE if an R8 is in the range [0,1].
c
c  Licensing:
c
c    This code is distributed under the GNU LGPL license.
c
c  Modified:
c
c    01 January 2007
c
c  Author:
c
c    John Burkardt
c
c  Parameters:
c
c    Input, double precision A, the value.
c
c    Output, logical R8_IN_01, is TRUE if 0 <= A <= 1.
c
      implicit none

      double precision a
      logical r8_in_01
      logical value

      if ( a .lt. 0.0D+00 .or. 1.0D+00 .lt. a ) then
        value = .false.
      else
        value = .true.
      end if

      r8_in_01 = value

      return
      end
      function r8_insignificant ( r, s )

c*********************************************************************72
c
cc R8_INSIGNIFICANT determines if an R8 is insignificant.
c
c  Licensing:
c
c    This code is distributed under the GNU LGPL license.
c
c  Modified:
c
c    26 November 2011
c
c  Author:
c
c    John Burkardt
c
c  Parameters:
c
c    Input, double precision R, the number to be compared against.
c
c    Input, double precision S, the number to be compared.
c
c    Output, logical R8_INSIGNIFICANT, is TRUE if S is insignificant
c    compared to R.
c
      implicit none

      double precision r
      double precision r8_epsilon
      logical r8_insignificant
      double precision s
      double precision t
      double precision tol
      logical value

      value = .true. 

      t = r + s
      tol = r8_epsilon ( ) * abs ( r )

      if ( tol .lt. abs ( r - t ) ) then 
        value = .false.
      end if
  
      r8_insignificant = value

      return
      end
      function r8_is_int ( r )

c*********************************************************************72
c
cc R8_IS_INT determines if an R8 represents an integer value.
c
c  Licensing:
c
c    This code is distributed under the GNU LGPL license.
c
c  Modified:
c
c    21 March 2001
c
c  Author:
c
c    John Burkardt
c
c  Parameters:
c
c    Input, double precision R, the number to be checked.
c
c    Output, logical R8_IS_INT, is TRUE if R is an integer value.
c
      implicit none

      integer i
      integer i4_huge
      parameter ( i4_huge = 2147483647 )
      double precision r
      logical r8_is_int

      if ( dble ( i4_huge ) .lt. r ) then
        r8_is_int = .false.
      else if ( r .lt. - dble ( i4_huge ) ) then
        r8_is_int = .false.
      else if ( r .eq. dble ( int ( r ) ) ) then
        r8_is_int = .true.
      else
        r8_is_int = .false.
      end if

      return
      end
      function r8_log_2 ( x )

c*********************************************************************72
c
cc R8_LOG_2 returns the logarithm base 2 of an R8.
c
c  Discussion:
c
c    value = Log ( |X| ) / Log ( 2.0 )
c
c  Licensing:
c
c    This code is distributed under the GNU LGPL license.
c
c  Modified:
c
c    01 January 2007
c
c  Author:
c
c    John Burkardt
c
c  Parameters:
c
c    Input, double precision X, the number whose base 2 logarithm is desired.
c    X should not be 0.
c
c    Output, double precision R8_LOG_2, the logarithm base 2 of the absolute
c    value of X.  It should be true that |X| = 2**D_LOG_2.
c
      implicit none

      double precision r8_huge
      double precision r8_log_2
      double precision x

      if ( x .eq. 0.0D+00 ) then
        r8_log_2 = -r8_huge ( )
      else
        r8_log_2 = log ( abs ( x ) ) / log ( 2.0D+00 )
      end if

      return
      end
      function r8_log_10 ( x )

c*********************************************************************72
c
cc R8_LOG_10 returns the logarithm base 10 of an R8.
c
c  Discussion:
c
c    value = Log10 ( |X| )
c
c  Licensing:
c
c    This code is distributed under the GNU LGPL license.
c
c  Modified:
c
c    16 January 2007
c
c  Author:
c
c    John Burkardt
c
c  Parameters:
c
c    Input, double precision X, the number whose base 2 logarithm is desired.
c    X should not be 0.
c
c    Output, double precision R8_LOG_10, the logarithm base 10 of the absolute
c    value of X.  It should be true that |X| = 10**R_LOG_10.
c
      implicit none

      double precision r8_huge
      double precision r8_log_10
      double precision x

      if ( x .eq. 0.0D+00 ) then
        r8_log_10 = - r8_huge ( x )
      else
        r8_log_10 = log10 ( abs ( x ) )
      end if

      return
      end
      function r8_log_b ( x, b )

c*********************************************************************72
c
cc R8_LOG_B returns the logarithm base B of an R8.
c
c  Discussion:
c
c    value = log ( |X| ) / log ( |B| )
c
c  Licensing:
c
c    This code is distributed under the GNU LGPL license.
c
c  Modified:
c
c    02 June 2010
c
c  Author:
c
c    John Burkardt
c
c  Parameters:
c
c    Input, double precision X, the number whose base B logarithm is desired.
c    X should not be 0.
c
c    Input, double precision B, the base, which should not be 0, 1 or -1.
c
c    Output, double precision R8_LOG_B, the logarithm base B of the absolute
c    value of X.  It should be true that |X| = |B|**R8_LOG_B.
c
      implicit none

      double precision b
      double precision r8_huge
      double precision r8_log_b
      double precision x

      if ( b .eq. 0.0D+00 .or.
     &     b .eq. 1.0D+00 .or.
     &     b .eq. - 1.0D+00 ) then
        r8_log_b = - r8_huge ( x )
      else if ( abs ( x ) .eq. 0.0D+00 ) then
        r8_log_b = - r8_huge ( x )
      else
        r8_log_b = log ( abs ( x ) ) / log ( abs ( b ) )
      end if

      return
      end
      subroutine r8_mant ( x, s, r, l )

c*********************************************************************72
c
cc R8_MANT computes the "mantissa" or "fraction part" of an R8.
c
c  Discussion:
c
c    X = S * R * 2**L
c
c    S is +1 or -1,
c    R is an R8 value between 1.0 and 2.0,
c    L is an integer.
c
c  Licensing:
c
c    This code is distributed under the GNU LGPL license.
c
c  Modified:
c
c    02 June 2010
c
c  Author:
c
c    John Burkardt
c
c  Parameters:
c
c    Input, double precision X, the number to be decomposed.
c
c    Output, integer S, the "sign" of the number.
c    S will be -1 if X is less than 0, and +1 if X is greater
c    than or equal to zero.
c
c    Output, double precision R, the mantissa of X.  R will be greater
c    than or equal to 1, and strictly less than 2.  The one
c    exception occurs if X is zero, in which case R will also
c    be zero.
c
c    Output, integer L, the integer part of the logarithm
c    (base 2) of X.
c
      implicit none

      integer l
      double precision r
      integer s
      double precision x
c
c  Determine the sign.
c
      if ( x .lt. 0.0D+00 ) then
        s = -1
      else
        s = 1
      end if
c
c  Set R to the absolute value of X, and L to zero.
c  Then force R to lie between 1 and 2.
c
      if ( x .lt. 0.0D+00 ) then
        r = -x
      else
        r = x
      end if

      l = 0
c
c  Time to bail out if X is zero.
c
      if ( x .eq. 0.0D+00 ) then
        return
      end if

10    continue

      if ( 2.0D+00 .le. r ) then
        r = r / 2.0D+00
        l = l + 1
        go to 10
      end if

20    continue

      if ( r .lt. 1.0D+00 ) then
        r = r * 2.0D+00
        l = l - 1
        go to 20
      end if

      return
      end
      function r8_mod ( x, y )

c*********************************************************************72
c
cc R8_MOD returns the remainder of R8 division.
c
c  Discussion:
c
c    If
c      REM = R8_MOD ( X, Y )
c      RMULT = ( X - REM ) / Y
c    then
c      X = Y * RMULT + REM
c    where REM has the same sign as X, and abs ( REM ) < Y.
c
c  Example:
c
c        X         Y     R8_MOD  R8_MOD Factorization
c
c      107        50       7      107 =  2 *  50 + 7
c      107       -50       7      107 = -2 * -50 + 7
c     -107        50      -7     -107 = -2 *  50 - 7
c     -107       -50      -7     -107 =  2 * -50 - 7
c
c  Licensing:
c
c    This code is distributed under the GNU LGPL license.
c
c  Modified:
c
c    02 June 2010
c
c  Author:
c
c    John Burkardt
c
c  Parameters:
c
c    Input, double precision X, the number to be divided.
c
c    Input, double precision Y, the number that divides X.
c
c    Output, double precision R8_MOD, the remainder when X is divided by Y.
c
      implicit none

      double precision r8_mod
      double precision x
      double precision y

      if ( y .eq. 0.0D+00 ) then
        write ( *, '(a)' ) ' '
        write ( *, '(a)' ) 'R8_MOD - Fatal error!'
        write ( *, '(a,g14.6)' ) '  R8_MOD ( X, Y ) called with Y = ', y
        stop
      end if

      r8_mod = x - dble ( int ( x / y ) ) * y

      if ( x .lt. 0.0D+00 .and. 0.0D+00 .lt. r8_mod ) then
        r8_mod = r8_mod - abs ( y )
      else if ( 0.0D+00 .lt. x .and. r8_mod .lt. 0.0D+00 ) then
        r8_mod = r8_mod + abs ( y )
      end if

      return
      end
      function r8_modp ( x, y )

c*********************************************************************72
c
cc R8_MODP returns the nonnegative remainder of R8 division.
c
c  Formula:
c
c    If
c      REM = R8_MODP ( X, Y )
c      RMULT = ( X - REM ) / Y
c    then
c      X = Y * RMULT + REM
c    where REM is always nonnegative.
c
c  Discussion:
c
c    The MOD function computes a result with the same sign as the
c    quantity being divided.  Thus, suppose you had an angle A,
c    and you wanted to ensure that it was between 0 and 360.
c    Then mod(A,360.0) would do, if A was positive, but if A
c    was negative, your result would be between -360 and 0.
c
c    On the other hand, R8_MODP(A,360.0) is between 0 and 360, always.
c
c  Example:
c
c        X         Y     MOD R8_MODP  R8_MODP Factorization
c
c      107        50       7       7    107 =  2 *  50 + 7
c      107       -50       7       7    107 = -2 * -50 + 7
c     -107        50      -7      43   -107 = -3 *  50 + 43
c     -107       -50      -7      43   -107 =  3 * -50 + 43
c
c  Licensing:
c
c    This code is distributed under the GNU LGPL license.
c
c  Modified:
c
c    19 October 2004
c
c  Author:
c
c    John Burkardt
c
c  Parameters:
c
c    Input, double precision X, the number to be divided.
c
c    Input, double precision Y, the number that divides X.
c
c    Output, double precision R8_MODP, the nonnegative remainder
c    when X is divided by Y.
c
      implicit none

      double precision r8_modp
      double precision x
      double precision y

      if ( y .eq. 0.0D+00 ) then
        write ( *, '(a)' ) ' '
        write ( *, '(a)' ) 'R8_MODP - Fatal error!'
        write ( *, '(a,g14.6)' )
     &    '  R8_MODP ( X, Y ) called with Y = ', y
        stop
      end if

      r8_modp = mod ( x, y )

      if ( r8_modp .lt. 0.0D+00 ) then
        r8_modp = r8_modp + abs ( y )
      end if

      return
      end
      function r8_mop ( i )

c*********************************************************************72
c
cc R8_MOP returns the I-th power of -1 as an R8.
c
c  Discussion:
c
c    An R8 is a double precision real value.
c
c  Licensing:
c
c    This code is distributed under the GNU LGPL license.
c
c  Modified:
c
c    26 July 2008
c
c  Author:
c
c    John Burkardt
c
c  Parameters:
c
c    Input, integer I, the power of -1.
c
c    Output, double precision R8_MOP, the I-th power of -1.
c
      implicit none

      integer i
      double precision r8_mop

      if ( mod ( i, 2 ) .eq. 0 ) then
        r8_mop = + 1.0D+00
      else
        r8_mop = - 1.0D+00
      end if

      return
      end
      function r8_nint ( x )

c*********************************************************************72
c
cc R8_NINT returns the nearest integer to an R8.
c
c  Example:
c
c        X        R8_NINT
c
c      1.3         1
c      1.4         1
c      1.5         1 or 2
c      1.6         2
c      0.0         0
c     -0.7        -1
c     -1.1        -1
c     -1.6        -2
c
c  Licensing:
c
c    This code is distributed under the GNU LGPL license.
c
c  Modified:
c
c    08 September 2005
c
c  Author:
c
c    John Burkardt
c
c  Parameters:
c
c    Input, double precision X, the value.
c
c    Output, integer R8_NINT, the nearest integer to X.
c
      implicit none

      integer r8_nint
      integer s
      double precision x

      if ( x .lt. 0.0D+00 ) then
        s = -1
      else
        s = 1
      end if

      r8_nint = s * int ( abs ( x ) + 0.5D+00 )

      return
      end
      function r8_normal ( a, b, seed )

c*********************************************************************72
c
cc R8_NORMAL returns a scaled pseudonormal R8.
c
c  Discussion:
c
c    The normal probability distribution function (PDF) is sampled,
c    with mean A and standard deviation B.
c
c  Licensing:
c
c    This code is distributed under the GNU LGPL license.
c
c  Modified:
c
c    17 July 2006
c
c  Author:
c
c    John Burkardt
c
c  Parameters:
c
c    Input, double precision A, the mean of the PDF.
c
c    Input, double precision B, the standard deviation of the PDF.
c
c    Input/output, integer SEED, a seed for the random number generator.
c
c    Output, double precision R8_NORMAL, a sample of the normal PDF.
c
      implicit none

      double precision a
      double precision b
      double precision pi
      parameter ( pi = 3.141592653589793D+00 )
      double precision r1
      double precision r2
      double precision r8_normal
      double precision r8_uniform_01
      integer seed
      integer seed2
      integer used
      double precision x
      double precision y

      save seed2
      save used
      save y

      data seed2 / 0 /
      data used / 0 /
      data y / 0.0D+00 /
c
c  On odd numbered calls, generate two uniforms, create two normals,
c  return the first normal and its corresponding seed.
c
      if ( mod ( used, 2 ) .eq. 0 ) then

        r1 = r8_uniform_01 ( seed )

        if ( r1 .eq. 0.0D+00 ) then
          write ( *, '(a)' ) ' '
          write ( *, '(a)' ) 'R8_NORMAL - Fatal error!'
          write ( *, '(a)' ) '  R8_UNIFORM_01 returned a value of 0.'
          stop
         end if

        seed2 = seed
        r2 = r8_uniform_01 ( seed2 )

        x = sqrt ( -2.0D+00 * log ( r1 ) ) * cos ( 2.0D+00 * pi * r2 )
        y = sqrt ( -2.0D+00 * log ( r1 ) ) * sin ( 2.0D+00 * pi * r2 )
c
c  On odd calls, return the second normal and its corresponding seed.
c
      else

        seed = seed2
        x = y

      end if

      used = used + 1

      r8_normal = a + b * x

      return
      end
      function r8_normal_01 ( seed )

c*********************************************************************72
c
cc R8_NORMAL_01 returns a unit pseudonormal R8.
c
c  Discussion:
c
c    Because this routine uses the Box Muller method, it requires pairs
c    of uniform random values to generate a pair of normal random values.
c    This means that on every other call, the code can use the second
c    value that it calculated.
c
c    However, if the user has changed the SEED value between calls,
c    the routine automatically resets itself and discards the saved data.
c
c  Licensing:
c
c    This code is distributed under the GNU LGPL license.
c
c  Modified:
c
c    08 January 2007
c
c  Author:
c
c    John Burkardt
c
c  Parameters:
c
c    Input/output, integer SEED, a seed for the random number generator.
c
c    Output, double precision R8_NORMAL_01, a sample of the standard normal PDF.
c
      implicit none

      double precision pi
      parameter ( pi = 3.141592653589793D+00 )
      double precision r1
      double precision r2
      double precision r8_normal_01
      double precision r8_uniform_01
      integer seed
      integer seed1
      integer seed2
      integer seed3
      integer used
      double precision v1
      double precision v2

      save seed1
      save seed2
      save seed3
      save used
      save v2

      data seed2 / 0 /
      data used / 0 /
      data v2 / 0.0D+00 /
c
c  If USED is odd, but the input SEED does not match
c  the output SEED on the previous call, then the user has changed
c  the seed.  Wipe out internal memory.
c
      if ( mod ( used, 2 ) .eq. 1 ) then

        if ( seed .ne. seed2 ) then
          used = 0
          seed1 = 0
          seed2 = 0
          seed3 = 0
          v2 = 0.0D+00
        end if

      end if
c
c  If USED is even, generate two uniforms, create two normals,
c  return the first normal and its corresponding seed.
c
      if ( mod ( used, 2 ) .eq. 0 ) then

        seed1 = seed

        r1 = r8_uniform_01 ( seed )

        if ( r1 .eq. 0.0D+00 ) then
          write ( *, '(a)' ) ' '
          write ( *, '(a)' ) 'R8_NORMAL_01 - Fatal error!'
          write ( *, '(a)' ) '  R8_UNIFORM_01 returned a value of 0.'
          stop
        end if

        seed2 = seed

        r2 = r8_uniform_01 ( seed )

        seed3 = seed

        v1 = sqrt ( -2.0D+00 * log ( r1 ) ) * cos ( 2.0D+00 * pi * r2 )
        v2 = sqrt ( -2.0D+00 * log ( r1 ) ) * sin ( 2.0D+00 * pi * r2 )

        r8_normal_01 = v1
        seed = seed2
c
c  If USED is odd (and the input SEED matched the output value from
c  the previous call), return the second normal and its corresponding seed.
c
      else

        r8_normal_01 = v2
        seed = seed3

      end if

      used = used + 1

      return
      end
      function r8_pi ( )

c*********************************************************************72
c
cc R8_PI returns the value of pi as an R8.
c
c  Licensing:
c
c    This code is distributed under the GNU LGPL license.
c
c  Modified:
c
c    01 January 2007
c
c  Author:
c
c    John Burkardt
c
c  Parameters:
c
c    Output, double precision R8_PI, the value of pi.
c
      implicit none

      double precision r8_pi

      r8_pi = 3.141592653589793D+00

      return
      end
      function r8_pi_sqrt ( )

c*********************************************************************72
c
cc R8_PI_SQRT returns the square root of pi as an R8.
c
c  Licensing:
c
c    This code is distributed under the GNU LGPL license.
c
c  Modified:
c
c    11 September 2012
c
c  Author:
c
c    John Burkardt
c
c  Parameters:
c
c    Output, double precision R8_PI_SQRT, the square root of pi.
c
      implicit none

      double precision r8_pi_sqrt

      r8_pi_sqrt = 1.7724538509055160273D+00

      return
      end
      function r8_power ( r, p )

c*********************************************************************72
c
cc R8_POWER computes the P-th power of an R8.
c
c  Licensing:
c
c    This code is distributed under the GNU LGPL license.
c
c  Modified:
c
c    01 January 2007
c
c  Author:
c
c    John Burkardt
c
c  Parameters:
c
c    Input, double precision R, the base.
c
c    Input, integer P, the power, which may be negative.
c
c    Output, double precision R8_POWER, the value of the P-th power of R.
c
      implicit none

      integer p
      double precision r
      double precision r8_power
      double precision value
c
c  Special case.  R^0 = 1.
c
      if ( p .eq. 0 ) then

        value = 1.0D+00
c
c  Special case.  Positive powers of 0 are 0.
c  For negative powers of 0, we go ahead and compute R**P,
c  relying on the software to complain.
c
      else if ( r .eq. 0.0D+00 ) then

        if ( 0 .lt. p ) then
          value = 0.0D+00
        else
          value = r**p
        end if

      else if ( 1 .le. p ) then
        value = r**p
      else
        value = 1.0D+00 / r**(-p)
      end if

      r8_power = value

      return
      end
      subroutine r8_power_fast ( r, p, rp, mults )

c*********************************************************************72
c
cc R8_POWER_FAST computes an integer power of an R8.
c
c  Discussion:
c
c    Obviously, R^P can be computed using P-1 multiplications.
c
c    However, R^P can also be computed using at most 2*LOG2(P) multiplications.
c    To do the calculation this way, let N = LOG2(P).
c    Compute A, A^2, A^4, ..., A^N by N-1 successive squarings.
c    Start the value of R^P at A, and each time that there is a 1 in
c    the binary expansion of P, multiply by the current result of the squarings.
c
c    This algorithm is not optimal.  For small exponents, and for special
c    cases, the result can be computed even more quickly.
c
c  Licensing:
c
c    This code is distributed under the GNU LGPL license.
c
c  Modified:
c
c    02 June 2010
c
c  Author:
c
c    John Burkardt
c
c  Parameters:
c
c    Input, double precision R, the base.
c
c    Input, integer P, the power, which may be negative.
c
c    Output, double precision RP, the value of R^P.
c
c    Output, integer MULTS, the number of multiplications
c    and divisions.
c
      implicit none

      integer mults
      integer p
      integer p_mag
      integer p_sign
      double precision r
      double precision r2
      double precision rp

      mults = 0
c
c  Special bases.
c
      if ( r .eq. 1.0D+00 ) then
        rp = 1.0D+00
        return
      end if

      if ( r .eq. -1.0D+00 ) then

        if ( mod ( p, 2 ) .eq. 1 ) then
          rp = -1.0D+00
        else
          rp = 1.0D+00
        end if

        return

      end if

      if ( r .eq. 0.0D+00 ) then

        if ( p .le. 0 ) then
          write ( *, '(a)' ) ' '
          write ( *, '(a)' ) 'R8_POWER_FAST - Fatal error!'
          write ( *, '(a)' )
     &      '  Base R is zero, and exponent is negative.'
          write ( *, '(a,i8)' ) '  Exponent P = ', p
          stop
        end if

        rp = 0.0D+00
        return

      end if
c
c  Special powers.
c
      if ( p .eq. -1 ) then
        rp = 1.0D+00 / r
        mults = mults + 1
        return
      else if ( p .eq. 0 ) then
        rp = 1.0D+00
        return
      else if ( p .eq. 1 ) then
        rp = r
        return
      end if
c
c  Some work to do.
c
      p_mag = abs ( p )
      p_sign = sign ( 1, p )

      rp = 1.0D+00
      r2 = r

10    continue

      if ( 0 .lt. p_mag ) then

        if ( mod ( p_mag, 2 ) .eq. 1 ) then
          rp = rp * r2
          mults = mults + 1
        end if

        p_mag = p_mag / 2
        r2 = r2 * r2
        mults = mults + 1

        go to 10

      end if

      if ( p_sign .eq. -1 ) then
        rp = 1.0D+00 / rp
        mults = mults + 1
      end if

      return
      end
      function r8_pythag ( a, b )

c*********************************************************************72
c
cc R8_PYTHAG computes sqrt ( A * A + B * B ) as an R8.
c
c  Discussion:
c
c    The computation avoids unnecessary overflow and underflow.
c
c  Licensing:
c
c    This code is distributed under the GNU LGPL license.
c
c  Modified:
c
c    02 June 2010
c
c  Author:
c
c    John Burkardt
c
c  Parameters:
c
c    Input, double precision A, B, the values for which sqrt ( A * A + B * B )
c    is desired.
c
c    Output, double precision R8_PYTHAG, the value of sqrt ( A * A + B * B ).
c
      implicit none

      double precision a
      double precision a_abs
      double precision b
      double precision b_abs
      double precision r8_pythag

      a_abs = abs ( a )
      b_abs = abs ( b )

      if ( b_abs .lt. a_abs ) then
        r8_pythag = a_abs *
     &    sqrt ( 1.0D+00 + ( b_abs / a_abs ) * ( b_abs / a_abs ) )
      else if ( b_abs .eq. 0.0D+00 ) then
        r8_pythag = 0.0D+00
      else if ( a_abs .le. b_abs ) then
        r8_pythag = b_abs *
     &    sqrt ( 1.0D+00 + ( a_abs / b_abs ) * ( a_abs / b_abs ) )
      end if

      return
      end
      function r8_round ( x )

c*********************************************************************72
c
cc R8_ROUND sets an R8 to the nearest integral value.
c
c  Example:
c
c        X        R8_ROUND
c
c      1.3         1.0
c      1.4         1.0
c      1.5         1.0 or 2.0
c      1.6         2.0
c      0.0         0.0
c     -0.7        -1.0
c     -1.1        -1.0
c     -1.6        -2.0
c
c  Licensing:
c
c    This code is distributed under the GNU LGPL license.
c
c  Modified:
c
c    15 October 2012
c
c  Author:
c
c    John Burkardt
c
c  Parameters:
c
c    Input, double precision X, the value.
c
c    Output, double precision R8_ROUND, the rounded value.
c
      implicit none

      double precision r8_round
      double precision value
      double precision x

      if ( x .lt. 0.0D+00 ) then
        value = - dble ( int ( - x + 0.5D+00 ) )
      else
        value =   dble ( int ( + x + 0.5D+00 ) )
      end if

      r8_round = value

      return
      end
      subroutine r8_round2 ( nplace, x, xround )

c*********************************************************************72
c
cc R8_ROUND2 rounds an R8 to a specified number of binary digits.
c
c  Discussion:
c
c    Assume that the input quantity X has the form
c
c      X = S * J * 2^L
c
c    where S is plus or minus 1, L is an integer, and J is a binary
c    mantissa which is either exactly zero, or greater than or equal
c    to 0.5 and strictly less than 1.0.
c
c    Then on return, XROUND will satisfy
c
c      XROUND = S * K * 2^L
c
c    where S and L are unchanged, and K is a binary mantissa which
c    agrees with J in the first NPLACE binary digits and is zero
c    thereafter.
c
c    If NPLACE is 0, XROUND will always be zero.
c
c    If NPLACE is 1, the mantissa of XROUND will be 0 or 0.5.
c
c    If NPLACE is 2, the mantissa of XROUND will be 0, 0.25, 0.50,
c    or 0.75.
c
c  Licensing:
c
c    This code is distributed under the GNU LGPL license.
c
c  Modified:
c
c    02 June 2010
c
c  Author:
c
c    John Burkardt
c
c  Parameters:
c
c    Input, integer NPLACE, the number of binary digits to
c    preserve.  NPLACE should be 0 or positive.
c
c    Input, double precision X, the number to be decomposed.
c
c    Output, double precision XROUND, the rounded value of X.
c
      implicit none

      integer iplace
      integer l
      integer nplace
      integer s
      double precision x
      double precision xmant
      double precision xround
      double precision xtemp

      xround = 0.0D+00
c
c  1: Handle the special case of 0.
c
      if ( x .eq. 0.0D+00 ) then
        return
      end if

      if ( nplace .le. 0 ) then
        return
      end if
c
c  2: Determine the sign S.
c
      if ( 0.0D+00 .lt. x ) then
        s = 1
        xtemp = x
      else
        s = -1
        xtemp = -x
      end if
c
c  3: Force XTEMP to lie between 1 and 2, and compute the
c  logarithm L.
c
      l = 0

10    continue

      if ( 2.0D+00 .le. xtemp ) then
        xtemp = xtemp / 2.0D+00
        l = l + 1
        go to 10
      end if

20    continue

      if ( xtemp .lt. 1.0D+00 ) then
        xtemp = xtemp * 2.0D+00
        l = l - 1
        go to 20
      end if
c
c  4: Strip out the digits of the mantissa as XMANT, and decrease L.
c
      xmant = 0.0D+00
      iplace = 0

30    continue

        xmant = 2.0D+00 * xmant

        if ( 1.0D+00 .le. xtemp ) then
          xmant = xmant + 1.0D+00
          xtemp = xtemp - 1.0D+00
        end if

        iplace = iplace + 1

        if ( xtemp .eq. 0.0D+00 .or. nplace .le. iplace ) then
          xround = s * xmant * 2.0D+00**l
          go to 40
        end if

        l = l - 1
        xtemp = xtemp * 2.0D+00

      go to 30

40    continue

      return
      end
      subroutine r8_roundb ( base, nplace, x, xround )

c*********************************************************************72
c
cc R8_ROUNDB rounds an R8 to a given number of digits in a given base.
c
c  Discussion:
c
c    The code does not seem to do a good job of rounding when
c    the base is negativec
c
c    Assume that the input quantity X has the form
c
c      X = S * J * BASE^L
c
c    where S is plus or minus 1, L is an integer, and J is a
c    mantissa base BASE which is either exactly zero, or greater
c    than or equal to (1/BASE) and less than 1.0.
c
c    Then on return, XROUND will satisfy
c
c      XROUND = S * K * BASE^L
c
c    where S and L are unchanged, and K is a mantissa base BASE
c    which agrees with J in the first NPLACE digits and is zero
c    thereafter.
c
c    Note that because of rounding, for most bases, most numbers
c    with a fractional quantities cannot be stored exactly in the
c    computer, and hence will have trailing "bogus" digits.
c
c    If NPLACE is 0, XROUND will always be zero.
c
c    If NPLACE is 1, the mantissa of XROUND will be 0,
c    1/BASE, 2/BASE, ..., (BASE-1)/BASE.
c
c    If NPLACE is 2, the mantissa of XROUND will be 0,
c    BASE/BASE^2, (BASE+1)/BASE^2, ...,
c    BASE^2-2/BASE^2, BASE^2-1/BASE^2.
c
c  Licensing:
c
c    This code is distributed under the GNU LGPL license.
c
c  Modified:
c
c    02 June 2010
c
c  Author:
c
c    John Burkardt
c
c  Parameters:
c
c    Input, integer BASE, the base of the arithmetic.
c    BASE must not be zero.  Theoretically, BASE may be negative.
c
c    Input, integer NPLACE, the number of digits base BASE to
c    preserve.  NPLACE should be 0 or positive.
c
c    Input, double precision X, the number to be decomposed.
c
c    Output, double precision XROUND, the rounded value of X.
c
      implicit none

      integer base
      integer iplace
      integer is
      integer js
      integer l
      integer nplace
      double precision x
      double precision xmant
      double precision xround
      double precision xtemp

      xround = 0.0D+00
c
c  0: Error checks.
c
      if ( base .eq. 0 ) then
        write ( *, '(a)' ) ' '
        write ( *, '(a)' ) 'R8_ROUNDB - Fatal error!'
        write ( *, '(a)' ) '  The base BASE cannot be zero.'
        stop
      end if
c
c  1: Handle the special case of 0.
c
      if ( x .eq. 0.0D+00 ) then
        return
      end if

      if ( nplace .le. 0 ) then
        return
      end if
c
c  2: Determine the sign IS.
c
      if ( 0.0D+00 .lt. x ) then
        is = 1
        xtemp = x
      else
        is = -1
        xtemp = -x
      end if
c
c  3: Force XTEMP to lie between 1 and ABS(BASE), and compute the
c  logarithm L.
c
      l = 0

10    continue

      if ( abs ( base ) .le. abs ( xtemp ) ) then

        xtemp = xtemp / dble ( base )

        if ( xtemp .lt. 0.0D+00 ) then
          is = -is
          xtemp = -xtemp
        end if

        l = l + 1

        go to 10

      end if

20    continue

      if ( abs ( xtemp ) .lt. 1.0D+00 ) then

        xtemp = xtemp * base

        if ( xtemp .lt. 0.0D+00 ) then
          is = -is
          xtemp = -xtemp
        end if

        l = l - 1

        go to 20

      end if
c
c  4: Now strip out the digits of the mantissa as XMANT, and
c  decrease L.
c
      xmant = 0.0D+00
      iplace = 0
      js = is

30    continue

        xmant = base * xmant

        if ( xmant .lt. 0.0D+00 ) then
          js = -js
          xmant = -xmant
        end if

        if ( 1.0D+00 .le. xtemp ) then
          xmant = xmant + int ( xtemp )
          xtemp = xtemp - int ( xtemp )
        end if

        iplace = iplace + 1

        if ( xtemp .eq. 0.0D+00 .or. nplace .le. iplace ) then
          xround = js * xmant * dble ( base )**l
          go to 40
        end if

        l = l - 1
        xtemp = xtemp * base

        if ( xtemp .lt. 0.0D+00 ) then
          is = -is
          xtemp = -xtemp
        end if

      go to 30

40    continue

      return
      end
      subroutine r8_roundx ( nplace, x, xround )

c*********************************************************************72
c
cc R8_ROUNDX rounds an R8.
c
c  Discussion:
c
c    Assume that the input quantity X has the form
c
c      X = S * J * 10^L
c
c    where S is plus or minus 1, L is an integer, and J is a decimal
c    mantissa which is either exactly zero, or greater than or equal
c    to 0.1 and less than 1.0.
c
c    Then on return, XROUND will satisfy
c
c      XROUND = S * K * 10^L
c
c    where S and L are unchanged, and K is a decimal mantissa which
c    agrees with J in the first NPLACE decimal digits and is zero
c    thereafter.
c
c    Note that because of rounding, most decimal fraction quantities
c    cannot be stored exactly in the computer, and hence will have
c    trailing "bogus" digits.
c
c    If NPLACE is 0, XROUND will always be zero.
c
c    If NPLACE is 1, the mantissa of XROUND will be 0, 0.1,
c    0.2, ..., or 0.9.
c
c    If NPLACE is 2, the mantissa of XROUND will be 0, 0.01, 0.02,
c    0.03, ..., 0.98, 0.99.
c
c  Licensing:
c
c    This code is distributed under the GNU LGPL license.
c
c  Modified:
c
c    02 June 2010
c
c  Author:
c
c    John Burkardt
c
c  Parameters:
c
c    Input, integer NPLACE, the number of decimal digits to
c    preserve.  NPLACE should be 0 or positive.
c
c    Input, double precision X, the number to be decomposed.
c
c    Output, double precision XROUND, the rounded value of X.
c
      implicit none

      integer iplace
      integer is
      integer l
      integer nplace
      double precision x
      double precision xmant
      double precision xround
      double precision xtemp

      xround = 0.0D+00
c
c  1: Handle the special case of 0.
c
      if ( x .eq. 0.0D+00 ) then
        return
      end if

      if ( nplace .le. 0 ) then
        return
      end if
c
c  2: Determine the sign IS.
c
      if ( 0.0D+00 .lt. x ) then
        is = 1
        xtemp = x
      else
        is = -1
        xtemp = -x
      end if
c
c  3: Force XTEMP to lie between 1 and 10, and compute the
c  logarithm L.
c
      l = 0

10    continue

      if ( 10.0D+00 .le. x ) then
        xtemp = xtemp / 10.0D+00
        l = l + 1
        go to 10
      end if

20    continue

      if ( xtemp .lt. 1.0D+00 ) then
        xtemp = xtemp * 10.0D+00
        l = l - 1
        go to 20
      end if
c
c  4: Now strip out the digits of the mantissa as XMANT, and
c  decrease L.
c
      xmant = 0.0D+00
      iplace = 0

30    continue

        xmant = 10.0D+00 * xmant

        if ( 1.0D+00 .le. xtemp ) then
          xmant = xmant + int ( xtemp )
          xtemp = xtemp - int ( xtemp )
        end if

        iplace = iplace + 1

        if ( xtemp .eq. 0.0D+00 .or. nplace .le. iplace ) then
          xround = is * xmant * ( 10.0D+00**l )
          go to 40
        end if

        l = l - 1
        xtemp = xtemp * 10.0D+00

      go to 30

40    continue

      return
      end
      function r8_sech ( x )

c*********************************************************************72
c
cc R8_SECH evaluates the hyperbolic secant, while avoiding COSH overflow.
c
c  Licensing:
c
c    This code is distributed under the GNU LGPL license.
c
c  Modified:
c
c    29 August 2000
c
c  Author:
c
c    John Burkardt
c
c  Parameters:
c
c    Input, double precision X, the argument of the function.
c
c    Output, double precision R8_SECH, the value of the function.
c
      implicit none

      double precision log_huge 
      parameter ( log_huge = 80.0D+00 )
      double precision r8_sech
      double precision x

      if ( log_huge .lt. abs ( x ) ) then
        r8_sech = 0.0D+00
      else
        r8_sech = 1.0D+00 / cosh ( x )
      end if

      return
      end
      function r8_sign ( x )

c*********************************************************************72
c
cc R8_SIGN returns the sign of an R8.
c
c  Discussion:
c
c    value = -1 if X < 0;
c    value = +1 if X => 0.
c
c  Licensing:
c
c    This code is distributed under the GNU LGPL license.
c
c  Modified:
c
c    23 August 2008
c
c  Author:
c
c    John Burkardt
c
c  Parameters:
c
c    Input, double precision X, the number whose sign is desired.
c
c    Output, double precision R8_SIGN, the sign of X.
c
      implicit none

      double precision r8_sign
      double precision x

      if ( x .lt. 0.0D+00 ) then
        r8_sign = -1.0D+00
      else
        r8_sign = +1.0D+00
      end if

      return
      end
      function r8_sign_char ( x )

c*********************************************************************72
c
cc R8_SIGN_CHAR returns a character indicating the sign of an R8.
c
c  Licensing:
c
c    This code is distributed under the GNU LGPL license.
c
c  Modified:
c
c    28 April 2012
c
c  Author:
c
c    John Burkardt
c
c  Parameters:
c
c    Input, double precision X, the number whose sign is desired.
c
c    Output, character R8_SIGN_CHAR, the sign of X, '-', '0' or '+'.
c
      implicit none

      character r8_sign_char
      character value
      double precision x

      if ( x .lt. 0.0D+00 ) then
        value = '-'
      else if ( x .eq. 0.0D+00 ) then
        value = '0'
      else
        value = '+'
      end if

      r8_sign_char = value

      return
      end
      function r8_sign_match ( r1, r2 )

c*********************************************************************72
c
cc R8_SIGN_MATCH is TRUE if two R8's are of the same sign.
c
c  Discussion:
c
c    This test could be coded numerically as
c
c      if ( 0 <= r1 * r2 ) then ...
c
c  Licensing:
c
c    This code is distributed under the GNU LGPL license.
c
c  Modified:
c
c    26 April 2012
c
c  Author:
c
c    John Burkardt
c
c  Parameters:
c
c    Input, double precision R1, R2, the values to check.
c
c    Output, logical R8_SIGN_MATCH, is TRUE if ( R1 <= 0 and R2 <= 0 )
c    or ( 0 <= R1 and 0 <= R2 ).
c
      implicit none

      double precision r1
      double precision r2
      logical r8_sign_match

      r8_sign_match = ( r1 .le. 0.0D+00 .and. r2 .le. 0.0D+00 ) .or. 
     &                ( 0.0D+00 .le. r1 .and. 0.0D+00 .le. r2 )

      return
      end
      function r8_sign_match_strict ( r1, r2 )

c*********************************************************************72
c
cc R8_SIGN_MATCH_STRICT is TRUE if two R8's are of the same strict sign.
c
c  Licensing:
c
c    This code is distributed under the GNU LGPL license.
c
c  Modified:
c
c    28 April 2012
c
c  Author:
c
c    John Burkardt
c
c  Parameters:
c
c    Input, double precision R1, R2, the values to check.
c
c    Output, logical R8_SIGN_MATCH_STRICT, is TRUE if the signs match.
c
      implicit none

      double precision r1
      double precision r2
      logical r8_sign_match_strict

      r8_sign_match_strict = 
     &  ( r1 .lt. 0.0D+00 .and. r2 .lt. 0.0D+00 ) .or.
     &  ( r1 .eq. 0.0D+00 .and. r2 .eq. 0.0D+00 ) .or.
     &  ( 0.0D+00 .lt. r1 .and. 0.0D+00 .lt. r2 )

      return
      end
      function r8_sign_opposite ( r1, r2 )

c*********************************************************************72
c
cc R8_SIGN_OPPOSITE is TRUE if two R8's are not of the same sign.
c
c  Discussion:
c
c    This test could be coded numerically as
c
c      if ( r1 * r2 <= 0.0 ) then ...
c
c  Licensing:
c
c    This code is distributed under the GNU LGPL license.
c
c  Modified:
c
c    23 June 2010
c
c  Author:
c
c    John Burkardt
c
c  Parameters:
c
c    Input, double precision R1, R2, the values to check.
c
c    Output, logical R8_SIGN_OPPOSITE, is TRUE if ( R1 <= 0 and 0 <= R2 )
c    or ( R2 <= 0 and 0 <= R1 ).
c
      implicit none

      double precision r1
      double precision r2
      logical r8_sign_opposite

      r8_sign_opposite = ( r1 <= 0.0D+00 .and. 0.0D+00 <= r2 ) .or.
     &                   ( r2 <= 0.0D+00 .and. 0.0D+00 <= r1 )

      return
      end
      function r8_sign_opposite_strict ( r1, r2 )

c*********************************************************************72
c
cc R8_SIGN_OPPOSITE_STRICT is TRUE if two R8's are strictly of opposite sign.
c
c  Discussion:
c
c    This test could be coded numerically as
c
c      if ( r1 * r2 < 0.0 ) then ...
c
c  Licensing:
c
c    This code is distributed under the GNU LGPL license.
c
c  Modified:
c
c    23 June 2010
c
c  Author:
c
c    John Burkardt
c
c  Parameters:
c
c    Input, double precision R1, R2, the values to check.
c
c    Output, logical R8_SIGN_OPPOSITE_STRICT, is TRUE if ( R1 < 0 and 0 < R2 )
c    or ( R2 < 0 and 0 < R1 ).
c
      implicit none

      double precision r1
      double precision r2
      logical r8_sign_opposite_strict

      r8_sign_opposite_strict = ( r1 < 0.0D+00 .and. 0.0D+00 < r2 ) .or.
     &                          ( r2 < 0.0D+00 .and. 0.0D+00 < r1 )

      return
      end
      function r8_sqrt_i4 ( i )

!*********************************************************************72
!
!! R8_SQRT_I4 returns the square root of an I4 as an R8.
!
!  Licensing:
!
!    This code is distributed under the GNU LGPL license. 
!
!  Modified:
!
!    05 June 2012
!
!  Author:
!
!    John Burkardt
!
!  Parameters:
!
!    Input, integer I, the number whose square root is desired.
!
!    Output, double precision R8_SQRT_I4, the value of sqrt(I).
!
      implicit none

      integer i
      double precision r8_sqrt_i4

      r8_sqrt_i4 = sqrt ( dble ( i ) )

      return
      end
      subroutine r8_swap ( x, y )

c*********************************************************************72
c
cc R8_SWAP switches two R8's.
c
c  Licensing:
c
c    This code is distributed under the GNU LGPL license.
c
c  Modified:
c
c    30 November 1998
c
c  Author:
c
c    John Burkardt
c
c  Parameters:
c
c    Input/output, double precision X, Y.  On output, the values of X and
c    Y have been interchanged.
c
      implicit none

      double precision x
      double precision y
      double precision z

      z = x
      x = y
      y = z

      return
      end
      subroutine r8_swap3 ( x, y, z )

c*********************************************************************72
c
cc R8_SWAP3 swaps three R8's.
c
c  Example:
c
c    Input:
c
c      X = 1, Y = 2, Z = 3
c
c    Output:
c
c      X = 2, Y = 3, Z = 1
c
c  Licensing:
c
c    This code is distributed under the GNU LGPL license.
c
c  Modified:
c
c    08 June 2000
c
c  Author:
c
c    John Burkardt
c
c  Parameters:
c
c    Input/output, double precision X, Y, Z, three values to be swapped.
c
      implicit none

      double precision w
      double precision x
      double precision y
      double precision z

      w = x
      x = y
      y = z
      z = w

      return
      end
      function r8_tiny ( )

c*********************************************************************72
c
cc R8_TINY returns a very small but positive R8.
c
c  Discussion:
c
c    FORTRAN90 provides a built-in routine TINY ( X ) that
c    is more suitable for this purpose, returning the smallest positive
c    but normalized real number.
c
c    This routine does NOT try to provide an accurate value for TINY.
c    Instead, it simply returns a "reasonable" value, that is, a rather
c    small, but representable, real number.
c
c  Licensing:
c
c    This code is distributed under the GNU LGPL license.
c
c  Modified:
c
c    31 December 2007
c
c  Author:
c
c    John Burkardt
c
c  Parameters:
c
c    Output, double precision R8_TINY, a "tiny" value.
c
      implicit none

      double precision r8_tiny

      r8_tiny = 1.0D-30

      return
      end
      subroutine r8_to_r8_discrete ( r, rmin, rmax, nr, rd )

c*********************************************************************72
c
cc R8_TO_R8_DISCRETE maps R to RD in [RMIN, RMAX] with NR possible values.
c
c  Formula:
c
c    if ( R < RMIN ) then
c      RD = RMIN
c    else if ( RMAX < R ) then
c      RD = RMAX
c    else
c      T = nint ( ( NR - 1 ) * ( R - RMIN ) / ( RMAX - RMIN ) )
c      RD = RMIN + T * ( RMAX - RMIN ) / real ( NR - 1 )
c
c    In the special case where NR = 1, when
c
c      XD = 0.5 * ( RMAX + RMIN )
c
c  Licensing:
c
c    This code is distributed under the GNU LGPL license.
c
c  Modified:
c
c    02 June 2010
c
c  Author:
c
c    John Burkardt
c
c  Parameters:
c
c    Input, double precision R, the number to be converted.
c
c    Input, double precision RMAX, RMIN, the maximum and minimum
c    values for RD.
c
c    Input, integer NR, the number of allowed values for XD.
c    NR should be at least 1.
c
c    Output, double precision RD, the corresponding discrete value.
c
      implicit none

      integer f
      integer nr
      double precision r
      double precision rd
      double precision rmax
      double precision rmin
c
c  Check for errors.
c
      if ( nr .lt. 1 ) then
        write ( *, '(a)' ) ' '
        write ( *, '(a)' ) 'R8_TO_R8_DISCRETE - Fatal error!'
        write ( *, '(a,i8)' ) '  NR = ', nr
        write ( *, '(a)' ) '  but NR must be at least 1.'
        stop
      end if

      if ( nr .eq. 1 ) then
        rd = 0.5D+00 * ( rmin + rmax )
        return
      end if

      if ( rmax .eq. rmin ) then
        rd = rmax
        return
      end if

      f = nint ( dble ( nr ) * ( rmax - r ) / ( rmax - rmin ) )
      f = max ( f, 0 )
      f = min ( f, nr )

      rd = ( dble (      f ) * rmin
     &     + dble ( nr - f ) * rmax )
     &     / dble ( nr     )

      return
      end
      subroutine r8_to_dhms ( r, d, h, m, s )

c*********************************************************************72
c
cc R8_TO_DHMS converts decimal days into days, hours, minutes, seconds.
c
c  Licensing:
c
c    This code is distributed under the GNU LGPL license.
c
c  Modified:
c
c    02 June 2010
c
c  Author:
c
c    John Burkardt
c
c  Parameters:
c
c    Input, double precision R, a decimal number representing a time
c    period measured in days.
c
c    Output, integer D, H, M, S, the equivalent number of days,
c    hours, minutes and seconds.
c
      implicit none

      integer d
      integer h
      integer m
      double precision r
      double precision r_copy
      integer s

      r_copy = abs ( r )

      d = int ( r_copy )

      r_copy = r_copy - d
      r_copy = 24.0D+00 * r_copy
      h = int ( r_copy )

      r_copy = r_copy - h
      r_copy = 60.0D+00 * r_copy
      m = int ( r_copy )

      r_copy = r_copy - m
      r_copy = 60.0D+00 * r_copy
      s = int ( r_copy )

      if ( r .lt. 0.0D+00 ) then
        d = -d
        h = -h
        m = -m
        s = -s
      end if

      return
      end
      subroutine r8_to_i4 ( x, xmin, xmax, ixmin, ixmax, ix )

c*********************************************************************72
c
cc R8_TO_I4 maps X in [XMIN, XMAX] to integer IX in [IXMIN, IXMAX].
c
c  Formula:
c
c    IX := IXMIN + ( IXMAX - IXMIN ) * ( X - XMIN ) / ( XMAX - XMIN )
c    IX := min ( IX, max ( IXMIN, IXMAX ) )
c    IX := max ( IX, min ( IXMIN, IXMAX ) )
c
c  Licensing:
c
c    This code is distributed under the GNU LGPL license.
c
c  Modified:
c
c    02 June 2010
c
c  Author:
c
c    John Burkardt
c
c  Parameters:
c
c    Input, double precision X, the number to be converted.
c
c    Input, double precision XMIN, XMAX, the range.  XMAX and
c    XMIN must not be equal.  It is not necessary that XMIN be less than XMAX.
c
c    Input, integer IXMIN, IXMAX, the allowed range of the output
c    variable.  IXMAX corresponds to XMAX, and IXMIN to XMIN.
c    It is not necessary that IXMIN be less than IXMAX.
c
c    Output, integer IX, the value in the range [IXMIN,IXMAX] that
c    corresponds to X.
c
      implicit none

      integer ix
      integer ixmax
      integer ixmin
      double precision temp
      double precision x
      double precision xmax
      double precision xmin

      if ( xmax .eq. xmin ) then
        write ( *, '(a)' ) ' '
        write ( *, '(a)' ) 'R8_TO_I4 - Fatal error!'
        write ( *, '(a)' ) '  XMAX = XMIN, making a zero divisor.'
        write ( *, '(a,g14.6)' ) '  XMAX = ', xmax
        write ( *, '(a,g14.6)' ) '  XMIN = ', xmin
        stop
      end if

      temp =
     &    ( ( xmax - x        ) * dble ( ixmin )
     &    + (        x - xmin ) * dble ( ixmax ) )
     &    / ( xmax     - xmin )

      if ( 0.0D+00 .le. temp ) then
        temp = temp + 0.5D+00
      else
        temp = temp - 0.5D+00
      end if

      ix = int ( temp )

      return
      end
      function r8_uniform_ab ( a, b, seed )

c*********************************************************************72
c
cc R8_UNIFORM_AB returns a pseudorandom R8 scaled to [A,B].
c
c  Licensing:
c
c    This code is distributed under the GNU LGPL license.
c
c  Modified:
c
c    06 January 2006
c
c  Author:
c
c    John Burkardt
c
c  Parameters:
c
c    Input, double precision A, B, the limits of the interval.
c
c    Input/output, integer SEED, the "seed" value, which should NOT be 0.
c    On output, SEED has been updated.
c
c    Output, double precision R8_UNIFORM_AB, a number strictly between A and B.
c
      implicit none

      double precision a
      double precision b
      integer k
      double precision r8_uniform_ab
      integer seed

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

      k = seed / 127773

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

      if ( seed .lt. 0 ) then
        seed = seed + 2147483647
      end if

      r8_uniform_ab = a + ( b - a ) * dble ( seed ) * 4.656612875D-10

      return
      end
      function r8_uniform_01 ( seed )

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

      double precision r8_uniform_01
      integer k
      integer seed

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

      k = seed / 127773

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

      if ( seed .lt. 0 ) then
        seed = seed + 2147483647
      end if

      r8_uniform_01 = dble ( seed ) * 4.656612875D-10

      return
      end
      subroutine r8_unswap3 ( x, y, z )

c*********************************************************************72
c
cc R8_UNSWAP3 unswaps three R8's.
c
c  Example:
c
c    Input:
c
c      X = 2, Y = 3, Z = 1
c
c    Output:
c
c      X = 1, Y = 2, Z = 3
c
c  Licensing:
c
c    This code is distributed under the GNU LGPL license.
c
c  Modified:
c
c    02 June 2010
c
c  Author:
c
c    John Burkardt
c
c  Parameters:
c
c    Input/output, double precision X, Y, Z, three values to be swapped.
c
      implicit none

      double precision w
      double precision x
      double precision y
      double precision z

      w = z
      z = y
      y = x
      x = w

      return
      end
      function r8_walsh_1d ( x, digit )

c*********************************************************************72
c
cc R8_WALSH_1D evaluates the Walsh function.
c
c  Discussion:
c
c    Consider the binary representation of X, and number the digits
c    in descending order, from leading to lowest, with the units digit
c    being numbered 0.
c
c    The Walsh function W(J)(X) is equal to the J-th binary digit of X.
c
c  Licensing:
c
c    This code is distributed under the GNU LGPL license.
c
c  Modified:
c
c    02 June 2010
c
c  Author:
c
c    John Burkardt
c
c  Parameters:
c
c    Input, double precision X, the argument of the Walsh function.
c
c    Input, integer DIGIT, the index of the Walsh function.
c
c    Output, double precision R8_WALSH_1D, the value of the Walsh function.
c
      implicit none

      integer digit
      integer n
      double precision r8_walsh_1d
      double precision x
      double precision x_copy
c
c  Hide the effect of the sign of X.
c
      x_copy = abs ( x )
c
c  If DIGIT is positive, divide by 2 DIGIT times.
c  If DIGIT is negative, multiply by 2 (-DIGIT) times.
c
      x_copy = x_copy / 2.0D+00**digit
c
c  Make it an integer.
c  Because it's positive, and we're using INT, we don't change the
c  units digit.
c
      n = int ( x_copy )
c
c  Is the units digit odd or even?
c
      if ( mod ( n, 2 ) .eq. 0 ) then
        r8_walsh_1d = 0.0D+00
      else
        r8_walsh_1d = 1.0D+00
      end if

      return
      end
      function r8_wrap ( r, rlo, rhi )

c*********************************************************************72
c
cc R8_WRAP forces an R8 to lie between given limits by wrapping.
c
c  Discussion:
c
c    An R8 is a double precision value.
c
c  Example:
c
c    RLO = 4.0, RHI = 8.0
c
c     R  Value
c
c    -2     8
c    -1     4
c     0     5
c     1     6
c     2     7
c     3     8
c     4     4
c     5     5
c     6     6
c     7     7
c     8     8
c     9     4
c    10     5
c    11     6
c    12     7
c    13     8
c    14     4
c
c  Licensing:
c
c    This code is distributed under the GNU LGPL license.
c
c  Modified:
c
c    04 July 2011
c
c  Author:
c
c    John Burkardt
c
c  Parameters:
c
c    Input, double precision R, a value.
c
c    Input, double precision RLO, RHI, the desired bounds.
c
c    Output, double precision R8_WRAP, a "wrapped" version of the value.
c
      implicit none

      integer n
      double precision r
      double precision r8_wrap
      double precision rhi
      double precision rhi2
      double precision rlo
      double precision rlo2
      double precision rwide
      double precision value
c
c  Guarantee RLO2 .lt. RHI2.
c
      rlo2 = min ( rlo, rhi )
      rhi2 = max ( rlo, rhi )
c
c  Find the width.
c
      rwide = rhi2 - rlo2
c
c  Add enough copies of (RHI2-RLO2) to R so that the
c  result ends up in the interval RLO2 - RHI2.
c
      if ( rwide .eq. 0.0D+00 ) then
        value = rlo
      else if ( r .lt. rlo2 ) then
        n = int ( ( rlo2 - r ) / rwide ) + 1
        value = r + n * rwide
        if ( value .eq. rhi ) then
          value = rlo
        end if
      else
        n = int ( ( r - rlo2 ) / rwide )
        value = r - n * rwide
        if ( value .eq. rlo ) then
          value = rhi
        end if
      end if

      r8_wrap = value

      return
      end
      function r82_dist_l2 ( a1, a2 )

c*********************************************************************72
c
cc R82_DIST_L2 returns the L2 distance between a pair of R82's.
c
c  Discussion:
c
c    An R82 is a vector of type R8, with two entries.
c
c    The vector L2 norm is defined as:
c
c      sqrt ( sum ( 1 <= I <= N ) A(I) * A(I) ).
c
c  Licensing:
c
c    This code is distributed under the GNU LGPL license.
c
c  Modified:
c
c    03 September 2011
c
c  Author:
c
c    John Burkardt
c
c  Parameters:
c
c    Input, double precision A1(2), A2(2), the vectors.
c
c    Output, double precision R82_DIST_L2, the L2 norm of the distance
c    between A1 and A2.
c
      implicit none

      integer dim_num
      parameter ( dim_num = 2 )

      double precision a1(dim_num)
      double precision a2(dim_num)
      double precision r82_dist_l2

      r82_dist_l2 = sqrt ( 
     &  ( a1(1) - a2(1) )**2 + ( a1(2) - a2(2) )**2 )

      return
      end
      function r82_eq ( a1, a2 )

c*********************************************************************72
c
cc R82_EQ .eq. ( A1 .eq. A2 ) for two R82's.
c
c  Discussion:
c
c    An R82 is a vector of type R8, with two entries.
c
c    The comparison is lexicographic.
c
c    A1 .eq. A2  <=>  A1(1) .eq. A2(1) and A1(2) .eq. A2(2).
c
c  Licensing:
c
c    This code is distributed under the GNU LGPL license.
c
c  Modified:
c
c    04 September 2011
c
c  Author:
c
c    John Burkardt
c
c  Parameters:
c
c    Input, double precision A1(2), A2(2), two R82 vectors to be compared.
c
c    Output, logical R82_EQ, is TRUE if and only if A1 .eq. A2.
c
      implicit none

      integer dim_num
      parameter ( dim_num = 2 )

      double precision a1(dim_num)
      double precision a2(dim_num)
      integer i
      logical r82_eq

      r82_eq = .true.

      do i = 1, dim_num
        if ( a1(i) .ne. a2(i) ) then
          r82_eq = .false.
          return
        end if
      end do

      return
      end
      function r82_ge ( a1, a2 )

c*********************************************************************72
c
cc R82_GE .eq. ( A1 >= A2 ) for two R82's.
c
c  Discussion:
c
c    An R82 is a vector of type R8, with two entries.
c
c    The comparison is lexicographic.
c
c    A1 >= A2  <=>  A1(1) > A2(1) or ( A1(1) .eq. A2(1) and A1(2) >= A2(2) ).
c
c  Licensing:
c
c    This code is distributed under the GNU LGPL license.
c
c  Modified:
c
c    03 September 2011
c
c  Author:
c
c    John Burkardt
c
c  Parameters:
c
c    Input, double precision A1(2), A2(2), R82 vectors to be compared.
c
c    Output, logical R92_GE, is TRUE if and only if A1 >= A2.
c
      implicit none

      integer dim_num
      parameter ( dim_num = 2 )

      double precision a1(dim_num)
      double precision a2(dim_num)
      integer i
      logical r82_ge

      r82_ge = .true.

      do i = 1, dim_num

        if ( a2(i) .lt. a1(i) ) then
          r82_ge = .true.
          return
        else if ( a1(i) .lt. a2(i) ) then
          r82_ge = .false.
          return
        end if

      end do

      return
      end
      function r82_gt ( a1, a2 )

c*********************************************************************72
c
cc R82_GT .eq. ( A1 > A2 ) for two R82's.
c
c  Discussion:
c
c    An R82 is a vector of type R2, with two entries.
c
c    The comparison is lexicographic.
c
c    A1 > A2  <=>  A1(1) > A2(1) or ( A1(1) .eq. A2(1) and A1(2) > A2(2) ).
c
c  Licensing:
c
c    This code is distributed under the GNU LGPL license.
c
c  Modified:
c
c    03 September 2011
c
c  Author:
c
c    John Burkardt
c
c  Parameters:
c
c    Input, double precision A1(2), A2(2), R82 vectors to be compared.
c
c    Output, logical R82_GT, is TRUE if and only if A1 > A2.
c
      implicit none

      integer dim_num
      parameter ( dim_num = 2 )

      double precision a1(dim_num)
      double precision a2(dim_num)
      integer i
      logical r82_gt

      r82_gt = .false.

      do i = 1, dim_num

        if ( a2(i) .lt. a1(i) ) then
          r82_gt = .true.
          return
        else if ( a1(i) .lt. a2(i) ) then
          r82_gt = .false.
          return
        end if

      end do

      return
      end
      function r82_le ( a1, a2 )

c*********************************************************************72
c
cc R82_LE .eq. ( A1 <= A2 ) for two R82's.
c
c  Discussion:
c
c    An R82 is a vector of type R8, with two entries.
c
c    The comparison is lexicographic.
c
c    A1 <= A2  <=>  A1(1) < A2(1) or ( A1(1) .eq. A2(1) and A1(2) <= A2(2) ).
c
c  Licensing:
c
c    This code is distributed under the GNU LGPL license.
c
c  Modified:
c
c    03 September 2011
c
c  Author:
c
c    John Burkardt
c
c  Parameters:
c
c    Input, double precision A1(2), A2(2), R82 vectors to be compared.
c
c    Output, logical R82_LE, is TRUE if and only if A1 <= A2.
c
      implicit none

      integer dim_num
      parameter ( dim_num = 2 )

      double precision a1(dim_num)
      double precision a2(dim_num)
      integer i
      logical r82_le

      r82_le = .true.

      do i = 1, dim_num

        if ( a1(i) .lt. a2(i) ) then
          r82_le = .true.
          return
        else if ( a2(i) .lt. a1(i) ) then
          r82_le = .false.
          return
        end if

      end do

      return
      end
      function r82_lt ( a1, a2 )

c*********************************************************************72
c
cc R82_LT .eq. ( A1 < A2 ) for two R82's.
c
c  Discussion:
c
c    An R82 is a vector of type R8, with two entries.
c
c    The comparison is lexicographic.
c
c    A1 < A2  <=>  A1(1) < A2(1) or ( A1(1) .eq. A2(1) and A1(2) < A2(2) ).
c
c  Licensing:
c
c    This code is distributed under the GNU LGPL license.
c
c  Modified:
c
c    03 September 2011
c
c  Author:
c
c    John Burkardt
c
c  Parameters:
c
c    Input, double precision A1(2), A2(2), R82 vectors to be compared.
c
c    Output, logical R82_LT, is TRUE if and only if A1 < A2.
c
      implicit none

      integer dim_num
      parameter ( dim_num = 2 )

      double precision a1(dim_num)
      double precision a2(dim_num)
      integer i
      logical r82_lt

      r82_lt = .false.

      do i = 1, dim_num

        if ( a1(i) .lt. a2(i) ) then
          r82_lt = .true.
          return
        else if ( a2(i) .lt. a1(i) ) then
          r82_lt = .false.
          return
        end if

      end do

      return
      end
      function r82_ne ( a1, a2 )

c*********************************************************************72
c
cc R82_NE .eq. ( A1 /= A2 ) for two R82's.
c
c  Discussion:
c
c    An R82 is a vector of type R8, with two entries.
c
c    The comparison is lexicographic.
c
c    A1 /= A2  <=>  A1(1) /= A2(1) or A1(2) /= A2(2).
c
c  Licensing:
c
c    This code is distributed under the GNU LGPL license.
c
c  Modified:
c
c    03 September 2011
c
c  Author:
c
c    John Burkardt
c
c  Parameters:
c
c    Input, double precision A1(2), A2(2), R82 vectors to be compared.
c
c    Output, logical R82_NE, is TRUE if and only if A1 /= A2.
c
      implicit none

      integer dim_num
      parameter ( dim_num = 2 )

      double precision a1(dim_num)
      double precision a2(dim_num)
      integer i
      logical r82_ne

      r82_ne = .false.
      do i = 1, dim_num
        if ( a1(i) .ne. a2(i) ) then
          r82_ne = .true.
          return
        end if
      end do

      return
      end
      function r82_norm ( a )

c*********************************************************************72
c
cc R82_NORM returns the Euclidean norm of an R82.
c
c  Discussion:
c
c    An R82 is a vector of type R8, with two entries.
c
c  Licensing:
c
c    This code is distributed under the GNU LGPL license.
c
c  Modified:
c
c    03 September 2011
c
c  Author:
c
c    John Burkardt
c
c  Parameters:
c
c    Input, double precision A(2), the vector.
c
c    Output, double precision R82_NORM, the norm.
c
      implicit none

      double precision a(2)
      double precision r82_norm

      r82_norm = sqrt ( a(1) * a(1) + a(2) * a(2) )

      return
      end
      subroutine r82_normalize ( a )

c*********************************************************************72
c
cc R82_NORMALIZE Euclidean normalizes an R82.
c
c  Discussion:
c
c    An R82 is a vector of type R8, with two entries.
c
c  Licensing:
c
c    This code is distributed under the GNU LGPL license.
c
c  Modified:
c
c    03 September 2011
c
c  Author:
c
c    John Burkardt
c
c  Parameters:
c
c    Input/output, double precision A(2), the components of the vector.
c
      implicit none

      double precision a(2)
      double precision norm

      norm = sqrt ( a(1) * a(1) + a(2) * a(2) )

      if ( norm .ne. 0.0D+00 ) then
        a(1) = a(1) / norm
        a(2) = a(2) / norm
      end if

      return
      end
      subroutine r82_print ( a, title )

c*********************************************************************72
c
cc R82_PRINT prints an R82.
c
c  Discussion:
c
c    An R82 is a vector of type R8, with two entries.
c
c    A format is used which suggests a coordinate pair:
c
c  Example:
c
c    Center : ( 1.23, 7.45 )
c
c  Licensing:
c
c    This code is distributed under the GNU LGPL license.
c
c  Modified:
c
c    03 September 2011
c
c  Author:
c
c    John Burkardt
c
c  Parameters:
c
c    Input, double precision A(2), the coordinates of the vector.
c
c    Input, character ( len = * ) TITLE, a title.
c
      implicit none

      double precision a(2)
      character * ( * ) title

      if ( 0 .lt. len_trim ( title ) ) then
        write ( *, '( 2x, a, a4, g14.6, a1, g14.6, a1 )' ) 
     &    trim ( title ), ' : (', a(1), ',', a(2), ')'
      else
        write ( *, '( 2x, a1, g14.6, a1, g14.6, a1 )' ) 
     &    '(', a(1), ',', a(2), ')'

      end if

      return
      end
      subroutine r82_swap ( x, y )

c*********************************************************************72
c
cc R82_SWAP swaps two R82 values.
c
c  Discussion:
c
c    An R82 is a vector of type R8, with two entries.
c
c  Licensing:
c
c    This code is distributed under the GNU LGPL license.
c
c  Modified:
c
c    03 September 2011
c
c  Author:
c
c    John Burkardt
c
c  Parameters:
c
c    Input/output, double precision X(2), Y(2).  On output, the values of X and
c    Y have been interchanged.
c
      implicit none

      integer dim_num
      parameter ( dim_num = 2 )

      integer i
      double precision x(dim_num)
      double precision y(dim_num)
      double precision t

      do i = 1, dim_num
        t    = x(i)
        x(i) = y(i)
        y(i) = t
      end do

      return
      end
      subroutine r82_uniform_ab ( a, b, seed, r )

c*********************************************************************72
c
cc R82_UNIFORM returns a pseudorandom R82 scaled to [A,B].
c
c  Discussion:
c
c    An R82 is a vector of type R8, with two entries.
c
c  Licensing:
c
c    This code is distributed under the GNU LGPL license.
c
c  Modified:
c
c    03 September 2011
c
c  Author:
c
c    John Burkardt
c
c  Parameters:
c
c    Input, double precision A, B, the minimum and maximum values.
c
c    Input/output, integer SEED, a seed for the random number
c    generator.
c
c    Output, double precision R(2), the randomly chosen value.
c
      implicit none

      integer dim_num
      parameter ( dim_num = 2 )

      double precision a
      double precision b
      double precision r(dim_num)
      double precision r8_uniform_ab
      integer i
      integer seed

      do i = 1, dim_num
        r(i) = r8_uniform_ab ( a, b, seed )
      end do

      return
      end
      subroutine r82poly2_print ( a, b, c, d, e, f )

c*********************************************************************72
c
cc R82POLY2_PRINT prints a second order polynomial in two variables.
c
c  Licensing:
c
c    This code is distributed under the GNU LGPL license.
c
c  Modified:
c
c    04 September 2011
c
c  Author:
c
c    John Burkardt
c
c  Parameters:
c
c    Input, double precision A, B, C, D, E, F, the coefficients.
c
      implicit none

      double precision a
      double precision b
      double precision c
      double precision d
      double precision e
      double precision f

      write ( *, 
     &  '( 2x, f8.4, '' * x^2 + '', f8.4, '' * y^2 + '', 
     &  f8.4, '' * xy  + '' )' ) 
     &  a, b, c

      write ( *, 
     &  '( 2x, f8.4, '' * x + '', f8.4, '' * y + '', 
     &  f8.4, '' = 0 '' )' ) d, e, f

      return
      end
      subroutine r82poly2_type ( a, b, c, d, e, f, type )

c*********************************************************************72
c
cc R82POLY2_TYPE analyzes a second order polynomial in two variables.
c
c  Discussion:
c
c    The polynomial has the form
c
c      A x^2 + B y^2 + C xy + Dx + Ey + F = 0
c
c    The possible types of the solution set are:
c
c     1: a hyperbola;
c        9x^2 -  4y^2       -36x - 24y -  36 = 0
c     2: a parabola;
c        4x^2 +  1y^2 - 4xy + 3x -  4y +   1 = 0;
c     3: an ellipse;
c        9x^2 + 16y^2       +36x - 32y -  92 = 0;
c     4: an imaginary ellipse (no real solutions);
c         x^2 +   y^2       - 6x - 10y + 115 = 0;
c     5: a pair of intersecting lines;
c                        xy + 3x -   y -   3 = 0
c     6: one point;
c         x^2 +  2y^2       - 2x + 16y +  33 = 0;
c     7: a pair of distinct parallel lines;
c                 y^2            -  6y +   8 = 0
c     8: a pair of imaginary parallel lines (no real solutions);
c                 y^2            -  6y +  10 = 0
c     9: a pair of coincident lines.
c                 y^2            -  2y +   1 = 0
c    10: a single line;
c                             2x -   y +   1 = 0;
c    11; all space;
c                                          0 = 0;
c    12; no solutions;
c                                          1 = 0;
c
c  Licensing:
c
c    This code is distributed under the GNU LGPL license.
c
c  Modified:
c
c    04 September 2011
c
c  Author:
c
c    John Burkardt
c
c  Reference:
c
c    Daniel Zwillinger, editor,
c    CRC Standard Mathematical Tables and Formulae,
c    CRC Press, 30th Edition, 1996, pages 282-284.
c
c  Parameters:
c
c    Input, double precision A, B, C, D, E, F, the coefficients.
c
c    Output, integer TYPE, indicates the type of the solution set.
c
      implicit none

      double precision a
      double precision b
      double precision c
      double precision d
      double precision delta
      double precision e
      double precision f
      double precision j
      double precision k
      integer type
c
c  Handle the degenerate case.
c
      if ( a .eq. 0.0D+00 .and. 
     &     b .eq. 0.0D+00 .and. 
     &     c .eq. 0.0D+00 ) then
        if ( d .eq. 0.0D+00 .and. e .eq. 0.0D+00 ) then
          if ( f .eq. 0.0D+00 ) then
            type = 11
          else
            type = 12
          end if
        else
          type = 10
        end if
        return
      end if

      delta = 
     &    8.0D+00 * a * b * f 
     &  + 2.0D+00 * c * e * d 
     &  - 2.0D+00 * a * e * e 
     &  - 2.0D+00 * b * d * d 
     &  - 2.0D+00 * f * c * c

      j = 4.0D+00 * a * b - c * c

      if ( delta .ne. 0.0D+00 ) then
        if ( j .lt. 0.0D+00 ) then
          type = 1
        else if ( j .eq. 0.0D+00 ) then
          type = 2
        else if ( 0.0D+00 .lt. j ) then
          if ( sign ( 1.0D+00, delta ) .ne. 
     &         sign ( 1.0D+00, ( a + b ) ) ) then
            type = 3
          else if ( sign ( 1.0D+00, delta ) .eq. 
     &              sign ( 1.0D+00, ( a + b ) ) ) then
            type = 4
          end if
        end if
      else if ( delta .eq. 0.0D+00 ) then
        if ( j .lt. 0.0D+00 ) then
          type = 5
        else if ( 0.0D+00 .lt. j ) then
          type = 6
        else if ( j .eq. 0.0D+00 ) then

          k = 4.0D+00 * ( a + b ) * f - d * d - e * e

          if ( k .lt. 0.0D+00 ) then
            type = 7
          else if ( 0.0D+00 .lt. k ) then
            type = 8
          else if ( k .eq. 0.0D+00 ) then
            type = 9
          end if

        end if
      end if

      return
      end
      subroutine r82poly2_type_print ( type )

c*********************************************************************72
c
cc R82POLY2_TYPE_PRINT prints the meaning of the output from R82POLY2_TYPE.
c
c  Licensing:
c
c    This code is distributed under the GNU LGPL license.
c
c  Modified:
c
c    04 September 2011
c
c  Author:
c
c    John Burkardt
c
c  Parameters:
c
c    Input, integer TYPE, the type index returned by R82POLY2_TYPE.
c
      implicit none

      integer type

      if ( type .eq. 1 ) then
        write ( *, '(a)' ) '  The set of solutions forms a hyperbola.'
      else if ( type .eq. 2 ) then
        write ( *, '(a)' ) '  The set of solutions forms a parabola.'
      else if ( type .eq. 3 ) then
        write ( *, '(a)' ) '  The set of solutions forms an ellipse.'
      else if ( type .eq. 4 ) then
        write ( *, '(a)' ) 
     &    '  The set of solutions forms an imaginary ellipse.'
        write ( *, '(a)' ) '  (There are no real solutions).'
      else if ( type .eq. 5 ) then
        write ( *, '(a)' ) 
     &    '  The set of solutions forms a pair of intersecting lines.'
      else if ( type .eq. 6 ) then
        write ( *, '(a)' ) '  The set of solutions is a single point.'
      else if ( type .eq. 7 ) then
        write ( *, '(a)' ) 
     &    '  The set of solutions form a pair of '
        write ( *, '(a)' ) '  distinct parallel lines.'
      else if ( type .eq. 8 ) then
        write ( *, '(a)' ) 
     &    '  The set of solutions forms a pair of '
        write ( *, '(a)' ) '  imaginary parallel lines.'
        write ( *, '(a)' ) '  (There are no real solutions).'
      else if ( type .eq. 9 ) then
        write ( *, '(a)' ) 
     &    '  The set of solutions forms a pair of coincident lines.'
      else if ( type .eq. 10 ) then
        write ( *, '(a)' ) '  The set of solutions forms a single line.'
      else if ( type .eq. 11 ) then
        write ( *, '(a)' ) '  The set of solutions is all space.'
      else if ( type .eq. 12 ) then
        write ( *, '(a)' ) '  The set of solutions is empty.'
      else
        write ( *, '(a)' ) '  This type index is unknown.'
      end if

      return
      end
      subroutine r82vec_max ( n, a, amax )

c*********************************************************************72
c
cc R82VEC_MAX returns the maximum value in an R82VEC.
c
c  Discussion:
c
c    An R82VEC is an array of pairs of R8's.
c
c  Licensing:
c
c    This code is distributed under the GNU LGPL license.
c
c  Modified:
c
c    04 September 2011
c
c  Author:
c
c    John Burkardt
c
c  Parameters:
c
c    Input, integer N, the number of entries in the array.
c
c    Input, double precision A(2,N), the array.
c
c    Output, double precision AMAX(2); the largest entries in each row.
c
      implicit none

      integer n

      double precision a(2,n)
      double precision amax(2)
      integer i
      integer j

      do i = 1, 2
        amax(i) = a(i,1)
        do j = 2, n
          amax(i) = max ( amax(i), a(i,j) )
        end do
      end do

      return
      end
      subroutine r82vec_min ( n, a, amin )

c*********************************************************************72
c
cc R82VEC_MIN returns the minimum value in an R82VEC.
c
c  Discussion:
c
c    An R82VEC is an array of pairs of R82's.
c
c  Licensing:
c
c    This code is distributed under the GNU LGPL license.
c
c  Modified:
c
c    11 September 2011
c
c  Author:
c
c    John Burkardt
c
c  Parameters:
c
c    Input, integer N, the number of entries in the array.
c
c    Input, double precision A(2,N), the array.
c
c    Output, double precision AMIN(2); the smallest entries in each row.
c
      implicit none

      integer n

      double precision a(2,n)
      double precision amin(2)
      integer i
      integer j

      do i = 1, 2
        amin(i) = a(i,1)
        do j = 2, n
          amin(i) = min ( amin(i), a(i,j) )
        end do
      end do

      return
      end
      subroutine r82vec_order_type ( n, a, order )

c*********************************************************************72
c
cc R82VEC_ORDER_TYPE finds the order type of an R82VEC.
c
c  Discussion:
c
c    An R82VEC is an array of pairs of R8 values.
c
c    The dictionary or lexicographic ordering is used.
c
c    (X1,Y1) .lt. (X2,Y2)  <=>  X1 .lt. X2 or ( X1 = X2 and Y1 .lt. Y2).
c
c  Licensing:
c
c    This code is distributed under the GNU LGPL license.
c
c  Modified:
c
c    11 September 2011
c
c  Author:
c
c    John Burkardt
c
c  Parameters:
c
c    Input, integer N, the number of entries of the array.
c
c    Input, double precision A(2,N), the array to be checked.
c
c    Output, integer ORDER, order indicator:
c    -1, no discernable order;
c    0, all entries are equal;
c    1, ascending order;
c    2, strictly ascending order;
c    3, descending order;
c    4, strictly descending order.
c
      implicit none

      integer n
      integer dim_num
      parameter ( dim_num = 2 )

      double precision a(dim_num,n)
      integer i
      integer order
c
c  Search for the first value not equal to A(1,1).
c
      i = 1

10    continue

        i = i + 1

        if ( n .lt. i ) then
          order = 0
          return
        end if

        if ( 
     &       a(1,1) .lt. a(1,i) .or. 
     &     ( a(1,1) .eq. a(1,i) .and. a(2,1) .lt. a(2,i) ) 
     &     ) then

          if ( i .eq. 2 ) then
            order = 2
          else
            order = 1
          end if

          go to 20

        else if ( 
     &      a(1,i) .lt. a(1,1)  .or. 
     &    ( a(1,i) .eq. a(1,1) .and. a(2,i) .lt. a(2,1) ) 
     &    ) then

          if ( i .eq. 2 ) then
            order = 4
          else
            order = 3
          end if

          go to 20

        end if

      go to 10

20    continue
c
c  Now we have a "direction".  Examine subsequent entries.
c
30    continue

        i = i + 1
        if ( n .lt. i ) then
          go to 40
        end if

        if ( order .eq. 1 ) then

          if ( 
     &        a(1,i) .lt. a(1,i-1) .or. 
     &      ( a(1,i) .eq. a(1,i-1) .and. a(2,i) .lt. a(2,i-1) ) 
     &      ) then
            order = -1
            go to 40
          end if

        else if ( order .eq. 2 ) then

          if ( 
     &        a(1,i) .lt. a(1,i-1) .or. 
     &      ( a(1,i) .eq. a(1,i-1) .and. a(2,i) .lt. a(2,i-1) ) 
     &      ) then
            order = -1
            go to 40
          else if ( 
     &       a(1,i) .eq. a(1,i-1) .and. a(2,i) .eq. a(2,i-1) ) then
            order = 1
          end if

        else if ( order .eq. 3 ) then

          if ( 
     &        a(1,i-1) .lt. a(1,i) .or. 
     &      ( a(1,i-1) .eq. a(1,i) .and. a(2,i-1) .lt. a(2,i) ) 
     &      ) then
            order = -1
            go to 40
          end if

        else if ( order .eq. 4 ) then

          if ( 
     &        a(1,i-1) .lt. a(1,i) .or. 
     &      ( a(1,i-1) .eq. a(1,i) .and. a(2,i-1) .lt. a(2,i) ) 
     &      ) then
            order = -1
            go to 40
          else if ( a(1,i) .eq. a(1,i-1) .and. 
     &              a(2,i) .eq. a(2,i-1) ) then
            order = 3
          end if

        end if

      go to 30

40    continue

      return
      end
      subroutine r82vec_part_quick_a ( n, a, l, r )

c*********************************************************************72
c
cc R82VEC_PART_QUICK_A reorders an R82VEC as part of a quick sort.
c
c  Discussion:
c
c    An R82VEC is an array of pairs of R82 values.
c
c    The routine reorders the entries of A.  Using A(1:2,1) as a
c    key, all entries of A that are less than or equal to the key will
c    precede the key, which precedes all entries that are greater than the key.
c
c  Example:
c
c    Input:
c
c      N = 8
c
c      A = ( (2,4), (8,8), (6,2), (0,2), (10,6), (10,0), (0,6), (4,8) )
c
c    Output:
c
c      L = 2, R = 4
c
c      A = ( (0,2), (0,6), (2,4), (8,8), (6,2), (10,6), (10,0), (4,8) )
c             -----------          ----------------------------------
c             LEFT          KEY    RIGHT
c
c  Licensing:
c
c    This code is distributed under the GNU LGPL license.
c
c  Modified:
c
c    16 September 2011
c
c  Author:
c
c    John Burkardt
c
c  Parameters:
c
c    Input, integer N, the number of entries of A.
c
c    Input/output, double precision A(2,N).  On input, the array to be checked.
c    On output, A has been reordered as described above.
c
c    Output, integer L, R, the indices of A that define the three
c    segments.  Let KEY = the input value of A(1:2,1).  Then
c    I <= L                 A(1:2,I) < KEY;
c         L < I < R         A(1:2,I) = KEY;
c                 R <= I    KEY < A(1:2,I).
c
      implicit none

      integer n
      integer dim_num
      parameter ( dim_num = 2 )

      double precision a(dim_num,n)
      integer i
      integer j
      double precision key(dim_num)
      integer l
      integer m
      integer r
      logical r8vec_eq
      logical r8vec_gt
      logical r8vec_lt

      if ( n .lt. 1 ) then
        write ( *, '(a)' ) ' '
        write ( *, '(a)' ) 'R82VEC_PART_QUICK_A - Fatal errorc'
        write ( *, '(a)' ) '  N < 1.'
        write ( *, '(a,i8)' ) '  N = ', n
        stop
      else if ( n .eq. 1 ) then
        l = 0
        r = 2
        return
      end if

      do i = 1, dim_num
        key(i) = a(i,1)
      end do

      m = 1
c
c  The elements of unknown size have indices between L+1 and R-1.
c
      l = 1
      r = n + 1

      do i = 2, n

        if ( r8vec_gt ( dim_num, a(1,l+1), key ) ) then
          r = r - 1
          call r8vec_swap ( dim_num, a(1,r), a(1,l+1) )
        else if ( r8vec_eq ( dim_num, a(1,l+1), key ) ) then
          m = m + 1
          call r8vec_swap ( dim_num, a(1,m), a(1,l+1) )
          l = l + 1
        else if ( r8vec_lt ( dim_num, a(1,l+1), key ) ) then
          l = l + 1
        end if

      end do
c
c  Now shift small elements to the left, and KEY elements to center.
c
      do j = 1, l - m
        do i = 1, dim_num
          a(i,j) = a(i,j+m)
        end do
      end do

      l = l - m

      do j = l + 1, l + m
        do i = 1, dim_num
          a(i,j) = key(i)
        end do
      end do

      return
      end
      subroutine r82vec_permute ( n, p, a )

c*********************************************************************72
c
cc R82VEC_PERMUTE permutes an R82VEC in place.
c
c  Discussion:
c
c    An R82VEC is an array of pairs of R8 values.
c
c    The same logic can be used to permute an array of objects of any
c    arithmetic type, or an array of objects of any complexity.  The only
c    temporary storage required is enough to store a single object.  The number
c    of data movements made is N + the number of cycles of order 2 or more,
c    which is never more than N + N/2.
c
c  Example:
c
c    Input:
c
c      N = 5
c      P = (   2,    4,    5,    1,    3 )
c      A = ( 1.0,  2.0,  3.0,  4.0,  5.0 )
c          (11.0, 22.0, 33.0, 44.0, 55.0 )
c
c    Output:
c
c      A    = (  2.0,  4.0,  5.0,  1.0,  3.0 )
c             ( 22.0, 44.0, 55.0, 11.0, 33.0 ).
c
c  Licensing:
c
c    This code is distributed under the GNU LGPL license.
c
c  Modified:
c
c    03 June 2009
c
c  Author:
c
c    John Burkardt
c
c  Parameters:
c
c    Input, integer N, the number of objects.
c
c    Input, integer P(N), the permutation.  P(I) = J means
c    that the I-th element of the output array should be the J-th
c    element of the input array.
c
c    Input/output, double precision A(2,N), the array to be permuted.
c
      implicit none

      integer n
      integer dim_num
      parameter ( dim_num = 2 )

      double precision a(dim_num,n)
      double precision a_temp(dim_num)
      integer base
      parameter ( base = 1 )
      integer dim
      integer ierror
      integer iget
      integer iput
      integer istart
      integer p(n)

      call perm_check ( n, p, base, ierror )

      if ( ierror .ne. 0 ) then
        write ( *, '(a)' ) ' '
        write ( *, '(a)' ) 'R82VEC_PERMUTE - Fatal error!'
        write ( *, '(a)' ) '  PERM_CHECK rejects this permutation.'
        stop
      end if
c
c  Search for the next element of the permutation that has not been used.
c
      do istart = 1, n

        if ( p(istart) .lt. 0 ) then

        else if ( p(istart) .eq. istart ) then

          p(istart) = - p(istart)

        else

          do dim = 1, dim_num
            a_temp(dim) = a(dim,istart)
          end do
          iget = istart
c
c  Copy the new value into the vacated entry.
c
10        continue

            iput = iget
            iget = p(iget)

            p(iput) = - p(iput)

            if ( iget .lt. 1 .or. n .lt. iget ) then
              write ( *, '(a)' ) ' '
              write ( *, '(a)' ) 'R82VEC_PERMUTE - Fatal error!'
              write ( *, '(a)' )
     &          '  A permutation index is out of range.'
              write ( *, '(a,i8,a,i8)' ) '  P(', iput, ') = ', iget
              stop
            end if

            if ( iget .eq. istart ) then
              do dim = 1, dim_num
                a(dim,iput) = a_temp(dim)
              end do
              go to 20
            end if

            do dim = 1, dim_num
              a(dim,iput) = a(dim,iget)
            end do

          go to 10

        end if

20      continue

      end do
c
c  Restore the signs of the entries.
c
      do istart = 1, n
        p(istart) = - p(istart)
      end do

      return
      end
      subroutine r82vec_print ( n, a, title )

c*********************************************************************72
c
cc R82VEC_PRINT prints an R82VEC.
c
c  Discussion:
c
c    An R82VEC is an array of pairs of R82's.
c
c  Licensing:
c
c    This code is distributed under the GNU LGPL license.
c
c  Modified:
c
c    28 November 2011
c
c  Author:
c
c    John Burkardt
c
c  Parameters:
c
c    Input, integer N, the number of components of the vector.
c
c    Input, double precision A(2,N), the R82 vector to be printed.
c
c    Input, character * ( * ) TITLE, a title.
c
      implicit none

      integer n
      integer dim_num
      parameter ( dim_num = 2 )

      double precision a(dim_num,n)
      integer i
      integer j
      character * ( * ) title

      write ( *, '(a)' ) ' '
      write ( *, '(a)' ) trim ( title )
      write ( *, '(a)' ) ' '
      do j = 1, n
        write ( *, '(2x,i8,(5g14.6))' ) j, ( a(i,j), i = 1, dim_num )
      end do

      return
      end
      subroutine r82vec_print_part ( n, a, max_print, title )

c*********************************************************************72
c
cc R82VEC_PRINT_PART prints "part" of an R82VEC.
c
c  Discussion:
c
c    The user specifies MAX_PRINT, the maximum number of lines to print.
c
c    If N, the size of the vector, is no more than MAX_PRINT, then
c    the entire vector is printed, one entry per line.
c
c    Otherwise, if possible, the first MAX_PRINT-2 entries are printed,
c    followed by a line of periods suggesting an omission,
c    and the last entry.
c
c  Licensing:
c
c    This code is distributed under the GNU LGPL license.
c
c  Modified:
c
c    09 November 2011
c
c  Author:
c
c    John Burkardt
c
c  Parameters:
c
c    Input, integer N, the number of entries of the vector.
c
c    Input, double precision A(2,N), the vector to be printed.
c
c    Input, integer MAX_PRINT, the maximum number of lines
c    to print.
c
c    Input, character * ( * ) TITLE, a title.
c
      implicit none

      integer n

      double precision a(2,n)
      integer i
      integer max_print
      character * ( * )  title

      if ( max_print .le. 0 ) then
        return
      end if

      if ( n .le. 0 ) then
        return
      end if

      write ( *, '(a)' ) ' '
      write ( *, '(a)' ) trim ( title )
      write ( *, '(a)' ) ' '

      if ( n .le. max_print ) then

        do i = 1, n
          write ( *, '(2x,i8,a,1x,g14.6,2x,g14.6)' ) 
     &      i, ':', a(1,i), a(2,i)
        end do

      else if ( 3 .le. max_print ) then

        do i = 1, max_print - 2
          write ( *, '(2x,i8,a,1x,g14.6,2x,g14.6)' ) 
     &      i, ':', a(1,i), a(2,i)
        end do
        write ( *, '(a)' ) '  ........  ..............  ..............'
        i = n
        write ( *, '(2x,i8,a,1x,g14.6,2x,g14.6)' ) 
     &    i, ':', a(1,i), a(2,i)

      else

        do i = 1, max_print - 1
          write ( *, '(2x,i8,a,1x,g14.6,2x,g14.6)' ) 
     &      i, ':', a(1,i), a(2,i)
        end do
        i = max_print
        write ( *, '(2x,i8,a,1x,g14.6,2x,g14.6,2x,a)' ) 
     &    i, ':', a(1,i), a(2,i), '...more entries...'

      end if

      return
      end
      subroutine r82vec_sort_heap_index_a ( n, a, indx )

c*********************************************************************72
c
cc R82VEC_SORT_HEAP_INDEX_A ascending index heaps an R82VEC.
c
c  Discussion:
c
c    An R82VEC is an array of R82's.
c
c    The sorting is not actually carried out.  Rather an index array is
c    created which defines the sorting.  This array may be used to sort
c    or index the array, or to sort or index related arrays keyed on the
c    original array.
c
c    Once the index array is computed, the sorting can be carried out
c    "implicitly:
c
c      A(1:2,INDX(1:N)) is sorted,
c
c    or explicitly, by the call
c
c      call r82vec_permute ( n, indx, a )
c
c    after which A(1:2,I), I = 1 to N is sorted.
c
c  Licensing:
c
c    This code is distributed under the GNU LGPL license.
c
c  Modified:
c
c    03 June 2009
c
c  Author:
c
c    John Burkardt
c
c  Parameters:
c
c    Input, integer N, the number of entries in the array.
c
c    Input, double precision A(2,N), an array to be index-sorted.
c
c    Output, integer INDX(N), the sort index.  The
c    I-th element of the sorted array is A(1:2,INDX(I)).
c
      implicit none

      integer dim_num
      parameter ( dim_num = 2 )
      integer n

      double precision a(dim_num,n)
      double precision aval(dim_num)
      integer dim
      integer i
      integer indx(n)
      integer indxt
      integer ir
      integer j
      integer l

      if ( n .lt. 1 ) then
        return
      end if

      do i = 1, n
        indx(i) = i
      end do

      if ( n .eq. 1 ) then
        return
      end if

      l = n / 2 + 1
      ir = n

10    continue

        if ( 1 .lt. l ) then

          l = l - 1
          indxt = indx(l)
          do dim = 1, dim_num
            aval(dim) = a(dim,indxt)
          end do

        else

          indxt = indx(ir)
          do dim = 1, dim_num
            aval(dim) = a(dim,indxt)
          end do
          indx(ir) = indx(1)
          ir = ir - 1

          if ( ir .eq. 1 ) then
            indx(1) = indxt
            go to 30
          end if

        end if

        i = l
        j = l + l

20      continue

        if ( j .le. ir ) then

          if ( j .lt. ir ) then
            if (   a(1,indx(j)) .lt.  a(1,indx(j+1)) .or.
     &           ( a(1,indx(j)) .eq. a(1,indx(j+1)) .and.
     &             a(2,indx(j)) .lt.  a(2,indx(j+1)) ) ) then
              j = j + 1
            end if
          end if

          if (   aval(1) .lt.  a(1,indx(j)) .or.
     &         ( aval(1) .eq. a(1,indx(j)) .and.
     &           aval(2) .lt.  a(2,indx(j)) ) ) then
            indx(i) = indx(j)
            i = j
            j = j + j
          else
            j = ir + 1
          end if

          go to 20

        end if

        indx(i) = indxt

      go to 10

30    continue

      return
      end
      subroutine r82vec_sort_quick_a ( n, a )

c*********************************************************************72
c
cc R82VEC_SORT_QUICK_A ascending sorts an R82VEC using quick sort.
c
c  Discussion:
c
c    An R82VEC is an array of R82's.
c
c  Licensing:
c
c    This code is distributed under the GNU LGPL license.
c
c  Modified:
c
c    16 September 2011
c
c  Author:
c
c    John Burkardt
c
c  Parameters:
c
c    Input, integer N, the number of entries in the array.
c
c    Input/output, double precision A(2,N).
c    On input, the array to be sorted.
c    On output, the array has been sorted.
c
      implicit none

      integer level_max
      parameter ( level_max = 30 )
      integer n
      integer dim_num
      parameter ( dim_num = 2 )

      double precision a(dim_num,n)
      integer base
      integer l_segment
      integer level
      integer n_segment
      integer rsave(level_max)
      integer r_segment

      if ( n .lt. 1 ) then
        write ( *, '(a)' ) ' '
        write ( *, '(a)' ) 'R82VEC_SORT_QUICK_A - Fatal error!'
        write ( *, '(a)' ) '  N < 1.'
        write ( *, '(a,i8)' ) '  N = ', n
        stop
      else if ( n .eq. 1 ) then
        return
      end if

      level = 1
      rsave(level) = n + 1
      base = 1
      n_segment = n

10    continue
c
c  Partition the segment.
c
        call r82vec_part_quick_a ( n_segment, a(1,base), l_segment, 
     &    r_segment )
c
c  If the left segment has more than one element, we need to partition it.
c
        if ( 1 .lt. l_segment ) then

          if ( level_max .lt. level ) then
            write ( *, '(a)' ) ' '
            write ( *, '(a)' ) 
     &        'R82VEC_SORT_QUICK_A - Fatal error!'
            write ( *, '(a,i8)' ) 
     &        '  Exceeding recursion maximum of ', level_max
            stop
          end if

          level = level + 1
          n_segment = l_segment
          rsave(level) = r_segment + base - 1
c
c  The left segment and the middle segment are sorted.
c  Must the right segment be partitioned?
c
        else if ( r_segment .lt. n_segment ) then

          n_segment = n_segment + 1 - r_segment
          base = base + r_segment - 1
c
c  Otherwise, we back up a level if there is an earlier one.
c
        else

20        continue

            if ( level .le. 1 ) then
              return
            end if

            base = rsave(level)
            n_segment = rsave(level-1) - rsave(level)
            level = level - 1

            if ( 0 .lt. n_segment ) then
              go to 30
            end if

          go to 20

30        continue

        end if

      go to 10

      return
      end
      function r83_norm ( x, y, z )

c**********************************************************************72
c
cc R83_NORM returns the Euclidean norm of an R83.
c
c  Discussion:
c
c    An R83 is a vector of 3 R8's.
c
c  Licensing:
c
c    This code is distributed under the GNU LGPL license.
c
c  Modified:
c
c    12 September 2011
c
c  Author:
c
c    John Burkardt
c
c  Parameters:
c
c    Input, double precision X, Y, Z, the vector.
c
c    Output, double precision R83_NORM, the norm of the vector.
c
      implicit none

      double precision r83_norm
      double precision x
      double precision y
      double precision z

      r83_norm = sqrt ( x * x + y * y + z * z )

      return
      end
      subroutine r83_normalize ( x, y, z )

c**********************************************************************72
c
cc R83_NORMALIZE normalizes an R83.
c
c  Discussion:
c
c    An R83 is a vector of 3 R8's.
c
c  Licensing:
c
c    This code is distributed under the GNU LGPL license.
c
c  Modified:
c
c    12 September 2011
c
c  Author:
c
c    John Burkardt
c
c  Parameters:
c
c    Input/output, double precision X, Y, Z, the components of the vector.
c
      implicit none

      double precision norm
      double precision x
      double precision y
      double precision z

      norm = sqrt ( x * x + y * y + z * z )

      if ( norm .ne. 0.0D+00 ) then
        x = x / norm
        y = y / norm
        z = z / norm
      end if

      return
      end
      subroutine r83_print ( x, y, z, title )

c**********************************************************************72
c
cc R83_PRINT prints an R83.
c
c  Discussion:
c
c    An R83 is a vector of 3 R8's.
c
c    A format is used which suggests a coordinate triple:
c
c  Example:
c
c    Center : ( 1.23, 7.45, -1.45 )
c
c  Licensing:
c
c    This code is distributed under the GNU LGPL license.
c
c  Modified:
c
c    12 September 2011
c
c  Author:
c
c    John Burkardt
c
c  Parameters:
c
c    Input, double precision X, Y, Z, the coordinates of the vector.
c
c    Input, character * ( * ) TITLE, a title.
c
      implicit none

      character * ( * ) title
      double precision x
      double precision y
      double precision z

      if ( 0 .lt. len_trim ( title ) ) then
        write ( *, '( 2x, a, a4, g14.6, a1, g14.6, a1, g14.6, a1 )' ) 
     &    trim ( title ), ' : (', x, ',', y, ',', z, ')'
      else
        write ( *, '( 2x, a1, g14.6, a1, g14.6, a1, g14.6, a1 )' ) 
     &    '(', x, ',', y, ',', z, ')'
      end if

      return
      end
      subroutine r83_swap ( x, y )

c**********************************************************************72
c
cc R83_SWAP swaps two R83's.
c
c  Discussion:
c
c    An R83 is a vector of 3 R8's.
c
c  Licensing:
c
c    This code is distributed under the GNU LGPL license.
c
c  Modified:
c
c    12 September 2011
c
c  Author:
c
c    John Burkardt
c
c  Parameters:
c
c    Input/output, double precision X(3), Y(3).  On output, the values
c    of X and Y have been interchanged.
c
      implicit none

      integer dim_num
      parameter ( dim_num = 3 )

      integer i
      double precision x(dim_num)
      double precision y(dim_num)
      double precision z

      do i = 1, dim_num
        z    = x(i)
        x(i) = y(i)
        y(i) = z
      end do

      return
      end
      subroutine r83vec_max ( n, a, amax )

c*********************************************************************72
c
cc R83VEC_MAX returns the maximum value in an R83VEC.
c
c  Discussion:
c
c    An R83VEC is an array of R83's.
c
c  Licensing:
c
c    This code is distributed under the GNU LGPL license.
c
c  Modified:
c
c    10 November 2011
c
c  Author:
c
c    John Burkardt
c
c  Parameters:
c
c    Input, integer N, the number of entries in the array.
c
c    Input, double precision A(3,N), the array.
c
c    Output, double precision AMAX(3); the largest entries in each row.
c
      implicit none

      integer n

      double precision a(3,n)
      double precision amax(3)
      integer i
      integer j

      do i = 1, 3
        amax(i) = a(i,1)
        do j = 2, n
          amax(i) = max ( amax(i), a(i,j) )
        end do
      end do

      return
      end
      subroutine r83vec_min ( n, a, amin )

c*********************************************************************72
c
cc R83VEC_MIN returns the minimum value in an R83VEC.
c
c  Discussion:
c
c    An R83VEC is an array of R83's.
c
c  Licensing:
c
c    This code is distributed under the GNU LGPL license.
c
c  Modified:
c
c    10 November 2011
c
c  Author:
c
c    John Burkardt
c
c  Parameters:
c
c    Input, integer N, the number of entries in the array.
c
c    Input, double precision A(3,N), the array.
c
c    Output, double precision AMIN(3); the smallest entries in each row.
c
      implicit none

      integer n

      double precision a(3,n)
      double precision amin(3)
      integer i
      integer j

      do i = 1, 3
        amin(i) = a(i,1)
        do j = 2, n
          amin(i) = min ( amin(i), a(i,j) )
        end do
      end do

      return
      end
      subroutine r83vec_normalize ( n, x )

c**********************************************************************72
c
cc R83VEC_NORMALIZE normalizes each R83 in an R83VEC.
c
c  Discussion:
c
c    An R83VEC is a vector of R83's.
c
c    An R83 is a vector of 3 R8's.
c
c  Licensing:
c
c    This code is distributed under the GNU LGPL license.
c
c  Modified:
c
c    12 September 2011
c
c  Author:
c
c    John Burkardt
c
c  Parameters:
c
c    Input, integer N, the number of R83 vectors.
c
c    Input/output, double precision X(3,N), the coordinates of N R83 vectors.
c    On output, the nonzero vectors have been scaled to have unit L2 norm.
c
      implicit none

      integer n
      integer dim_num
      parameter ( dim_num = 3 )

      integer i
      integer j
      double precision norm
      double precision x(dim_num,n)

      do j = 1, n

        norm = 0.0D+00
        do i = 1, dim_num
          norm = norm + x(i,j) * x(i,j)
        end do
        norm = sqrt ( norm )

        if ( norm .ne. 0.0D+00 ) then
          do i = 1, dim_num
            x(i,j) = x(i,j) / norm
          end do
        end if

      end do

      return
      end
      subroutine r83vec_print_part ( n, a, max_print, title )

c*********************************************************************72
c
cc R83VEC_PRINT_PART prints "part" of an R83VEC.
c
c  Discussion:
c
c    The user specifies MAX_PRINT, the maximum number of lines to print.
c
c    If N, the size of the vector, is no more than MAX_PRINT, then
c    the entire vector is printed, one entry per line.
c
c    Otherwise, if possible, the first MAX_PRINT-2 entries are printed,
c    followed by a line of periods suggesting an omission,
c    and the last entry.
c
c  Licensing:
c
c    This code is distributed under the GNU LGPL license.
c
c  Modified:
c
c    09 November 2011
c
c  Author:
c
c    John Burkardt
c
c  Parameters:
c
c    Input, integer N, the number of entries of the vector.
c
c    Input, double precision A(3,N), the vector to be printed.
c
c    Input, integer MAX_PRINT, the maximum number of lines
c    to print.
c
c    Input, character * ( * ) TITLE, a title.
c
      implicit none

      integer n

      double precision a(3,n)
      integer i
      integer max_print
      character * ( * )  title

      if ( max_print .le. 0 ) then
        return
      end if

      if ( n .le. 0 ) then
        return
      end if

      write ( *, '(a)' ) ' '
      write ( *, '(a)' ) trim ( title )
      write ( *, '(a)' ) ' '

      if ( n .le. max_print ) then

        do i = 1, n
          write ( *, '(2x,i8,a,1x,g14.6,2x,g14.6,2x,g14.6)' ) 
     &      i, ':', a(1,i), a(2,i), a(3,i)
        end do

      else if ( 3 .le. max_print ) then

        do i = 1, max_print - 2
          write ( *, '(2x,i8,a,1x,g14.6,2x,g14.6,2x,g14.6)' ) 
     &      i, ':', a(1,i), a(2,i), a(3,i)
        end do
        write ( *, '(a)' ) 
     &    '  ........  ..............  ..............  ..............'
        i = n
        write ( *, '(2x,i8,a,1x,g14.6,2x,g14.6,2x,g14.6)' ) 
     &    i, ':', a(1,i), a(2,i), a(3,i)

      else

        do i = 1, max_print - 1
          write ( *, '(2x,i8,a,1x,g14.6,2x,g14.6,2x,g14.6)' ) 
     &      i, ':', a(1,i), a(2,i), a(3,i)
        end do
        i = max_print
        write ( *, '(2x,i8,a,1x,g14.6,2x,g14.6,2x,g14.6,2x,a)' ) 
     &    i, ':', a(1,i), a(2,i), a(3,i), '...more entries...'

      end if

      return
      end
      subroutine r84_normalize ( v )

c**********************************************************************72
c
cc R84_NORMALIZE normalizes an R84.
c
c  Discussion:
c
c    An R84 is a vector of four R8's.
c
c  Licensing:
c
c    This code is distributed under the GNU LGPL license.
c
c  Modified:
c
c    12 September 2011
c
c  Author:
c
c    John Burkardt
c
c  Parameters:
c
c    Input/output, double precision V(4), the components of the vector.
c
      implicit none

      integer dim_num
      parameter ( dim_num = 4 )

      integer i
      double precision norm
      double precision v(dim_num)

      norm = 0.0D+00
      do i = 1, dim_num
        norm = norm + v(i) * v(i)
      end do
      norm = sqrt ( norm )

      if ( norm .ne. 0.0D+00 ) then
        do i = 1, dim_num
          v(i) = v(i) / norm
        end do
      end if

      return
      end
      subroutine r8block_expand_linear ( l, m, n, x, lfat, mfat, nfat, 
     &  xfat )

c*********************************************************************72
c
cc R8BLOCK_EXPAND_LINEAR linearly interpolates new data into an R8BLOCK.
c
c  Discussion:
c
c    An R8BLOCK is a 3D array of R8 values.
c
c    In this routine, the expansion is specified by giving the number
c    of intermediate values to generate between each pair of original
c    data rows and columns.
c
c    The interpolation is not actually linear.  It uses the functions
c
c      1, x, y, z, xy, xz, yz, xyz.
c
c  Licensing:
c
c    This code is distributed under the GNU LGPL license.
c
c  Modified:
c
c    02 December 2011
c
c  Author:
c
c    John Burkardt
c
c  Parameters:
c
c    Input, integer L, M, N, the dimensions of the input data.
c
c    Input, double precision X(L,M,N), the original data.
c
c    Input, integer LFAT, MFAT, NFAT, the number of data values
c    to interpolate original data values in the first, second and third
c    dimensions.
c
c    Output, double precision XFAT(L2,M2,N2), the fattened data, where
c    L2 = (L-1)*(LFAT+1)+1,
c    M2 = (M-1)*(MFAT+1)+1,
c    N2 = (N-1)*(NFAT+1)+1.
c
      implicit none

      integer l
      integer lfat
      integer m
      integer mfat
      integer n
      integer nfat

      integer i
      integer ihi
      integer ii
      integer iii
      integer ip1
      integer j
      integer jhi
      integer jj
      integer jjj
      integer jp1
      integer k
      integer khi
      integer kk
      integer kkk
      integer kp1
      double precision r
      double precision rn
      double precision s
      double precision sn
      double precision t
      double precision tn
      double precision x(l,m,n)
      double precision x000
      double precision x001
      double precision x010
      double precision x011
      double precision x100
      double precision x101
      double precision x110
      double precision x111
      double precision 
     &  xfat((l-1)*(lfat+1)+1,(m-1)*(mfat+1)+1,(n-1)*(nfat+1)+1)

      do i = 1, l

        if ( i .lt. l ) then
          ihi = lfat
        else
          ihi = 0
        end if

        do j = 1, m

          if ( j .lt. m ) then
            jhi = mfat
          else
            jhi = 0
          end if

          do k = 1, n

            if ( k .lt. n ) then
              khi = nfat
            else
              khi = 0
            end if

            if ( i .lt. l ) then
              ip1 = i + 1
            else
              ip1 = i
            end if

            if ( j .lt. m ) then
              jp1 = j + 1
            else
              jp1 = j
            end if

            if ( k .lt. n ) then
              kp1 = k + 1
            else
              kp1 = k
            end if

            x000 = x(i,j,k)
            x001 = x(i,j,kp1)
            x100 = x(ip1,j,k)
            x101 = x(ip1,j,kp1)
            x010 = x(i,jp1,k)
            x011 = x(i,jp1,kp1)
            x110 = x(ip1,jp1,k)
            x111 = x(ip1,jp1,kp1)

            do ii = 0, ihi

              r = dble ( ii ) / dble ( ihi + 1 )

              do jj = 0, jhi

                s = dble ( jj ) / dble ( jhi + 1 )

                do kk = 0, khi

                  t = dble ( kk ) / dble ( khi + 1 )

                  iii = 1 + ( i - 1 ) * ( lfat + 1 ) + ii
                  jjj = 1 + ( j - 1 ) * ( mfat + 1 ) + jj
                  kkk = 1 + ( k - 1 ) * ( nfat + 1 ) + kk

                  rn = 1.0D+00 - r
                  sn = 1.0D+00 - s
                  tn = 1.0D+00 - t

                  xfat(iii,jjj,kkk) = 
     &                x000 * rn * sn * tn 
     &              + x001 * rn * sn * t 
     &              + x010 * rn * s  * tn 
     &              + x011 * rn * s  * t  
     &              + x100 * r  * sn * tn
     &              + x101 * r  * sn * t
     &              + x110 * r  * s  * tn
     &              + x111 * r  * s  * t

                end do

              end do

            end do

          end do

        end do

      end do

      return
      end
      subroutine r8block_print ( l, m, n, a, title )

c*********************************************************************72
c
cc R8BLOCK_PRINT prints an R8BLOCK.
c
c  Discussion:
c
c    An R8BLOCK is a 3D array of R8 values.
c
c  Licensing:
c
c    This code is distributed under the GNU LGPL license.
c
c  Modified:
c
c    12 September 2011
c
c  Author:
c
c    John Burkardt
c
c  Parameters:
c
c    Input, integer L, M, N, the dimensions of the block.
c
c    Input, double precision A(L,M,N), the matrix to be printed.
c
c    Input, character * ( * ) TITLE, a title.
c
      implicit none

      integer l
      integer m
      integer n

      double precision a(l,m,n)
      integer i
      integer j
      integer jhi
      integer jlo
      integer k
      character * ( * )  title

      write ( *, '(a)' ) ' '
      write ( *, '(a)' ) trim ( title )

      do k = 1, n

        write ( *, '(a)' ) ' '
        write ( *, '(a,i8)' ) '  K = ', k
        write ( *, '(a)' ) ' '

        do jlo = 1, m, 5
          jhi = min ( jlo + 4, m )
          write ( *, '(a)' ) ' '
          write ( *, '(10x,5(i8,6x))' ) (j, j = jlo, jhi )
          write ( *, '(a)' ) ' '
          do i = 1, l
            write ( *, '(2x,i8,5g14.6)' ) i, ( a(i,j,k), j = jlo, jhi )
          end do
        end do

      end do

      return
      end
      subroutine r8col_compare ( m, n, a, i, j, value )

c*********************************************************************72
c
cc R8COL_COMPARE compares columns in an R8COL.
c
c  Discussion:
c
c    An R8COL is an M by N array of R8 values.
c    It is regarded as an array of N columns of length M.
c
c  Example:
c
c    Input:
c
c      M = 3, N = 4, I = 2, J = 4
c
c      A = (
c        1.  2.  3.  4.
c        5.  6.  7.  8.
c        9. 10. 11. 12. )
c
c    Output:
c
c      VALUE = -1
c
c  Licensing:
c
c    This code is distributed under the GNU LGPL license.
c
c  Modified:
c
c    24 August 2008
c
c  Author:
c
c    John Burkardt
c
c  Parameters:
c
c    Input, integer M, N, the number of rows and columns.
c
c    Input, double precision A(M,N), the M by N array.
c
c    Input, integer I, J, the columns to be compared.
c    I and J must be between 1 and N.
c
c    Output, integer VALUE, the results of the comparison:
c    -1, column I < column J,
c     0, column I = column J,
c    +1, column J < column I.
c
      implicit none

      integer m
      integer n

      double precision a(m,n)
      integer i
      integer isgn
      integer j
      integer k
      integer value
c
c  Check.
c
      if ( i .lt. 1 .or. n .lt. i ) then
        write ( *, '(a)' ) ' '
        write ( *, '(a)' ) 'R8COL_COMPARE - Fatal error!'
        write ( *, '(a)' ) '  Column index I is out of bounds.'
        write ( *, '(a,i8)' ) '  I = ', i
        stop
      end if

      if ( j .lt. 1 .or. n .lt. j ) then
        write ( *, '(a)' ) ' '
        write ( *, '(a)' ) 'R8COL_COMPARE - Fatal error!'
        write ( *, '(a)' ) '  Column index J is out of bounds.'
        write ( *, '(a,i8)' ) '  J = ', j
        stop
      end if

      value = 0

      if ( i .eq. j ) then
        return
      end if

      k = 1

10    continue

      if ( k .le. m ) then

        if ( a(k,i) .lt. a(k,j) ) then
          value = -1
          return
        else if ( a(k,j) .lt. a(k,i) ) then
          value = +1
          return
        end if

        k = k + 1

        go to 10

      end if

      return
      end
      subroutine r8col_duplicates ( m, n, n_unique, seed, a )

c*********************************************************************72
c
cc R8COL_DUPLICATES generates an R8COL with some duplicate columns.
c
c  Discussion:
c
c    An R8COL is an M by N array of R8's, regarded as an array of N columns,
c    each of length M.
c
c    This routine generates a random R8COL with a specified number of
c    duplicate columns.
c
c  Licensing:
c
c    This code is distributed under the GNU LGPL license.
c
c  Modified:
c
c    21 July 2010
c
c  Author:
c
c    John Burkardt
c
c  Parameters:
c
c    Input, integer M, the number of rows in each column of A.
c
c    Input, integer N, the number of columns in A.
c
c    Input, integer N_UNIQUE, the number of unique columns in A.
c    1 <= N_UNIQUE <= N.
c
c    Input/output, integer SEED, a seed for the random
c    number generator.
c
c    Output, double precision A(M,N), the array.
c
      implicit none

      integer m
      integer n

      double precision a(m,n)
      integer i
      integer i4_uniform_ab
      integer j1
      integer j2
      integer n_unique
      integer seed
      double precision temp(m)

      if ( n_unique .lt. 1 .or. n .lt. n_unique ) then
        write ( *, '(a)' ) ' '
        write ( *, '(a)' ) 'R8COL_DUPLICATES - Fatal error!'
        write ( *, '(a)' ) '  1 <= N_UNIQUE <= N is required.'
        stop
      end if

      call r8mat_uniform_01 ( m, n_unique, seed, a )
c
c  Randomly copy unique columns.
c
      do j1 = n_unique + 1, n
        j2 = i4_uniform_ab ( 1, n_unique, seed )
        do i = 1, m
          a(i,j1) = a(i,j2)
        end do
      end do
c
c  Permute the columns.
c
      do j1 = 1, n
        j2 = i4_uniform_ab ( j1, n, seed )
        do i = 1, m
          temp(i) = a(i,j1)
          a(i,j1) = a(i,j2)
          a(i,j2) = temp(i)
        end do
      end do

      return
      end
      subroutine r8col_find ( m, n, a, x, col )

c*********************************************************************72
c
cc R8COL_FIND seeks a column value in an R8COL.
c
c  Discussion:
c
c    An R8COL is an M by N array of R8 values, regarded
c    as an array of N columns of length M.
c
c  Example:
c
c    Input:
c
c      M = 3,
c      N = 4,
c
c      A = (
c        1.  2.  3.  4.
c        5.  6.  7.  8.
c        9. 10. 11. 12. )
c
c      x = ( 3.,
c            7.,
c           11. )
c
c    Output:
c
c      COL = 3
c
c  Licensing:
c
c    This code is distributed under the GNU LGPL license.
c
c  Modified:
c
c    31 August 2008
c
c  Author:
c
c    John Burkardt
c
c  Parameters:
c
c    Input, integer M, N, the number of rows and columns.
c
c    Input, double precision A(M,N), a table of numbers, regarded as
c    N columns of vectors of length M.
c
c    Input, double precision X(M), a vector to be matched with a column of A.
c
c    Output, integer COL, the index of the first column of A
c    which exactly matches every entry of X, or -1 if no match
c    could be found.
c
      implicit none

      integer m
      integer n

      double precision a(m,n)
      integer col
      integer i
      integer j
      double precision x(m)

      col = -1

      do j = 1, n

        col = j

        do i = 1, m
          if ( x(i) .ne. a(i,j) ) then
            col = -1
            go to 10
          end if
        end do

10      continue

        if ( col .ne. -1 ) then
          return
        end if

      end do

      return
      end
      subroutine r8col_first_index ( m, n, a, tol, first_index )

c*********************************************************************72
c
cc R8COL_FIRST_INDEX indexes the first occurrence of values in an R8COL.
c
c  Discussion:
c
c    An R8COL is an M by N array of R8 values.
c    It is regarded as an array of N columns of length M.
c
c    For element A(1:M,J) of the matrix, FIRST(J) is the index in A of
c    the first column whose entries are equal to A(1:M,J).
c
c  Licensing:
c
c    This code is distributed under the GNU LGPL license.
c
c  Modified:
c
c    24 August 2008
c
c  Author:
c
c    John Burkardt
c
c  Parameters:
c
c    Input, integer M, N, the number of rows and columns of A.
c    The length of an "element" of A, and the number of "elements".
c
c    Input, double precision A(M,N), the array.
c
c    Input, double precision TOL, a tolerance for equality.
c
c    Output, integer FIRST_INDEX(N), the first occurrence index.
c
      implicit none

      integer m
      integer n

      double precision a(m,n)
      double precision diff
      integer first_index(n)
      integer i
      integer j1
      integer j2
      double precision tol

      do j1 = 1, n
        first_index(j1) = -1
      end do

      do j1 = 1, n

        if ( first_index(j1) .eq. -1 ) then

          first_index(j1) = j1

          do j2 = j1 + 1, n
            diff = 0.0D+00
            do i = 1, m
              diff = diff + abs ( a(i,j1) - a(i,j2) )
            end do
            if ( diff .le. tol ) then
              first_index(j2) = j1
            end if
          end do

        end if

      end do

      return
      end
      subroutine r8col_insert ( n_max, m, n, a, x, col )

c*********************************************************************72
c
cc R8COL_INSERT inserts a column into an R8COL.
c
c  Discussion:
c
c    An R8COL is an M by N array of R8's, regarded as an array of N columns,
c    each of length M.
c
c  Example:
c
c    Input:
c
c      N_MAX = 10,
c      M = 3,
c      N = 4,
c
c      A = (
c        1.  2.  3.  4.
c        5.  6.  7.  8.
c        9. 10. 11. 12. )
c
c      X = ( 3., 4., 18. )
c
c    Output:
c
c      N = 5,
c
c      A = (
c        1.  2.  3.  3.  4.
c        5.  6.  4.  7.  8.
c        9. 10. 18. 11. 12. )
c
c      COL = 3
c
c  Licensing:
c
c    This code is distributed under the GNU LGPL license.
c
c  Modified:
c
c    08 May 2010
c
c  Author:
c
c    John Burkardt
c
c  Parameters:
c
c    Input, integer N_MAX, the maximum number of columns in A.
c
c    Input, integer M, the number of rows.
c
c    Input/output, integer N, the number of columns.
c    If the new column is inserted into the table, then the output
c    value of N will be increased by 1.
c
c    Input/output, double precision A(M,N_MAX), a table of numbers, regarded
c    as an array of columns.  The columns must have been sorted
c    lexicographically.
c
c    Input, double precision X(M), a vector of data which will be inserted
c    into the table if it does not already occur.
c
c    Output, integer COL.
c    I, X was inserted into column I.
c    -I, column I was already equal to X.
c    0, N = N_MAX.
c
      implicit none

      integer m
      integer n_max

      double precision a(m,n_max)
      integer col
      integer high
      integer i
      integer isgn
      integer j
      integer low
      integer mid
      integer n
      double precision x(m)
c
c  Refuse to work if N_MAX <= N.
c
      if ( n_max .le. n ) then
        col = 0
        return
      end if
c
c  Stick X temporarily in column N+1, just so it's easy to use R8COL_COMPARE.
c
      do i = 1, m
        a(i,n+1) = x(i)
      end do
c
c  Do a binary search.
c
      low = 1
      high = n

10    continue

        if ( high .lt. low ) then
          col = low
          go to 20
        end if

        mid = ( low + high ) / 2

        call r8col_compare ( m, n + 1, a, mid, n + 1, isgn )

        if ( isgn .eq. 0 ) then
          col = -mid
          return
        else if ( isgn .eq. -1 ) then
          low = mid + 1
        else if ( isgn .eq. +1 ) then
          high = mid - 1
        end if

      go to 10

20    continue
c
c  Shift part of the table up to make room.
c
      do j = n, col, -1
        do i = 1, m
          a(i,j+1) = a(i,j)
        end do
      end do
c
c  Insert the new column.
c
      do i = 1, m
        a(i,col) = x(i)
      end do

      n = n + 1

      return
      end
      subroutine r8col_max ( m, n, a, amax )

c*********************************************************************72
c
cc R8COL_MAX returns the maximums in an R8COL.
c
c  Discussion:
c
c    An R8COL is an M by N array of R8's, regarded as an array of N columns,
c    each of length M.
c
c  Licensing:
c
c    This code is distributed under the GNU LGPL license.
c
c  Modified:
c
c    08 May 2010
c
c  Author:
c
c    John Burkardt
c
c  Parameters:
c
c    Input, integer M, N, the number of rows and columns.
c
c    Input, double precision A(M,N), the array to be examined.
c
c    Output, double precision AMAX(N), the maximums of the columns.
c
      implicit none

      integer m
      integer n

      double precision a(m,n)
      double precision amax(n)
      integer i
      integer j

      do j = 1, n

        amax(j) = a(1,j)
        do i = 2, m
          amax(j) = max ( amax(j), a(i,j) )
        end do

      end do

      return
      end
      subroutine r8col_max_index ( m, n, a, imax )

c*********************************************************************72
c
cc R8COL_MAX_INDEX returns the indices of column maximums in an R8COL.
c
c  Discussion:
c
c    An R8COL is an M by N array of R8's, regarded as an array of N columns,
c    each of length M.
c
c  Licensing:
c
c    This code is distributed under the GNU LGPL license.
c
c  Modified:
c
c    08 May 2010
c
c  Author:
c
c    John Burkardt
c
c  Parameters:
c
c    Input, integer M, N, the number of rows and columns.
c
c    Input, double precision A(M,N), the array to be examined.
c
c    Output, integer IMAX(N); IMAX(I) is the row of A in which
c    the maximum for column I occurs.
c
      implicit none

      integer m
      integer n

      double precision a(m,n)
      double precision amax
      integer i
      integer imax(n)
      integer j

      do j = 1, n

        imax(j) = 1
        amax = a(1,j)
        do i = 2, m
          if ( amax .lt. a(i,j) ) then
            imax(j) = i
            amax = a(i,j)
          end if
        end do

      end do

      return
      end
      subroutine r8col_max_one ( m, n, a )

c*********************************************************************72
c
cc R8COL_MAX_ONE rescales an R8COL so each column maximum is 1.
c
c  Discussion:
c
c    An R8COL is an M by N array of R8's, regarded as an array of N columns,
c    each of length M.
c
c  Licensing:
c
c    This code is distributed under the GNU LGPL license.
c
c  Modified:
c
c    08 May 2010
c
c  Author:
c
c    John Burkardt
c
c  Parameters:
c
c    Input, integer M, N, the number of rows and columns.
c
c    Input/output, double precision A(M,N), the array to be rescaled.
c
      implicit none

      integer m
      integer n

      double precision a(m,n)
      integer i
      integer i_big
      integer j
      double precision temp

      do j = 1, n

        i_big = 1
        do i = 2, m
          if ( abs ( a(i_big,j) ) .lt. abs ( a(i,j) ) ) then
            i_big = i
          end if
        end do

        if ( a(i_big,j) .ne. 0.0D+00 ) then
          temp = a(i_big,j)
          do i = 1, m
            a(i,j) = a(i,j) / temp
          end do
        end if

      end do

      return
      end
      subroutine r8col_mean ( m, n, a, mean )

c*********************************************************************72
c
cc R8COL_MEAN returns the column means of an R8COL.
c
c  Discussion:
c
c    An R8COL is an M by N array of R8 values, regarded
c    as an array of N columns of length M.
c
c  Example:
c
c    A =
c      1  2  3
c      2  6  7
c
c    MEAN =
c      1.5  4.0  5.0
c
c  Licensing:
c
c    This code is distributed under the GNU LGPL license.
c
c  Modified:
c
c    13 January 2008
c
c  Author:
c
c    John Burkardt
c
c  Parameters:
c
c    Input, integer M, N, the number of rows and columns.
c
c    Input, double precision A(M,N), the array to be examined.
c
c    Output, double precision MEAN(N), the means, or averages, of the columns.
c
      implicit none

      integer m
      integer n

      double precision a(m,n)
      double precision a_sum
      integer i
      integer j
      double precision mean(n)

      do j = 1, n

        a_sum = 0.0D+00
        do i = 1, m
          a_sum = a_sum + a(i,j)
        end do

        mean(j) = a_sum / dble ( m )

      end do

      return
      end
      subroutine r8col_min ( m, n, a, amin )

c*********************************************************************72
c
cc R8COL_MIN returns the minimums in an R8COL.
c
c  Discussion:
c
c    An R8COL is an M by N array of R8's, regarded as an array of N columns,
c    each of length M.
c
c  Licensing:
c
c    This code is distributed under the GNU LGPL license.
c
c  Modified:
c
c    08 May 2010
c
c  Author:
c
c    John Burkardt
c
c  Parameters:
c
c    Input, integer M, N, the number of rows and columns.
c
c    Input, double precision A(M,N), the array to be examined.
c
c    Output, double precision AMIN(N), the minimums of the columns.
c
      implicit none

      integer m
      integer n

      double precision a(m,n)
      double precision amin(n)
      integer i
      integer j

      do j = 1, n

        amin(j) = a(1,j)
        do i = 2, m
          amin(j) = min ( amin(j), a(i,j) )
        end do

      end do

      return
      end
      subroutine r8col_min_index ( m, n, a, imin )

c*********************************************************************72
c
cc R8COL_MIN_INDEX returns the indices of column minimums in an R8COL.
c
c  Discussion:
c
c    An R8COL is an M by N array of R8's, regarded as an array of N columns,
c    each of length M.
c
c  Licensing:
c
c    This code is distributed under the GNU LGPL license.
c
c  Modified:
c
c    08 May 2010
c
c  Author:
c
c    John Burkardt
c
c  Parameters:
c
c    Input, integer M, N, the number of rows and columns.
c
c    Input, double precision A(M,N), the array to be examined.
c
c    Output, integer IMIN(N); IMIN(I) is the row of A in which
c    the minimum for column I occurs.
c
      implicit none

      integer m
      integer n

      double precision a(m,n)
      double precision amin
      integer i
      integer imin(n)
      integer j

      do j = 1, n

        imin(j) = 1
        amin = a(1,j)
        do i = 2, m
          if ( a(i,j) .lt. amin ) then
            imin(j) = i
            amin = a(i,j)
          end if
        end do

      end do

      return
      end
      subroutine r8col_normalize_li ( m, n, a )

c*********************************************************************72
c
cc R8COL_NORMALIZE_LI normalizes an R8COL with the column infinity norm.
c
c  Discussion:
c
c    Each column is scaled so that the entry of maximum norm has the value 1.
c
c  Licensing:
c
c    This code is distributed under the GNU LGPL license.
c
c  Modified:
c
c    08 February 2012
c
c  Author:
c
c    John Burkardt
c
c  Parameters:
c
c    Input, integer M, N, the number of rows and columns.
c
c    Input/output, double precision A(M,N), the array to be normalized.
c
      implicit none

      integer m
      integer n

      double precision a(m,n)
      double precision c
      integer i
      integer j

      do j = 1, n

        c = a(1,j)

        do i = 2, m
          if ( abs ( c ) .lt. abs ( a(i,j) ) ) then
            c = a(i,j)
          end if
        end do

        if ( c .ne. 0.0D+00 ) then
          do i = 1, m
            a(i,j) = a(i,j) / c
          end do
        end if

      end do

      return
      end
      subroutine r8col_part_quick_a ( m, n, a, l, r )

c*********************************************************************72
c
cc R8COL_PART_QUICK_A reorders the columns of an array as part of a quick sort.
c
c  Discussion:
c
c    The routine reorders the columns of A.  Using A(1:M,1) as a
c    key, all entries of A that are less than or equal to the key will
c    precede the key, which precedes all entries that are greater than the key.
c
c  Example:
c
c    Input:
c
c      M = 2, N = 8
c      A = ( 2  8  6  0 10 10  0  5
c            4  8  2  2  6  0  6  8 )
c
c    Output:
c
c      L = 2, R = 4
c
c      A = (  0  0  2  8  6 10 10  4
c             2  6  4  8  2  6  0  8 )
c             ----     -------------
c             LEFT KEY     RIGHT
c
c  Licensing:
c
c    This code is distributed under the GNU LGPL license.
c
c  Modified:
c
c    22 July 2008
c
c  Author:
c
c    John Burkardt
c
c  Parameters:
c
c    Input, integer M, the row dimension of A, and the length of a column.
c
c    Input, integer N, the column dimension of A.
c
c    Input/output, double precision A(M,N).  On input, the array to be checked.
c    On output, A has been reordered as described above.
c
c    Output, integer L, R, the indices of A that define the three segments.
c    Let KEY = the input value of A(1:M,1).  Then
c    I <= L                 A(1:M,I) < KEY;
c         L < I < R         A(1:M,I) = KEY;
c                 R <= I    A(1:M,I) > KEY.
c
      implicit none

      integer m
      integer n

      double precision a(m,n)
      integer i
      integer j
      integer k
      double precision key(m)
      integer l
      integer r
      logical r8vec_eq
      logical r8vec_gt
      logical r8vec_lt

      if ( n .lt. 1 ) then
        write ( *, '(a)' ) ' '
        write ( *, '(a)' ) 'R8COL_PART_QUICK_A - Fatal error!'
        write ( *, '(a)' ) '  N < 1.'
        return
      end if

      if ( n .eq. 1 ) then
        l = 0
        r = 2
        return
      end if

      do i = 1, m
        key(i) = a(i,1)
      end do

      k = 1
c
c  The elements of unknown size have indices between L+1 and R-1.
c
      l = 1
      r = n + 1

      do i = 2, n

        if ( r8vec_gt ( m, a(1,l+1), key ) ) then
          r = r - 1
          call r8vec_swap ( m, a(1,r), a(1,l+1) )
        else if ( r8vec_eq ( m, a(1,l+1), key ) ) then
          k = k + 1
          call r8vec_swap ( m, a(1,k), a(1,l+1) )
          l = l + 1
        else if ( r8vec_lt ( m, a(1,l+1), key ) ) then
          l = l + 1
        end if

      end do
c
c  Shift small elements to the left.
c
      do j = 1, l - k
        do i = 1, m
          a(i,j) = a(i,j+k)
        end do
      end do
c
c  Shift KEY elements to center.
c
      do j = l-k+1, l
        do i = 1, m
          a(i,j) = key(i)
        end do
      end do
c
c  Update L.
c
      l = l - k

      return
      end
      subroutine r8col_permute ( m, n, p, a )

c*********************************************************************72
c
cc R8COL_PERMUTE permutes an R8COL in place.
c
c  Discussion:
c
c    An R8COL is an M by N array of R8's, regarded as an array of N columns,
c    each of length M.
c
c    The same logic can be used to permute an array of objects of any
c    arithmetic type, or an array of objects of any complexity.  The only
c    temporary storage required is enough to store a single object.  The number
c    of data movements made is N + the number of cycles of order 2 or more,
c    which is never more than N + N/2.
c
c  Example:
c
c    Input:
c
c      M = 2
c      N = 5
c      P = (   2,    4,    5,    1,    3 )
c      A = ( 1.0,  2.0,  3.0,  4.0,  5.0 )
c          (11.0, 22.0, 33.0, 44.0, 55.0 )
c
c    Output:
c
c      A    = (  2.0,  4.0,  5.0,  1.0,  3.0 )
c             ( 22.0, 44.0, 55.0, 11.0, 33.0 ).
c
c  Licensing:
c
c    This code is distributed under the GNU LGPL license.
c
c  Modified:
c
c    16 July 2010
c
c  Author:
c
c    John Burkardt
c
c  Parameters:
c
c    Input, integer M, the dimension of objects.
c
c    Input, integer N, the number of objects.
c
c    Input, integer P(N), the permutation.  P(I) = J means
c    that the I-th element of the output array should be the J-th
c    element of the input array.
c
c    Input/output, double precision A(M,N), the array to be permuted.
c
      implicit none

      integer m
      integer n

      double precision a(m,n)
      double precision a_temp(m)
      integer base
      parameter ( base = 1 )
      integer i
      integer ierror
      integer iget
      integer iput
      integer istart
      integer p(n)

      call perm_check ( n, p, base, ierror )

      if ( ierror .ne. 0 ) then
        write ( *, '(a)' ) ' '
        write ( *, '(a)' ) 'R8COL_PERMUTE - Fatal error!'
        write ( *, '(a)' ) '  PERM_CHECK rejects this permutation.'
        stop
      end if
c
c  Search for the next element of the permutation that has not been used.
c
      do istart = 1, n

        if ( p(istart) .lt. 0 ) then

          go to 30

        else if ( p(istart) .eq. istart ) then

          p(istart) = - p(istart)
          go to 30

        else

          do i = 1, m
            a_temp(i) = a(i,istart)
          end do
          iget = istart
c
c  Copy the new value into the vacated entry.
c
10        continue

            iput = iget
            iget = p(iget)

            p(iput) = - p(iput)

            if ( iget .lt. 1 .or. n .lt. iget ) then
              write ( *, '(a)' ) ' '
              write ( *, '(a)' ) 'R8COL_PERMUTE - Fatal error!'
              write ( *, '(a)' ) '  Permutation index out of range.'
              write ( *, '(a,i8,a,i8)' ) '  P(', iput, ') = ', iget
              stop
            end if

            if ( iget .eq. istart ) then
              do i = 1, m
                a(i,iput) = a_temp(i)
              end do
              go to 20
            end if

            do i = 1, m
              a(i,iput) = a(i,iget)
            end do

          go to 10

20        continue

        end if

30      continue

      end do
c
c  Restore the signs of the entries.
c
      do i = 1, n
        p(i) = - p(i)
      end do

      return
      end
      subroutine r8col_sort_heap_a ( m, n, a )

c*********************************************************************72
c
cc R8COL_SORT_HEAP_A ascending heapsorts an R8COL.
c
c  Discussion:
c
c    An R8COL is an M by N array of R8's, regarded as an array of N columns,
c    each of length M.
c
c    In lexicographic order, the statement "X < Y", applied to two real
c    vectors X and Y of length M, means that there is some index I, with
c    1 <= I <= M, with the property that
c
c      X(J) = Y(J) for J < I,
c    and
c      X(I) < Y(I).
c
c    In other words, the first time they differ, X is smaller.
c
c  Licensing:
c
c    This code is distributed under the GNU LGPL license.
c
c  Modified:
c
c    07 June 2010
c
c  Author:
c
c    John Burkardt
c
c  Parameters:
c
c    Input, integer M, N, the number of rows and columns.
c
c    Input/output, double precision A(M,N).
c    On input, the array of N columns of M-vectors.
c    On output, the columns of A have been sorted in lexicographic order.
c
      implicit none

      integer m
      integer n

      double precision a(m,n)
      integer i
      integer indx
      integer isgn
      integer j

      if ( m .le. 0 ) then
        return
      end if

      if ( n .le. 1 ) then
        return
      end if
c
c  Initialize.
c
      i = 0
      indx = 0
      isgn = 0
      j = 0
c
c  Call the external heap sorter.
c
10    continue

        call sort_heap_external ( n, indx, i, j, isgn )
c
c  Interchange the I and J objects.
c
        if ( 0 .lt. indx ) then

          call r8col_swap ( m, n, a, i, j )
c
c  Compare the I and J objects.
c
        else if ( indx .lt. 0 ) then

          call r8col_compare ( m, n, a, i, j, isgn )

        else if ( indx .eq. 0 ) then

          go to 20

        end if

      go to 10

20    continue

      return
      end
      subroutine r8col_sort_heap_index_a ( m, n, a, indx )

c*********************************************************************72
c
cc R8COL_SORT_HEAP_INDEX_A does an indexed heap ascending sort of an R8COL.
c
c  Discussion:
c
c    An R8COL is an M by N array of R8's, regarded as an array of N columns,
c    each of length M.
c
c    The sorting is not actually carried out.  Rather an index array is
c    created which defines the sorting.  This array may be used to sort
c    or index the array, or to sort or index related arrays keyed on the
c    original array.
c
c    A(*,J1) < A(*,J2) if the first nonzero entry of A(*,J1)-A(*,J2)
c    is negative.
c
c    Once the index array is computed, the sorting can be carried out
c    "implicitly:
c
c      A(*,INDX(*)) is sorted,
c
c  Licensing:
c
c    This code is distributed under the GNU LGPL license.
c
c  Modified:
c
c    24 July 2010
c
c  Author:
c
c    John Burkardt
c
c  Parameters:
c
c    Input, integer M, the number of rows in each column of A.
c
c    Input, integer N, the number of columns in A.
c
c    Input, double precision A(M,N), the array.
c
c    Output, integer INDX(N), the sort index.  The I-th element
c    of the sorted array is column INDX(I).
c
      implicit none

      integer m
      integer n

      double precision a(m,n)
      double precision column(m)
      integer i
      integer indx(n)
      integer indxt
      integer ir
      integer isgn
      integer j
      integer l

      if ( n .lt. 1 ) then
        return
      end if

      do i = 1, n
        indx(i) = i
      end do

      if ( n .eq. 1 ) then
        return
      end if

      l = ( n / 2 ) + 1
      ir = n

10    continue

        if ( 1 .lt. l ) then

          l = l - 1
          indxt = indx(l)
          do i = 1, m
            column(i) = a(i,indxt)
          end do

        else

          indxt = indx(ir)
          do i = 1, m
            column(i) = a(i,indxt)
          end do
          indx(ir) = indx(1)
          ir = ir - 1

          if ( ir .eq. 1 ) then
            indx(1) = indxt
            go to 30
          end if

        end if

        i = l
        j = l + l

20      continue

        if ( j .le. ir ) then

          if ( j .lt. ir ) then

            call r8vec_compare ( m, a(1,indx(j)), a(1,indx(j+1)), isgn )

            if ( isgn .lt. 0 ) then
              j = j + 1
            end if

          end if

          call r8vec_compare ( m, column, a(1,indx(j)), isgn )

          if ( isgn .lt. 0 ) then
            indx(i) = indx(j)
            i = j
            j = j + j
          else
            j = ir + 1
          end if

          go to 20

        end if

        indx(i) = indxt

      go to 10

30    continue

      return
      end
      subroutine r8col_sort_quick_a ( m, n, a )

c*********************************************************************72
c
cc R8COL_SORT_QUICK_A ascending sorts the columns of a table using quick sort.
c
c  Licensing:
c
c    This code is distributed under the GNU LGPL license.
c
c  Modified:
c
c    22 July 2008
c
c  Author:
c
c    John Burkardt
c
c  Parameters:
c
c    Input, integer M, the row order of A, and the length of a column.
c
c    Input, integer N, the number of columns of A.
c
c    Input/output, double precision A(M,N).
c    On input, the array to be sorted.
c    On output, the array has been sorted.
c
      implicit none

      integer MAXLEVEL
      parameter ( MAXLEVEL = 25 )

      integer m
      integer n

      double precision a(m,n)
      integer base
      integer l_segment
      integer level
      integer n_segment
      integer rsave(MAXLEVEL)
      integer r_segment

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

      if ( n .eq. 1 ) then
        return
      end if

      level = 1
      rsave(level) = n + 1
      base = 1
      n_segment = n

10    continue
c
c  Partition the segment.
c
        call r8col_part_quick_a ( m, n_segment, a(1,base), l_segment,
     &    r_segment )
c
c  If the left segment has more than one element, we need to partition it.
c
        if ( 1 .lt. l_segment ) then

          if ( MAXLEVEL .lt. level ) then
            write ( *, '(a)' ) ' '
            write ( *, '(a)' ) 'R8COL_SORT_QUICK_A - Fatal error!'
            write ( *, '(a,i8)' )
     &        '  Exceeding recursion maximum of ', MAXLEVEL
            stop
          end if

          level = level + 1
          n_segment = l_segment
          rsave(level) = r_segment + base - 1
c
c  The left segment and the middle segment are sorted.
c  Must the right segment be partitioned?
c
        else if ( r_segment .lt. n_segment ) then

          n_segment = n_segment + 1 - r_segment
          base = base + r_segment - 1
c
c  Otherwise, we back up a level if there is an earlier one.
c
        else

20        continue

            if ( level .le. 1 ) then
              go to 40
            end if

            base = rsave(level)
            n_segment = rsave(level-1) - rsave(level)
            level = level - 1

            if ( 0 .lt. n_segment ) then
              go to 30
            end if

          go to 20

30        continue

        end if

      go to 10

40    continue

      return
      end
      subroutine r8col_sorted_tol_undex ( m, n, a, unique_num, tol,
     &  undx, xdnu )

c*********************************************************************72
c
cc R8COL_SORTED_TOL_UNDEX: tolerably unique indexes for a sorted R8COL.
c
c  Discussion:
c
c    An R8COL is an M by N array of R8's, regarded as an array of N columns,
c    each of length M.
c
c    The goal of this routine is to determine a vector UNDX,
c    which points, to the tolerably unique elements of A, in sorted order,
c    and a vector XDNU, which identifies, for each entry of A, the index of
c    the unique sorted element of A.
c
c    This is all done with index vectors, so that the elements of
c    A are never moved.
c
c    Assuming A is already sorted, we examine the entries of A in order,
c    noting the unique entries, creating the entries of XDNU and
c    UNDX as we go.
c
c    Once this process has been completed, the vector A could be
c    replaced by a compressed vector XU, containing the unique entries
c    of A in sorted order, using the formula
c
c      XU(*) = A(UNDX(*)).
c
c    We could then, if we wished, reconstruct the entire vector A, or
c    any element of it, by index, as follows:
c
c      A(I) = XU(XDNU(I)).
c
c    We could then replace A by the combination of XU and XDNU.
c
c    Later, when we need the I-th entry of A, we can locate it as
c    the XDNU(I)-th entry of XU.
c
c    Here is an example of a vector A, the unique sort and
c    inverse unique sort vectors and the compressed unique sorted vector.
c
c      I      A      XU  Undx  Xdnu
c    ----+------+------+-----+-----+
c      1 | 11.0 |  11.0    1     1
c      2 | 11.0 |  22.0    5     1
c      3 | 11.0 |  33.0    8     1
c      4 | 11.0 |  55.0    9     1
c      5 | 22.0 |                2
c      6 | 22.0 |                2
c      7 | 22.0 |                2
c      8 | 33.0 |                3
c      9 | 55.0 |                4
c
c  Licensing:
c
c    This code is distributed under the GNU LGPL license.
c
c  Modified:
c
c    17 July 2010
c
c  Author:
c
c    John Burkardt
c
c  Parameters:
c
c    Input, integer M, the dimension of the data values.
c
c    Input, integer N, the number of data values.
c
c    Input, double precision A(M,N), the data values.
c
c    Input, integer UNIQUE_NUM, the number of unique values
c    in A.  This value is only required for languages in which the size of
c    UNDX must be known in advance.
c
c    Input, double precision TOL, a tolerance for equality.
c
c    Output, integer UNDX(UNIQUE_NUM), the UNDX vector.
c
c    Output, integer XDNU(N), the XDNU vector.
c
      implicit none

      integer m
      integer n
      integer unique_num

      double precision a(m,n)
      double precision diff
      integer i
      integer i2
      integer i3
      integer j
      integer k
      double precision tol
      integer undx(unique_num)
      logical unique
      integer xdnu(n)
c
c  Consider entry I = 1.
c  It is unique, so set the number of unique items to K.
c  Set the K-th unique item to I.
c  Set the representative of item I to the K-th unique item.
c
      i = 1
      k = 1
      undx(k) = i
      xdnu(i) = k
c
c  Consider entry I.
c
c  If it is unique, increase the unique count K, set the
c  K-th unique item to I, and set the representative of I to K.
c
c  If it is not unique, set the representative of item I to a
c  previously determined unique item that is close to it.
c
      do i = 2, n

        unique = .true.

        do j = 1, k
          i2 = undx(j)
          diff = 0.0D+00
          do i3 = 1, m
            diff = max ( diff, abs ( a(i3,i) - a(i3,i2) ) )
          end do
          if ( diff .le. tol ) then
            unique = .false.
            xdnu(i) = j
            exit
          end if
        end do

        if ( unique ) then
          k = k + 1
          undx(k) = i
          xdnu(i) = k
        end if

      end do

      return
      end
      subroutine r8col_sorted_tol_unique ( m, n, a, tol, unique_num )

c*********************************************************************72
c
cc R8COL_SORTED_TOL_UNIQUE keeps tolerably unique elements in a sorted R8COL.
c
c  Discussion:
c
c    An R8COL is an M by N array of R8's, regarded as an array of N columns,
c    each of length M.
c
c    The columns of the array may be ascending or descending sorted.
c
c  Licensing:
c
c    This code is distributed under the GNU LGPL license.
c
c  Modified:
c
c    16 July 2010
c
c  Author:
c
c    John Burkardt
c
c  Parameters:
c
c    Input, integer M, N, the number of rows and columns.
c
c    Input/output, double precision A(M,N).
c    On input, the sorted array of N columns of M-vectors.
c    On output, a sorted array of columns of M-vectors.
c
c    Input, double precision TOL, a tolerance for equality.
c
c    Output, integer UNIQUE_NUM, the number of unique columns.
c
      implicit none

      integer m
      integer n

      double precision a(m,n)
      double precision diff
      integer i
      integer j
      integer k
      double precision tol
      logical unique
      integer unique_num

      unique_num = 0

      if ( n .le. 0 ) then
        return
      end if

      unique_num = 1

      do i = 2, n

        unique = .true.

        do j = 1, unique_num
          diff = 0.0D+00
          do k = 1, m
            diff = max ( diff, abs ( a(k,j) - a(k,i) ) )
          end do
          if ( diff .le. tol ) then
            unique = .false.
            exit
          end if
        end do

        if ( unique ) then
          unique_num = unique_num + 1
          do k = 1, m
            a(k,unique_num) = a(k,i)
          end do
        end if

      end do

      return
      end
      subroutine r8col_sorted_tol_unique_count ( m, n, a, tol,
     &  unique_num )

c*********************************************************************72
c
cc R8COL_SORTED_TOL_UNIQUE_COUNT counts tolerably unique elements in a sorted R8COL.
c
c  Discussion:
c
c    An R8COL is an M by N array of R8's, regarded as an array of N columns,
c    each of length M.
c
c    The columns of the array may be ascending or descending sorted.
c
c    If the tolerance is large enough, then the concept of uniqueness
c    can become ambiguous.  If we have a tolerance of 1.5, then in the
c    list ( 1, 2, 3, 4, 5, 6, 7, 8, 9 ) is it fair to say we have only
c    one unique entry?  That would be because 1 may be regarded as unique,
c    and then 2 is too close to 1 to be unique, and 3 is too close to 2 to
c    be unique and so on.
c
c    This seems wrongheaded.  So I prefer the idea that an item is not
c    unique under a tolerance only if it is close to something that IS unique.
c    Thus, the unique items are guaranteed to cover the space if we include
c    a disk of radius TOL around each one.
c
c  Licensing:
c
c    This code is distributed under the GNU LGPL license.
c
c  Modified:
c
c    16 July 2010
c
c  Author:
c
c    John Burkardt
c
c  Parameters:
c
c    Input, integer M, N, the number of rows and columns.
c
c    Input, double precision A(M,N), a sorted array, containing
c    N columns of data.
c
c    Input, double precision TOL, a tolerance for equality.
c
c    Output, integer UNIQUE_NUM, the number of unique columns.
c
      implicit none

      integer m
      integer n

      double precision a(m,n)
      double precision diff
      integer i
      integer i2
      integer i3
      integer j
      integer k
      double precision tol
      integer undx(n)
      logical unique
      integer unique_num
c
c  Consider entry I = 1.
c  It is unique, so set the number of unique items to K.
c  Set the K-th unique item to I.
c  Set the representative of item I to the K-th unique item.
c
      i = 1
      k = 1
      undx(k) = i
c
c  Consider entry I.
c
c  If it is unique, increase the unique count K, set the
c  K-th unique item to I, and set the representative of I to K.
c
c  If it is not unique, set the representative of item I to a
c  previously determined unique item that is close to it.
c
      do i = 2, n

        unique = .true.

        do j = 1, k
          i2 = undx(j)
          diff = 0.0D+00
          do i3 = 1, m
            diff = max ( diff, abs ( a(i3,i) - a(i3,i2) ) )
          end do
          if ( diff .le. tol ) then
            unique = .false.
            exit
          end if
        end do

        if ( unique ) then
          k = k + 1
          undx(k) = i
        end if

      end do

      unique_num = k

      return
      end
      subroutine r8col_sorted_undex ( m, n, a, unique_num, undx, xdnu )

c*********************************************************************72
c
cc R8COL_SORTED_UNDEX returns unique sorted indexes for a sorted R8COL.
c
c  Discussion:
c
c    An R8COL is an M by N array of R8's, regarded as an array of N columns,
c    each of length M.
c
c    The goal of this routine is to determine a vector UNDX,
c    which points, to the unique elements of A, in sorted order,
c    and a vector XDNU, which identifies, for each entry of A, the index of
c    the unique sorted element of A.
c
c    This is all done with index vectors, so that the elements of
c    A are never moved.
c
c    Assuming A is already sorted, we examine the entries of A in order,
c    noting the unique entries, creating the entries of XDNU and
c    UNDX as we go.
c
c    Once this process has been completed, the vector A could be
c    replaced by a compressed vector XU, containing the unique entries
c    of A in sorted order, using the formula
c
c      XU(*) = A(UNDX(*)).
c
c    We could then, if we wished, reconstruct the entire vector A, or
c    any element of it, by index, as follows:
c
c      A(I) = XU(XDNU(I)).
c
c    We could then replace A by the combination of XU and XDNU.
c
c    Later, when we need the I-th entry of A, we can locate it as
c    the XDNU(I)-th entry of XU.
c
c    Here is an example of a vector A, the unique sort and
c    inverse unique sort vectors and the compressed unique sorted vector.
c
c      I      A      XU  Undx  Xdnu
c    ----+------+------+-----+-----+
c      1 | 11.0 |  11.0    1     1
c      2 | 11.0 |  22.0    5     1
c      3 | 11.0 |  33.0    8     1
c      4 | 11.0 |  55.0    9     1
c      5 | 22.0 |                2
c      6 | 22.0 |                2
c      7 | 22.0 |                2
c      8 | 33.0 |                3
c      9 | 55.0 |                4
c
c  Licensing:
c
c    This code is distributed under the GNU LGPL license.
c
c  Modified:
c
c    17 July 2010
c
c  Author:
c
c    John Burkardt
c
c  Parameters:
c
c    Input, integer M, the dimension of the data values.
c
c    Input, integer N, the number of data values.
c
c    Input, double precision A(M,N), the data values.
c
c    Input, integer UNIQUE_NUM, the number of unique values
c    in A.  This value is only required for languages in which the size of
c    UNDX must be known in advance.
c
c    Output, integer UNDX(UNIQUE_NUM), the UNDX vector.
c
c    Output, integer XDNU(N), the XDNU vector.
c
      implicit none

      integer m
      integer n
      integer unique_num

      double precision a(m,n)
      double precision diff
      integer i
      integer j
      integer k
      integer undx(unique_num)
      integer xdnu(n)
c
c  Walk through the sorted array.
c
      i = 1

      j = 1
      undx(j) = i

      xdnu(i) = j

      do i = 2, n

        diff = 0.0D+00
        do k = 1, m
          diff = max ( diff, abs ( a(k,i) - a(k,undx(j)) ) )
        end do

        if ( 0.0D+00 .ne. diff ) then
          j = j + 1
          undx(j) = i
        end if

        xdnu(i) = j

      end do

      return
      end
      subroutine r8col_sorted_unique ( m, n, a, unique_num )

c*********************************************************************72
c
cc R8COL_SORTED_UNIQUE keeps unique elements in a sorted R8COL.
c
c  Discussion:
c
c    An R8COL is an M by N array of R8's, regarded as an array of N columns,
c    each of length M.
c
c    The columns of the array may be ascending or descending sorted.
c
c  Licensing:
c
c    This code is distributed under the GNU LGPL license.
c
c  Modified:
c
c    16 July 2010
c
c  Author:
c
c    John Burkardt
c
c  Parameters:
c
c    Input, integer M, N, the number of rows and columns.
c
c    Input/output, double precision A(M,N).
c    On input, the sorted array of N columns of M-vectors.
c    On output, a sorted array of columns of M-vectors.
c
c    Output, integer UNIQUE_NUM, the number of unique columns.
c
      implicit none

      integer m
      integer n

      double precision a(m,n)
      logical equal
      integer i
      integer j1
      integer j2
      integer unique_num

      if ( n .le. 0 ) then
        unique_num = 0
        return
      end if

      j1 = 1

      do j2 = 2, n

        equal = .true.
        do i = 1, m
          if ( a(i,j1) .ne. a(i,j2) ) then
            equal = .false.
          end if
        end do

        if ( .not. equal ) then
          j1 = j1 + 1
          do i = 1, m
            a(i,j1) = a(i,j2)
          end do
        end if

      end do

      unique_num = j1

      return
      end
      subroutine r8col_sorted_unique_count ( m, n, a, unique_num )

c*********************************************************************72
c
cc R8COL_SORTED_UNIQUE_COUNT counts unique elements in a sorted R8COL.
c
c  Discussion:
c
c    An R8COL is an M by N array of R8's, regarded as an array of N columns,
c    each of length M.
c
c    The columns of the array may be ascending or descending sorted.
c
c  Licensing:
c
c    This code is distributed under the GNU LGPL license.
c
c  Modified:
c
c    16 July 2010
c
c  Author:
c
c    John Burkardt
c
c  Parameters:
c
c    Input, integer M, N, the number of rows and columns.
c
c    Input, double precision A(M,N), a sorted array, containing
c    N columns of data.
c
c    Output, integer UNIQUE_NUM, the number of unique columns.
c
      implicit none

      integer m
      integer n

      double precision a(m,n)
      logical equal
      integer i
      integer j1
      integer j2
      integer unique_num

      unique_num = 0

      if ( n .le. 0 ) then
        return
      end if

      unique_num = 1
      j1 = 1

      do j2 = 2, n

        equal = .true.
        do i = 1, m
          if ( a(i,j1) .ne. a(i,j2) ) then
            equal = .false.
          end if
        end do

        if ( .not. equal ) then
          unique_num = unique_num + 1
          j1 = j2
        end if

      end do

      return
      end
      subroutine r8col_sortr_a ( m, n, a, key )

c*********************************************************************72
c
cc R8COL_SORTR_A ascending sorts one column of an R8COL, adjusting all columns.
c
c  Discussion:
c
c    An R8COL is an M by N array of R8's, regarded as an array of N columns,
c    each of length M.
c
c  Licensing:
c
c    This code is distributed under the GNU LGPL license.
c
c  Modified:
c
c    16 July 2010
c
c  Author:
c
c    John Burkardt
c
c  Parameters:
c
c    Input, integer M, N, the number of rows and columns.
c
c    Input/output, double precision A(M,N).
c    On input, an unsorted M by N array.
c    On output, rows of the array have been shifted in such
c    a way that column KEY of the array is in nondecreasing order.
c
c    Input, integer KEY, the column in which the "key" value
c    is stored.  On output, column KEY of the array will be
c    in nondecreasing order.
c
      implicit none

      integer m
      integer n

      double precision a(m,n)
      integer i
      integer indx
      integer isgn
      integer j
      integer key

      if ( m .le. 0 ) then
        return
      end if

      if ( key .lt. 1 .or. n .lt. key ) then
        write ( *, '(a)' ) ' '
        write ( *, '(a)' ) 'R8COL_SORTR_A - Fatal error!'
        write ( *, '(a)' ) '  KEY is not a legal column index.'
        write ( *, '(a,i8)' ) '  KEY = ', key
        write ( *, '(a,i8)' ) '  N = ', n
        stop
      end if
c
c  Initialize.
c
      i = 0
      indx = 0
      isgn = 0
      j = 0
c
c  Call the external heap sorter.
c
10    continue

        call sort_heap_external ( m, indx, i, j, isgn )
c
c  Interchange the I and J objects.
c
        if ( 0 .lt. indx ) then

          call r8row_swap ( m, n, a, i, j )
c
c  Compare the I and J objects.
c
        else if ( indx .lt. 0 ) then

          if ( a(i,key) .lt. a(j,key) ) then
            isgn = -1
          else
            isgn = +1
          end if

        else if ( indx .eq. 0 ) then

          go to 20

        end if

      go to 10

20    continue

      return
      end
      subroutine r8col_sum ( m, n, a, colsum )

c*********************************************************************72
c
cc R8COL_SUM sums the columns of an R8COL.
c
c  Discussion:
c
c    An R8COL is an M by N array of R8's, regarded as an array of N columns,
c    each of length M.
c
c  Licensing:
c
c    This code is distributed under the GNU LGPL license.
c
c  Modified:
c
c    08 May 2010
c
c  Author:
c
c    John Burkardt
c
c  Parameters:
c
c    Input, integer M, N, the number of rows and columns.
c
c    Input, double precision A(M,N), the array to be examined.
c
c    Output, double precision COLSUM(N), the sums of the columns.
c
      implicit none

      integer m
      integer n

      double precision a(m,n)
      double precision colsum(n)
      integer i
      integer j

      do j = 1, n
        colsum(j) = 0.0D+00
        do i = 1, m
          colsum(j) = colsum(j) + a(i,j)
        end do
      end do

      return
      end
      subroutine r8col_swap ( m, n, a, j1, j2 )

c*********************************************************************72
c
cc R8COL_SWAP swaps columns I and J of an R8COL.
c
c  Discussion:
c
c    An R8COL is an M by N array of R8's, regarded as an array of N columns,
c    each of length M.
c
c  Example:
c
c    Input:
c
c      M = 3, N = 4, J1 = 2, J2 = 4
c
c      A = (
c        1.  2.  3.  4.
c        5.  6.  7.  8.
c        9. 10. 11. 12. )
c
c    Output:
c
c      A = (
c        1.  4.  3.  2.
c        5.  8.  7.  6.
c        9. 12. 11. 10. )
c
c  Licensing:
c
c    This code is distributed under the GNU LGPL license.
c
c  Modified:
c
c    05 March 2010
c
c  Author:
c
c    John Burkardt
c
c  Parameters:
c
c    Input, integer M, N, the number of rows and columns.
c
c    Input/output, double precision A(M,N), the M by N array.
c
c    Input, integer J1, J2, the columns to be swapped.
c
      implicit none

      integer m
      integer n

      double precision a(m,n)
      integer i
      integer j1
      integer j2
      double precision temp

      if ( j1 .lt. 1 .or. n .lt. j1 .or. j2 .lt. 1 .or. n .lt. j2 ) then
        write ( *, '(a)' ) ' '
        write ( *, '(a)' ) 'R8COL_SWAP - Fatal error!'
        write ( *, '(a)' ) '  J1 or J2 is out of bounds.'
        write ( *, '(a,i8)' ) '  J1 =    ', j1
        write ( *, '(a,i8)' ) '  J2 =    ', j2
        write ( *, '(a,i8)' ) '  NCOL = ', n
        stop
      end if

      if ( j1 .eq. j2 ) then
        return
      end if

      do i = 1, m
        temp = a(i,j1)
        a(i,j1) = a(i,j2)
        a(i,j2) = temp
      end do

      return
      end
      subroutine r8col_to_r8vec ( m, n, a, x )

c*********************************************************************72
c
cc R8COL_TO_R8VEC converts an R8COL to an R8VEC.
c
c  Discussion:
c
c    An R8COL is an M by N array of R8's, regarded as an array of N columns,
c    each of length M.
c
c    An R8VEC is a vector of R8's.
c
c  Example:
c
c    M = 3, N = 4
c
c    A =
c      11 12 13 14
c      21 22 23 24
c      31 32 33 34
c
c    X = ( 11, 21, 31, 12, 22, 32, 13, 23, 33, 14, 24, 34 )
c
c  Licensing:
c
c    This code is distributed under the GNU LGPL license.
c
c  Modified:
c
c    08 May 2010
c
c  Author:
c
c    John Burkardt
c
c  Parameters:
c
c    Input, integer M, N, the number of rows and columns.
c
c    Input, double precision A(M,N), the array.
c
c    Output, double precision X(M*N), a vector containing the N columns of A.
c
      implicit none

      integer m
      integer n

      double precision a(m,n)
      integer i
      integer j
      integer k
      double precision x(m*n)

      k = 1
      do j = 1, n
        do i = 1, m
          x(k) = a(i,j)
          k = k + 1
        end do
      end do

      return
      end
      subroutine r8col_tol_undex ( m, n, a, unique_num, tol, undx,
     &  xdnu )

c*********************************************************************72
c
cc R8COL_TOL_UNDEX indexes tolerably unique entries of an R8COL.
c
c  Discussion:
c
c    An R8COL is an M by N array of R8's, regarded as an array of N columns,
c    each of length M.
c
c    The goal of this routine is to determine a vector UNDX,
c    which points to the unique elements of A, in sorted order,
c    and a vector XDNU, which identifies, for each entry of A, the index of
c    the unique sorted element of A.
c
c    This is all done with index vectors, so that the elements of
c    A are never moved.
c
c    The first step of the algorithm requires the indexed sorting
c    of A, which creates arrays INDX and XDNI.  (If all the entries
c    of A are unique, then these arrays are the same as UNDX and XDNU.)
c
c    We then use INDX to examine the entries of A in sorted order,
c    noting the unique entries, creating the entries of XDNU and
c    UNDX as we go.
c
c    Once this process has been completed, the object A could be
c    replaced by a compressed object XU, containing the unique entries
c    of X in sorted order, using the formula
c
c      XU(*) = A(UNDX(*)).
c
c    We could then, if we wished, reconstruct the entire vector A, or
c    any element of it, by index, as follows:
c
c      A(I) = XU(XDNU(I)).
c
c    We could then replace A by the combination of XU and XDNU.
c
c    Later, when we need the I-th entry of A, we can locate it as
c    the XDNU(I)-th entry of XU.
c
c    Here is an example of a vector A, the sort and inverse sort
c    index vectors, and the unique sort and inverse unique sort vectors
c    and the compressed unique sorted vector.
c
c      I    A   Indx  Xdni      XU   Undx  Xdnu
c    ----+-----+-----+-----+--------+-----+-----+
c      1 | 11.     1     1 |    11.     1     1
c      2 | 22.     3     5 |    22.     2     2
c      3 | 11.     6     2 |    33.     4     1
c      4 | 33.     9     8 |    55.     5     3
c      5 | 55.     2     9 |                  4
c      6 | 11.     7     3 |                  1
c      7 | 22.     8     6 |                  2
c      8 | 22.     4     7 |                  2
c      9 | 11.     5     4 |                  1
c
c    INDX(2) = 3 means that sorted item(2) is A(3).
c    XDNI(2) = 5 means that A(2) is sorted item(5).
c
c    UNDX(3) = 4 means that unique sorted item(3) is at A(4).
c    XDNU(8) = 2 means that A(8) is at unique sorted item(2).
c
c    XU(XDNU(I))) = A(I).
c    XU(I)        = A(UNDX(I)).
c
c  Licensing:
c
c    This code is distributed under the GNU LGPL license.
c
c  Modified:
c
c    17 July 2010
c
c  Author:
c
c    John Burkardt
c
c  Parameters:
c
c    Input, integer M, the dimension of the data values.
c
c    Input, integer N, the number of data values.
c
c    Input, double precision A(M,N), the data values.
c
c    Input, integer UNIQUE_NUM, the number of unique values
c    in A.  This value is only required for languages in which the size of
c    UNDX must be known in advance.
c
c    Input, double precision TOL, a tolerance for equality.
c
c    Output, integer UNDX(UNIQUE_NUM), the UNDX vector.
c
c    Output, integer XDNU(N), the XDNU vector.
c
      implicit none

      integer m
      integer n
      integer unique_num

      double precision a(m,n)
      double precision diff
      integer i
      integer i2
      integer indx(n)
      integer j
      integer k
      double precision tol
      integer undx(unique_num)
      logical unique
      integer xdnu(n)
c
c  Implicitly sort the array.
c
      call r8col_sort_heap_index_a ( m, n, a, indx )
c
c  Consider entry I = 1.
c  It is unique, so set the number of unique items to K.
c  Set the K-th unique item to I.
c  Set the representative of item I to the K-th unique item.
c
      i = 1
      k = 1
      undx(k) = indx(i)
      xdnu(indx(i)) = k
c
c  Consider entry I.
c
c  If it is unique, increase the unique count K, set the
c  K-th unique item to I, and set the representative of I to K.
c
c  If it is not unique, set the representative of item I to a
c  previously determined unique item that is close to it.
c
      do i = 2, n

        unique = .true.

        do j = 1, k

          diff = 0.0D+00
          do i2 = 1, m
            diff = max ( diff, abs ( a(i2,indx(i)) - a(i2,undx(j)) ) )
          end do

          if ( diff .le. tol ) then
            unique = .false.
            xdnu(indx(i)) = j
            go to 10
          end if

        end do

        if ( unique ) then
          k = k + 1
          undx(k) = indx(i)
          xdnu(indx(i)) = k
        end if

10      continue

      end do

      return
      end
      subroutine r8col_tol_unique_count ( m, n, a, tol, unique_num )

c*********************************************************************72
c
cc R8COL_TOL_UNIQUE_COUNT counts tolerably unique entries in an R8COL.
c
c  Discussion:
c
c    An R8COL is an M by N array of R8's, regarded as an array of N columns,
c    each of length M.
c
c    Because the array is unsorted, this algorithm is O(N^2).
c
c    If the tolerance is large enough, then the concept of uniqueness
c    can become ambiguous.  If we have a tolerance of 1.5, then in the
c    list ( 1, 2, 3, 4, 5, 6, 7, 8, 9 ) is it fair to say we have only
c    one unique entry?  That would be because 1 may be regarded as unique,
c    and then 2 is too close to 1 to be unique, and 3 is too close to 2 to
c    be unique and so on.
c
c    This seems wrongheaded.  So I prefer the idea that an item is not
c    unique under a tolerance only if it is close to something that IS unique.
c    Thus, the unique items are guaranteed to cover the space if we include
c    a disk of radius TOL around each one.
c
c  Licensing:
c
c    This code is distributed under the GNU LGPL license.
c
c  Modified:
c
c    17 July 2010
c
c  Author:
c
c    John Burkardt
c
c  Parameters:
c
c    Input, integer M, the number of rows.
c
c    Input, integer N, the number of columns.
c
c    Input, double precision A(M,N), the array of N columns of data.
c
c    Input, double precision TOL, a tolerance for equality.
c
c    Output, integer UNIQUE_NUM, the number of unique columns.
c
      implicit none

      integer m
      integer n

      double precision a(m,n)
      double precision diff
      integer i
      integer i2
      integer indx(n)
      integer j
      integer k
      double precision tol
      integer undx(n)
      logical unique
      integer unique_num
c
c  Implicitly sort the array.
c
      call r8col_sort_heap_index_a ( m, n, a, indx )
c
c  Consider entry I = 1.
c  It is unique, so set the number of unique items to K.
c  Set the K-th unique item to I.
c  Set the representative of item I to the K-th unique item.
c
      i = 1
      k = 1
      undx(k) = indx(i)
c
c  Consider entry I.
c
c  If it is unique, increase the unique count K, set the
c  K-th unique item to I, and set the representative of I to K.
c
c  If it is not unique, set the representative of item I to a
c  previously determined unique item that is close to it.
c
      do i = 2, n

        unique = .true.

        do j = 1, k

          diff = 0.0D+00
          do i2 = 1, m
            diff = max ( diff, abs ( a(i2,indx(i)) - a(i2,undx(j)) ) )
          end do

          if ( diff .le. tol ) then
            unique = .false.
            go to 10
          end if

        end do

        if ( unique ) then
          k = k + 1
          undx(k) = indx(i)
        end if

10      continue

      end do

      unique_num = k

      return
      end
      subroutine r8col_tol_unique_index ( m, n, a, tol, unique_index )

c*********************************************************************72
c
cc R8COL_TOL_UNIQUE_INDEX indexes tolerably unique entries in an R8COL.
c
c  Discussion:
c
c    An R8COL is an M by N array of R8 values.
c    It is regarded as an array of N columns of length M.
c
c    For element A(1:M,J) of the matrix, UNIQUE_INDEX(J) is the uniqueness index
c    of A(1:M,J).  That is, if A_UNIQUE contains the unique elements of A,
c    gathered in order, then
c
c      A_UNIQUE ( 1:M, UNIQUE_INDEX(J) ) = A(1:M,J)
c
c  Licensing:
c
c    This code is distributed under the GNU LGPL license.
c
c  Modified:
c
c    17 July 2010
c
c  Author:
c
c    John Burkardt
c
c  Parameters:
c
c    Input, integer M, N, the number of rows and columns of A.
c    The length of an "element" of A, and the number of "elements".
c
c    Input, double precision A(M,N), the array.
c
c    Input, double precision TOL, a tolerance for equality.
c
c    Output, integer UNIQUE_INDEX(N), the first occurrence index.
c
      implicit none

      integer m
      integer n

      double precision a(m,n)
      double precision diff
      integer i
      integer j1
      integer j2
      double precision tol
      integer unique_index(n)
      integer unique_num

      do i = 1, n
        unique_index(i) = -1
      end do
      unique_num = 0

      do j1 = 1, n

        if ( unique_index(j1) .eq. -1 ) then

          unique_num = unique_num + 1
          unique_index(j1) = unique_num

          do j2 = j1 + 1, n
            diff = 0.0D+00
            do i = 1, m
              diff = max ( diff, abs ( a(i,j1) - a(i,j2) ) )
            end do
            if ( diff .le. tol ) then
              unique_index(j2) = unique_num
            end if
          end do

        end if

      end do

      return
      end
      subroutine r8col_undex ( m, n, a, unique_num, undx, xdnu )

c*********************************************************************72
c
cc R8COL_UNDEX indexes unique entries of an R8COL.
c
c  Discussion:
c
c    An R8COL is an M by N array of R8's, regarded as an array of N columns,
c    each of length M.
c
c    The goal of this routine is to determine a vector UNDX,
c    which points to the unique elements of A, in sorted order,
c    and a vector XDNU, which identifies, for each entry of A, the index of
c    the unique sorted element of A.
c
c    This is all done with index vectors, so that the elements of
c    A are never moved.
c
c    The first step of the algorithm requires the indexed sorting
c    of A, which creates arrays INDX and XDNI.  (If all the entries
c    of A are unique, then these arrays are the same as UNDX and XDNU.)
c
c    We then use INDX to examine the entries of A in sorted order,
c    noting the unique entries, creating the entries of XDNU and
c    UNDX as we go.
c
c    Once this process has been completed, the object A could be
c    replaced by a compressed object XU, containing the unique entries
c    of X in sorted order, using the formula
c
c      XU(*) = A(UNDX(*)).
c
c    We could then, if we wished, reconstruct the entire vector A, or
c    any element of it, by index, as follows:
c
c      A(I) = XU(XDNU(I)).
c
c    We could then replace A by the combination of XU and XDNU.
c
c    Later, when we need the I-th entry of A, we can locate it as
c    the XDNU(I)-th entry of XU.
c
c    Here is an example of a vector A, the sort and inverse sort
c    index vectors, and the unique sort and inverse unique sort vectors
c    and the compressed unique sorted vector.
c
c      I    A   Indx  Xdni      XU   Undx  Xdnu
c    ----+-----+-----+-----+--------+-----+-----+
c      1 | 11.     1     1 |    11.     1     1
c      2 | 22.     3     5 |    22.     2     2
c      3 | 11.     6     2 |    33.     4     1
c      4 | 33.     9     8 |    55.     5     3
c      5 | 55.     2     9 |                  4
c      6 | 11.     7     3 |                  1
c      7 | 22.     8     6 |                  2
c      8 | 22.     4     7 |                  2
c      9 | 11.     5     4 |                  1
c
c    INDX(2) = 3 means that sorted item(2) is A(3).
c    XDNI(2) = 5 means that A(2) is sorted item(5).
c
c    UNDX(3) = 4 means that unique sorted item(3) is at A(4).
c    XDNU(8) = 2 means that A(8) is at unique sorted item(2).
c
c    XU(XDNU(I))) = A(I).
c    XU(I)        = A(UNDX(I)).
c
c  Licensing:
c
c    This code is distributed under the GNU LGPL license.
c
c  Modified:
c
c    17 July 2010
c
c  Author:
c
c    John Burkardt
c
c  Parameters:
c
c    Input, integer M, the dimension of the data values.
c
c    Input, integer N, the number of data values.
c
c    Input, double precision A(M,N), the data values.
c
c    Input, integer UNIQUE_NUM, the number of unique values
c    in A.  This value is only required for languages in which the size of
c    UNDX must be known in advance.
c
c    Output, integer UNDX(UNIQUE_NUM), the UNDX vector.
c
c    Output, integer XDNU(N), the XDNU vector.
c
      implicit none

      integer m
      integer n
      integer unique_num

      double precision a(m,n)
      double precision diff
      integer i
      integer indx(n)
      integer j
      integer k
      integer undx(unique_num)
      integer xdnu(n)
c
c  Implicitly sort the array.
c
      call r8col_sort_heap_index_a ( m, n, a, indx )
c
c  Walk through the implicitly sorted array.
c
      i = 1
      j = 1
      undx(j) = indx(i)
      xdnu(indx(i)) = j

      do i = 2, n

        diff = 0.0D+00
        do k = 1, m
          diff = max ( diff, abs ( a(k,indx(i)) - a(k,undx(j)) ) )
        end do

        if ( 0.0D+00 .lt. diff ) then
          j = j + 1
          undx(j) = indx(i)
        end if

        xdnu(indx(i)) = j

      end do

      return
      end
      subroutine r8col_uniform_abvec ( m, n, a, b, seed, r )

c*********************************************************************72
c
cc R8COL_UNIFORM_ABVEC fills an R8COL with pseudorandom values.
c
c  Discussion:
c
c    An R8COL is an array of R8 values, regarded as a set of column vectors.
c
c    The user specifies a minimum and maximum value for each row.
c
c  Licensing:
c
c    This code is distributed under the GNU LGPL license.
c
c  Modified:
c
c    19 December 2011
c
c  Author:
c
c    John Burkardt
c
c  Reference:
c
c    Paul Bratley, Bennett Fox, Linus Schrage,
c    A Guide to Simulation,
c    Springer Verlag, pages 201-202, 1983.
c
c    Bennett Fox,
c    Algorithm 647:
c    Implementation and Relative Efficiency of Quasirandom
c    Sequence Generators,
c    ACM Transactions on Mathematical Software,
c    Volume 12, Number 4, pages 362-376, 1986.
c
c    Peter Lewis, Allen Goodman, James Miller,
c    A Pseudo-Random Number Generator for the System/360,
c    IBM Systems Journal,
c    Volume 8, pages 136-143, 1969.
c
c  Parameters:
c
c    Input, integer M, N, the number of rows and columns in
c    the array.
c
c    Input, double precision A(M), B(M), the lower and upper limits.
c
c    Input/output, integer SEED, the "seed" value, which
c    should NOT be 0.  On output, SEED has been updated.
c
c    Output, double precision R(M,N), the array of pseudorandom values.
c
      implicit none

      integer m
      integer n

      double precision a(m)
      double precision b(m)
      integer i
      integer i4_huge
      parameter ( i4_huge = 2147483647 )
      integer j
      integer k
      integer seed
      double precision r(m,n)

      do j = 1, n

        do i = 1, m

          k = seed / 127773

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

          if ( seed .lt. 0 ) then
            seed = seed + i4_huge
          end if

          r(i,j) = a(i) 
     &      + ( b(i) - a(i) ) * dble ( seed ) * 4.656612875D-10

        end do
      end do

      return
      end
      subroutine r8col_unique_count ( m, n, a, unique_num )

c*********************************************************************72
c
cc R8COL_UNIQUE_COUNT counts the unique columns in an unsorted R8COL.
c
c  Discussion:
c
c    An R8COL is an M by N array of R8's, regarded as an array of N columns,
c    each of length M.
c
c    Because the array is unsorted, this algorithm is O(N^2).
c
c  Licensing:
c
c    This code is distributed under the GNU LGPL license.
c
c  Modified:
c
c    17 July 2010
c
c  Author:
c
c    John Burkardt
c
c  Parameters:
c
c    Input, integer M, the number of rows.
c
c    Input, integer N, the number of columns.
c
c    Input, double precision A(M,N), the array of N columns of data.
c
c    Output, integer UNIQUE_NUM, the number of unique columns.
c
      implicit none

      integer m
      integer n

      double precision a(m,n)
      double precision diff
      integer i
      integer j1
      integer j2
      logical unique(n)
      integer unique_num

      unique_num = 0

      do j1 = 1, n

        unique_num = unique_num + 1
        unique(j1) = .true.

        do j2 = 1, j1 - 1

          if ( unique(j2) ) then

            diff = 0.0D+00
            do i = 1, m
              diff = max ( diff, abs ( a(i,j1) - a(i,j2) ) )
            end do

            if ( diff .eq. 0.0D+00 ) then
              unique_num = unique_num - 1
              unique(j1) = .false.
              go to 10
            end if

          end if

        end do

10      continue

      end do

      return
      end
      subroutine r8col_unique_index ( m, n, a, unique_index )

c*********************************************************************72
c
cc R8COL_UNIQUE_INDEX indexes the first occurrence of values in an R8COL.
c
c  Discussion:
c
c    An R8COL is an M by N array of R8 values.
c    It is regarded as an array of N columns of length M.
c
c    For element A(1:M,J) of the matrix, UNIQUE_INDEX(J) is the uniqueness index
c    of A(1:M,J).  That is, if A_UNIQUE contains the unique elements of A,
c    gathered in order, then
c
c      A_UNIQUE ( 1:M, UNIQUE_INDEX(J) ) = A(1:M,J)
c
c  Licensing:
c
c    This code is distributed under the GNU LGPL license.
c
c  Modified:
c
c    17 July 2010
c
c  Author:
c
c    John Burkardt
c
c  Parameters:
c
c    Input, integer M, N, the number of rows and columns of A.
c    The length of an "element" of A, and the number of "elements".
c
c    Input, double precision A(M,N), the array.
c
c    Output, integer UNIQUE_INDEX(N), the first occurrence index.
c
      implicit none

      integer m
      integer n

      double precision a(m,n)
      double precision diff
      integer i
      integer j1
      integer j2
      integer unique_index(n)
      integer unique_num

      do i = 1, n
        unique_index(i) = -1
      end do
      unique_num = 0

      do j1 = 1, n

        if ( unique_index(j1) .eq. -1 ) then

          unique_num = unique_num + 1
          unique_index(j1) = unique_num

          do j2 = j1 + 1, n
            diff = 0.0D+00
            do i = 1, m
              diff = max ( diff, abs ( a(i,j1) - a(i,j2) ) )
            end do
            if ( diff .eq. 0.0D+00 ) then
              unique_index(j2) = unique_num
            end if
          end do

        end if

      end do

      return
      end
      subroutine r8col_variance ( m, n, a, variance )

c*********************************************************************72
c
cc R8COL_VARIANCE returns the variances of an R8COL.
c
c  Discussion:
c
c    An R8COL is an M by N array of R8 values, regarded
c    as an array of N columns of length M.
c
c  Licensing:
c
c    This code is distributed under the GNU LGPL license.
c
c  Modified:
c
c    13 January 2008
c
c  Author:
c
c    John Burkardt
c
c  Parameters:
c
c    Input, integer M, N, the number of rows and columns in
c    the array.
c
c    Input, double precision A(M,N), the array whose variances are desired.
c
c    Output, double precision VARIANCE(N), the variances of the rows.
c
      implicit none

      integer m
      integer n

      double precision a(m,n)
      double precision a_sum
      integer i
      integer j
      double precision mean
      double precision variance(n)

      do j = 1, n

        a_sum = 0.0D+00
        do i = 1, m
          a_sum = a_sum + a(i,j)
        end do
        mean = a_sum / dble ( m )

        variance(j) = 0.0D+00
        do i = 1, m
          variance(j) = variance(j) + ( a(i,j) - mean )**2
        end do

        if ( 1 .lt. m ) then
          variance(j) = variance(j) / dble ( m - 1 )
        else
          variance(j) = 0.0D+00
        end if

      end do

      return
      end
      function r8r8_compare ( x1, y1, x2, y2 )

c*********************************************************************72
c
cc R8R8_COMPARE compares two R8R8's.
c
c  Discussion:
c
c    An R8R8 is simply a pair of R8 values, stored separately.
c
c  Licensing:
c
c    This code is distributed under the GNU LGPL license.
c
c  Modified:
c
c    08 May 2010
c
c  Author:
c
c    John Burkardt
c
c  Parameters:
c
c    Input, double precision X1, Y1, the first vector.
c
c    Input, double precision X2, Y2, the second vector.
c
c    Output, integer R8R8_COMPARE:
c    -1, (X1,Y1) < (X2,Y2);
c     0, (X1,Y1) = (X2,Y2);
c    +1, (X1,Y1) > (X2,Y2).
c
      implicit none

      integer compare
      integer r8r8_compare
      double precision x1
      double precision x2
      double precision y1
      double precision y2

      if ( x1 .lt. x2 ) then
        compare = -1
      else if ( x2 .lt. x1 ) then
        compare = +1
      else if ( y1 .lt. y2 ) then
        compare = -1
      else if ( y2 .lt. y1 ) then
        compare = +1
      else
        compare = 0
      end if

      r8r8_compare = compare

      return
      end
      subroutine r8r8_print ( a1, a2, title )

c*********************************************************************72
c
cc R8R8_PRINT prints an R8R8.
c
c  Discussion:
c
c    An R8R8 is simply a pair of R8R8's, stored separately.
c
c    A format is used which suggests a coordinate pair:
c
c  Example:
c
c    Center : ( 1.23, 7.45 )
c
c  Licensing:
c
c    This code is distributed under the GNU LGPL license.
c
c  Modified:
c
c    12 September 2011
c
c  Author:
c
c    John Burkardt
c
c  Parameters:
c
c    Input, double precision A1, A2, the coordinates of the vector.
c
c    Input, character * ( * ) TITLE, a title.
c
      implicit none

      double precision a1
      double precision a2
      character * ( * )  title

      if ( 0 .lt. len_trim ( title ) ) then
        write ( *, '( 2x, a, a4, g14.6, a1, g14.6, a1 )' ) 
     &    trim ( title ), ' : (', a1, ',', a2, ')'
      else
        write ( *, '( 2x, a1, g14.6, a1, g14.6, a1 )' ) '(', a1, ',', a2, ')'
      end if

      return
      end
      function r8r8r8_compare ( x1, y1, z1, x2, y2, z2 )

c*********************************************************************72
c
cc R8R8R8_COMPARE compares two R8R8R8's.
c
c  Discussion:
c
c    An R8R8R8 is simply 3 R8 values, stored as scalars.
c
c  Licensing:
c
c    This code is distributed under the GNU LGPL license.
c
c  Modified:
c
c    03 December 2011
c
c  Author:
c
c    John Burkardt
c
c  Parameters:
c
c    Input, double precision X1, Y1, Z1, the first vector.
c
c    Input, double precision X2, Y2, Z2, the second vector.
c
c    Output, integer R8R8R8_COMPARE:
c    -1, (X1,Y1,Z1) .lt. (X2,Y2,Z2);
c     0, (X1,Y1,Z1) = (X2,Y2,Z2);
c    +1, (X1,Y1,Z1) > (X2,Y2,Z2).
c
      implicit none

      integer compare
      integer r8r8r8_compare
      double precision x1
      double precision x2
      double precision y1
      double precision y2
      double precision z1
      double precision z2

      if ( x1 .lt. x2 ) then
        compare = -1
      else if ( x2 .lt. x1 ) then
        compare = +1
      else if ( y1 .lt. y2 ) then
        compare = -1
      else if ( y2 .lt. y1 ) then
        compare = +1
      else if ( z1 .lt. z2 ) then
        compare = -1
      else if ( z2 .lt. z1 ) then
        compare = +1
      else
        compare = 0
      end if

      r8r8r8_compare = compare

      return
      end
      subroutine r8r8r8vec_index_insert_unique ( n_max, n, x, y, z, 
     &  indx, xval, yval, zval, ival, ierror )

c*********************************************************************72
c
cc R8R8R8VEC_INDEX_INSERT_UNIQUE inserts unique R8R8R in an indexed sorted list.
c
c  Discussion:
c
c    An R8R8R8VEC is set of N R8R8R8 items.
c
c    An R8R8R8 is simply 3 R8 values, stored as scalars.
c
c    If the input value does not occur in the current list, it is added,
c    and N, X, Y, Z and INDX are updated.
c
c  Licensing:
c
c    This code is distributed under the GNU LGPL license.
c
c  Modified:
c
c    03 December 2011
c
c  Author:
c
c    John Burkardt
c
c  Parameters:
c
c    Input, integer N_MAX, the maximum size of the list.
c
c    Input/output, integer N, the size of the list.
c
c    Input/output, double precision X(N), Y(N), Z(N), the R8R8R8 vector.
c
c    Input/output, integer INDX(N), the sort index of the list.
c
c    Input, double precision XVAL, YVAL, ZVAL, the value to be inserted
c    if it is not already in the list.
c
c    Output, integer IVAL, the index in X, Y, Z corresponding
c    to the value XVAL, YVAL, ZVAL.
c
c    Output, integer IERROR, 0 for no error, 1 if an error
c    occurred.
c
      implicit none

      integer n_max

      integer equal
      integer ierror
      integer indx(n_max)
      integer ival
      integer less
      integer more
      integer n
      double precision x(n_max)
      double precision xval
      double precision y(n_max)
      double precision yval
      double precision z(n_max)
      double precision zval

      ierror = 0

      if ( n .le. 0 ) then

        if ( n_max .le. 0 ) then
          ierror = 1
          write ( *, '(a)' ) ' '
          write ( *, '(a)' ) 
     &      'R8R8R8VEC_INDEX_INSERT_UNIQUE - Fatal error!'
          write ( *, '(a)' ) '  Not enough space to store new data.'
          return
        end if

        n = 1
        x(1) = xval
        y(1) = yval
        z(1) = zval
        indx(1) = 1
        ival = 1
        return

      end if
c
c  Does ( XVAL, YVAL, ZVAL ) already occur in ( X, Y, Z)?
c
      call r8r8r8vec_index_search ( n, x, y, z, indx, xval, yval, zval, 
     &  less, equal, more )

      if ( equal .eq. 0 ) then

        if ( n_max .le. n ) then
          ierror = 1
          write ( *, '(a)' ) ' '
          write ( *, '(a)' ) 
     &      'R8R8R8VEC_INDEX_INSERT_UNIQUE - Fatal error!'
          write ( *, '(a)' ) '  Not enough space to store new data.'
          return
        end if

        x(n+1) = xval
        y(n+1) = yval
        z(n+1) = zval
        ival = n + 1
        indx(n+1:more+1:-1) = indx(n:more:-1)
        indx(more) = n + 1
        n = n + 1

      else

        ival = indx(equal)

      end if

      return
      end
      subroutine r8r8r8vec_index_search ( n, x, y, z, indx, xval, yval, 
     &  zval, less, equal, more )

c*********************************************************************72
c
cc R8R8R8VEC_INDEX_SEARCH searches for R8R8R8 value in an indexed sorted list.
c
c  Discussion:
c
c    An R8R8R8VEC is set of N R8R8R8 items.
c
c    An R8R8R8 is simply 3 R8 values, stored as scalars.
c
c  Licensing:
c
c    This code is distributed under the GNU LGPL license.
c
c  Modified:
c
c    03 December 2011
c
c  Author:
c
c    John Burkardt
c
c  Parameters:
c
c    Input, integer N, the size of the list.
c
c    Input, double precision X(N), Y(N), Z(N), the list.
c
c    Input, integer INDX(N), the sort index of the list.
c
c    Input, double precision XVAL, YVAL, ZVAL, the value to be sought.
c
c    Output, integer LESS, EQUAL, MORE, the indexes in INDX of the
c    entries of X that are just less than, equal to, and just greater
c    than XVAL.  If XVAL does not occur in X, then EQUAL is zero.
c    If XVAL is the minimum entry of X, then LESS is 0.  If XVAL
c    is the greatest entry of X, then MORE is N+1.
c
      implicit none

      integer n

      integer compare
      integer r8r8r8_compare
      integer equal
      integer hi
      integer indx(n)
      integer less
      integer lo
      integer mid
      integer more
      double precision x(n)
      double precision xhi
      double precision xlo
      double precision xmid
      double precision xval
      double precision y(n)
      double precision yhi
      double precision ylo
      double precision ymid
      double precision yval
      double precision z(n)
      double precision zhi
      double precision zlo
      double precision zmid
      double precision zval

      if ( n .le. 0 ) then
        less = 0
        equal = 0
        more = 0
        return
      end if

      lo = 1
      hi = n

      xlo = x(indx(lo))
      ylo = y(indx(lo))
      zlo = z(indx(lo))

      xhi = x(indx(hi))
      yhi = y(indx(hi))
      zhi = z(indx(hi))

      compare = r8r8r8_compare ( xval, yval, zval, xlo, ylo, zlo )

      if ( compare .eq. -1 ) then
        less = 0
        equal = 0
        more = 1
        return
      else if ( compare .eq. 0 ) then
        less = 0
        equal = 1
        more = 2
        return
      end if

      compare = r8r8r8_compare ( xval, yval, zval, xhi, yhi, zhi )

      if ( compare .eq. 1 ) then
        less = n
        equal = 0
        more = n + 1
        return
      else if ( compare .eq. 0 ) then
        less = n - 1
        equal = n
        more = n + 1
        return
      end if

10    continue

        if ( lo + 1 .eq. hi ) then
          less = lo
          equal = 0
          more = hi
          go to 20
        end if

        mid = ( lo + hi ) / 2
        xmid = x(indx(mid))
        ymid = y(indx(mid))
        zmid = z(indx(mid))

        compare = r8r8r8_compare ( xval, yval, zval, xmid, ymid, zmid )

        if ( compare .eq. 0 ) then
          equal = mid
          less = mid - 1
          more = mid + 1
          return
        else if ( compare .eq. -1 ) then
          hi = mid
        else if ( compare .eq. +1 ) then
          lo = mid
        end if

      go to 10

20    continue

      return
      end
      subroutine r8r8vec_index_insert_unique ( n_max, n, x, y, indx, 
     &  xval, yval, ival, ierror )

c*********************************************************************72
c
cc R8R8VEC_INDEX_INSERT_UNIQUE inserts a unique R8R8 in an indexed sorted list.
c
c  Discussion:
c
c    An R8R8VEC is set of N R8R8 items.
c
c    An R8R8 is simply 2 R8 values, stored as scalars.
c
c    If the input value does not occur in the current list, it is added,
c    and N, X, Y and INDX are updated.
c
c  Licensing:
c
c    This code is distributed under the GNU LGPL license.
c
c  Modified:
c
c    03 December 2011
c
c  Author:
c
c    John Burkardt
c
c  Parameters:
c
c    Input, integer N_MAX, the maximum size of the list.
c
c    Input/output, integer N, the size of the list.
c
c    Input/output, double precision X(N), Y(N), the list of R8R8 vectors.
c
c    Input/output, integer INDX(N), the sort index of the list.
c
c    Input, double precision XVAL, YVAL, the value to be inserted if it is
c    not already in the list.
c
c    Output, integer IVAL, the index in X, Y corresponding to the
c    value XVAL, YVAL.
c
c    Output, integer IERROR, 0 for no error, 1 if an
c    error occurred.
c
      implicit none

      integer n_max

      integer equal
      integer ierror
      integer indx(n_max)
      integer ival
      integer less
      integer more
      integer n
      double precision x(n_max)
      double precision xval
      double precision y(n_max)
      double precision yval

      ierror = 0

      if ( n .le. 0 ) then

        if ( n_max .le. 0 ) then
          ierror = 1
          write ( *, '(a)' ) ' '
          write ( *, '(a)' ) 
     &      'R8R8VEC_INDEX_INSERT_UNIQUE - Fatal error!'
          write ( *, '(a)' ) '  Not enough space to store new data.'
          return
        end if

        n = 1
        x(1) = xval
        y(1) = yval
        indx(1) = 1
        ival = 1
        return

      end if
c
c  Does ( XVAL, YVAL ) already occur in ( X, Y )?
c
      call r8r8vec_index_search ( n, x, y, indx, xval, yval, less, 
     &  equal, more )

      if ( equal .eq. 0 ) then

        if ( n_max .le. n ) then
          ierror = 1
          write ( *, '(a)' ) ' '
          write ( *, '(a)' ) 
     &      'R8R8VEC_INDEX_INSERT_UNIQUE - Fatal error!'
          write ( *, '(a)' ) '  Not enough space to store new data.'
          return
        end if

        x(n+1) = xval
        y(n+1) = yval
        ival = n + 1
        indx(n+1:more+1:-1) = indx(n:more:-1)
        indx(more) = n + 1
        n = n + 1

      else

        ival = indx(equal)

      end if

      return
      end
      subroutine r8r8vec_index_search ( n, x, y, indx, xval, yval, 
     &  less, equal, more )

c*********************************************************************72
c
cc R8R8VEC_INDEX_SEARCH searches for an R8R8 in an indexed sorted list.
c
c  Discussion:
c
c    An R8R8VEC is set of N R8R8 items.
c
c    An R8R8 is simply 2 R8 values, stored as scalars.
c
c  Licensing:
c
c    This code is distributed under the GNU LGPL license.
c
c  Modified:
c
c    03 December 2011
c
c  Author:
c
c    John Burkardt
c
c  Parameters:
c
c    Input, integer N, the size of the current list.
c
c    Input, double precision X(N), Y(N), the list.
c
c    Input, integer INDX(N), the sort index of the list.
c
c    Input, double precision XVAL, YVAL, the value to be sought.
c
c    Output, integer LESS, EQUAL, MORE, the indexes in INDX of the
c    entries of X that are just less than, equal to, and just greater
c    than XVAL.  If XVAL does not occur in X, then EQUAL is zero.
c    If XVAL is the minimum entry of X, then LESS is 0.  If XVAL
c    is the greatest entry of X, then MORE is N+1.
c
      implicit none

      integer n

      integer compare
      integer r8r8_compare
      integer equal
      integer hi
      integer indx(n)
      integer less
      integer lo
      integer mid
      integer more
      double precision x(n)
      double precision xhi
      double precision xlo
      double precision xmid
      double precision xval
      double precision y(n)
      double precision yhi
      double precision ylo
      double precision ymid
      double precision yval

      if ( n .le. 0 ) then
        less = 0
        equal = 0
        more = 0
        return
      end if

      lo = 1
      hi = n

      xlo = x(indx(lo))
      ylo = y(indx(lo))

      xhi = x(indx(hi))
      yhi = y(indx(hi))

      compare = r8r8_compare ( xval, yval, xlo, ylo )

      if ( compare .eq. -1 ) then
        less = 0
        equal = 0
        more = 1
        return
      else if ( compare .eq. 0 ) then
        less = 0
        equal = 1
        more = 2
        return
      end if

      compare = r8r8_compare ( xval, yval, xhi, yhi )

      if ( compare .eq. 1 ) then
        less = n
        equal = 0
        more = n + 1
        return
      else if ( compare .eq. 0 ) then
        less = n - 1
        equal = n
        more = n + 1
        return
      end if

10    continue

        if ( lo + 1 .eq. hi ) then
          less = lo
          equal = 0
          more = hi
          go to 20
        end if

        mid = ( lo + hi ) / 2
        xmid = x(indx(mid))
        ymid = y(indx(mid))

        compare = r8r8_compare ( xval, yval, xmid, ymid )

        if ( compare .eq. 0 ) then
          equal = mid
          less = mid - 1
          more = mid + 1
          return
        else if ( compare .eq. -1 ) then
          hi = mid
        else if ( compare .eq. +1 ) then
          lo = mid
        end if

      go to 10

20    continue

      return
      end
      subroutine r8int_to_r8int ( rmin, rmax, r, r2min, r2max, r2 )

c*********************************************************************72
c
cc R8INT_TO_R8INT maps one R8INT to another.
c
c  Discussion:
c
c    The formula used is
c
c      R2 := R2MIN + ( R2MAX - R2MIN ) * ( R - RMIN ) / ( RMAX - RMIN )
c
c  Licensing:
c
c    This code is distributed under the GNU LGPL license.
c
c  Modified:
c
c    03 December 2011
c
c  Author:
c
c    John Burkardt
c
c  Parameters:
c
c    Input, double precision RMIN, RMAX, the first range.
c
c    Input, double precision R, the number to be converted.
c
c    Input, double precision R2MAX, R2MIN, the second range.
c
c    Output, double precision R2, the corresponding value in
c    the range [R2MIN,R2MAX].
c
      implicit none

      double precision r
      double precision rmax
      double precision rmin
      double precision r2
      double precision r2max
      double precision r2min

      if ( rmax .eq. rmin ) then

        r2 = ( r2max + r2min ) / 2.0D+00

      else

        r2 = ( ( ( rmax - r        ) * r2min   
     &         + (        r - rmin ) * r2max ) 
     &         / ( rmax     - rmin ) )

      end if

      return
      end
      subroutine r8int_to_i4int ( rmin, rmax, r, imin, imax, i )

c*********************************************************************72
c
cc R8INT_TO_I4INT maps an R8INT to an integer interval.
c
c  Discussion:
c
c    The formula used is
c
c      I := IMIN + ( IMAX - IMIN ) * ( R - RMIN ) / ( RMAX - RMIN )
c
c  Licensing:
c
c    This code is distributed under the GNU LGPL license.
c
c  Modified:
c
c    03 December 2011
c
c  Author:
c
c    John Burkardt
c
c  Parameters:
c
c    Input, double precision RMIN, RMAX, the range.
c
c    Input, double precision R, the number to be converted.
c
c    Input, integer IMAX, IMIN, the integer range.
c
c    Output, integer I, the corresponding value in the
c    range [IMIN,IMAX].
c
      implicit none

      integer i
      integer imax
      integer imin
      double precision r
      double precision rmax
      double precision rmin

      if ( rmax .eq. rmin ) then

        i = ( imax + imin ) / 2

      else

        i = nint ( 
     &    ( ( rmax - r        ) * dble ( imin )   
     &    + (        r - rmin ) * dble ( imax ) ) 
     &    / ( rmax     - rmin ) )

      end if

      return
      end
      subroutine r8mat_add ( m, n, alpha, a, beta, b, c )

c*********************************************************************72
c
cc R8MAT_ADD computes C = alpha * A + beta * B for R8MAT's.
c
c  Discussion:
c
c    An R8MAT is an array of R8 values.
c
c  Licensing:
c
c    This code is distributed under the GNU LGPL license.
c
c  Modified:
c
c    01 December 2011
c
c  Author:
c
c    John Burkardt
c
c  Parameters:
c
c    Input, integer M, N, the number of rows and columns.
c
c    Input, double precision ALPHA, the multiplier for A.
c
c    Input, double precision A(M,N), the first matrix.
c
c    Input, double precision BETA, the multiplier for A.
c
c    Input, double precision B(M,N), the second matrix.
c
c    Output, double precision C(M,N), the sum of alpha*A+beta*B.
c
      implicit none

      integer m
      integer n

      double precision a(m,n)
      double precision alpha
      double precision b(m,n)
      double precision beta
      double precision c(m,n)
      integer i
      integer j

      do j = 1, n
        do i = 1, m
          c(i,j) = alpha * a(i,j) + beta * b(i,j)
        end do
      end do

      return
      end
      subroutine r8mat_amax ( m, n, a, amax )

c*********************************************************************72
c
cc R8MAT_AMAX computes the largest absolute value in an R8MAT.
c
c  Discussion:
c
c    An R8MAT is an array of R8 values.
c
c  Licensing:
c
c    This code is distributed under the GNU LGPL license.
c
c  Modified:
c
c    07 September 2012
c
c  Author:
c
c    John Burkardt
c
c  Parameters:
c
c    Input, integer M, N, the number of rows and columns.
c
c    Input, double precision A(M,N), the matrix.
c
c    Output, double precision AMAX, the largest absolute value in A.
c
      implicit none

      integer m
      integer n

      double precision a(m,n)
      double precision amax
      integer i
      integer j

      amax = abs ( a(1,1) )

      do j = 1, n
        do i = 1, m
          amax = max ( amax, abs ( a(i,j) ) )
        end do
      end do

      return
      end
      subroutine r8mat_border_add ( m, n, table, table2 )

c*********************************************************************72
c
cc R8MAT_BORDER_ADD adds a "border" to an R8MAT.
c
c  Discussion:
c
c    An R8MAT is an array of R8's.
c
c    We suppose the input data gives values of a quantity on nodes
c    in the interior of a 2D grid, and we wish to create a new table
c    with additional positions for the nodes that would be on the
c    border of the 2D grid.
c
c                  0 0 0 0 0 0
c      * * * *     0 * * * * 0
c      * * * * --> 0 * * * * 0
c      * * * *     0 * * * * 0
c                  0 0 0 0 0 0
c
c    The illustration suggests the situation in which a 3 by 4 array
c    is input, and a 5 by 6 array is to be output.
c
c    The old data is shifted to its correct positions in the new array.
c
c  Licensing:
c
c    This code is distributed under the GNU LGPL license.
c
c  Modified:
c
c    28 April 2008
c
c  Author:
c
c    John Burkardt
c
c  Parameters:
c
c    Input, integer M, the spatial dimension.
c
c    Input, integer N, the number of points.
c
c    Input, double precision TABLE(M,N), the table data.
c
c    Output, double precision TABLE2(M+2,N+2), the augmented table data.
c
      implicit none

      integer m
      integer n

      integer i
      integer j
      double precision table(m,n)
      double precision table2(m+2,n+2)

      do j = 1, n + 2
        table2(1,j) = 0.0D+00
      end do

      do j = 1, n + 2
        table2(m+2,j) = 0.0D+00
      end do

      do i = 2, m + 1
        table2(i,1) = 0.0D+00
      end do

      do i = 2, m + 1
        table2(i,n+2) = 0.0D+00
      end do

      do j = 2, n + 1
        do i = 2, m + 1
          table2(i,j) = table(i-1,j-1)
        end do
      end do

      return
      end
      subroutine r8mat_border_cut ( m, n, table, table2 )

c*********************************************************************72
c
cc R8MAT_BORDER_CUT cuts the "border" of an R8MAT.
c
c  Discussion:
c
c    An R8MAT is an array of R8's.
c
c    We suppose the input data gives values of a quantity on nodes
c    on a 2D grid, and we wish to create a new table corresponding only
c    to those nodes in the interior of the 2D grid.
c
c      0 0 0 0 0 0
c      0 * * * * 0    * * * *
c      0 * * * * 0 -> * * * *
c      0 * * * * 0    * * * *
c      0 0 0 0 0 0
c
c    The illustration suggests the situation in which a 5 by 6 array
c    is input, and a 3 by 4 array is to be output.
c
c  Licensing:
c
c    This code is distributed under the GNU LGPL license.
c
c  Modified:
c
c    28 April 2008
c
c  Author:
c
c    John Burkardt
c
c  Parameters:
c
c    Input, integer M, the spatial dimension.
c
c    Input, integer N, the number of points.
c
c    Input, double precision TABLE(M,N), the table data.
c
c    Output, double precision TABLE2(M-2,N-2), the new table data.
c
      implicit none

      integer m
      integer n

      integer i
      integer j
      double precision table(m,n)
      double precision table2(m-2,n-2)

      if ( m .le. 2 .or. n .le. 2 ) then
        return
      end if

      do j = 1, n - 2
        do i = 1, m - 2
          table2(i,j) = table(i+1,j+1)
        end do
      end do

      return
      end
      subroutine r8mat_cholesky_factor ( n, a, c, flag )

c*********************************************************************72
c
cc R8MAT_CHOLESKY_FACTOR computes the Cholesky factor of a symmetric matrix.
c
c  Discussion:
c
c    An R8MAT is an array of R8's.
c
c    The matrix must be symmetric and positive semidefinite.
c
c    For a positive semidefinite symmetric matrix A, the Cholesky factorization
c    is a lower triangular matrix L such that:
c
c      A = L * L'
c
c  Licensing:
c
c    This code is distributed under the GNU LGPL license.
c
c  Modified:
c
c    08 April 2009
c
c  Author:
c
c    John Burkardt
c
c  Parameters:
c
c    Input, integer N, the number of rows and columns of
c    the matrix A.
c
c    Input, double precision A(N,N), the N by N matrix.
c
c    Output, double precision C(N,N), the N by N lower triangular
c    Cholesky factor.
c
c    Output, integer FLAG:
c    0, no error occurred.
c    1, the matrix is not positive definite.
c
      implicit none

      integer n

      double precision a(n,n)
      double precision c(n,n)
      integer flag
      integer i
      integer j
      integer k
      double precision sum2

      flag = 0

      do j = 1, n
        do i = 1, n
          c(i,j) = a(i,j)
        end do
      end do

      do j = 1, n

        do i = 1, j - 1
          c(i,j) = 0.0D+00
        end do

        do i = j, n

          sum2 = 0.0D+00
          do k = 1, j - 1
            sum2 = sum2 + c(j,k) * c(i,k)
          end do
          sum2 = c(j,i) - sum2

          if ( i .eq. j ) then
            if ( sum2 .le. 0.0D+00 ) then
              flag = 1
              return
            else
              c(i,j) = sqrt ( sum2 )
            end if
          else
            if ( c(j,j) .ne. 0.0D+00 ) then
              c(i,j) = sum2 / c(j,j)
            else
              c(i,j) = 0.0D+00
            end if
          end if

        end do

      end do

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

c*********************************************************************72
c
cc R8MAT_CHOLESKY_SOLVE solves a Cholesky factored linear system A * x = b.
c
c  Discussion:
c
c    An R8MAT is an array of R8's.
c
c  Licensing:
c
c    This code is distributed under the GNU LGPL license.
c
c  Modified:
c
c    09 April 2009
c
c  Author:
c
c    John Burkardt
c
c  Parameters:
c
c    Input, integer N, the number of rows and columns of
c    the matrix A.
c
c    Input, double precision A(N,N), the N by N Cholesky factor of the
c    system matrix.
c
c    Input, double precision B(N), the right hand side of the linear system.
c
c    Output, double precision X(N), the solution of the linear system.
c
      implicit none

      integer n

      double precision a(n,n)
      double precision b(n)
      double precision x(n)
c
c  Solve L * y = b.
c
      call r8mat_l_solve ( n, a, b, x )
c
c  Solve L' * x = y.
c
      call r8mat_lt_solve ( n, a, x, x )

      return
      end
      subroutine r8mat_choresky_factor ( n, a, r, flag )

c*********************************************************************72
c
cc R8MAT_CHORESKY_FACTOR computes the "Choresky" factor of a symmetric matrix.
c
c  Discussion:
c
c    An R8MAT is an array of R8's.
c
c    The matrix must be symmetric and positive semidefinite.
c
c    For a positive semidefinite symmetric matrix A, the Cholesky factorization
c    is an upper triangular matrix R such that:
c
c      A = R * R'
c
c    Note that the usual Cholesky factor is a LOWER triangular matrix L
c    such that
c
c      A = L * L'
c
c  Licensing:
c
c    This code is distributed under the GNU LGPL license.
c
c  Modified:
c
c    08 April 2009
c
c  Author:
c
c    John Burkardt
c
c  Parameters:
c
c    Input, integer N, the number of rows and columns of
c    the matrix A.
c
c    Input, double precision A(N,N), the N by N matrix.
c
c    Output, double precision R(N,N), the N by N upper triangular
c    "Choresky" factor.
c
c    Output, integer FLAG:
c    0, no error occurred.
c    1, the matrix is not positive definite.
c
      implicit none

      integer n

      double precision a(n,n)
      double precision c(n,n)
      integer flag
      integer i
      integer j
      integer k
      double precision r(n,n)
      double precision sum2

      flag = 0

      do j = 1, n
        do i = 1, n
          c(n+1-i,n+1-j) = a(i,j)
        end do
      end do

      do j = 1, n

        do i = 1, j - 1
          c(i,j) = 0.0D+00
        end do

        do i = j, n

          sum2 = 0.0D+00
          do k = 1, j - 1
            sum2 = sum2 + c(j,k) * c(i,k)
          end do
          sum2 = c(j,i) - sum2

          if ( i .eq. j ) then
            if ( sum2 .le. 0.0D+00 ) then
              flag = 1
              return
            else
              c(i,j) = sqrt ( sum2 )
            end if
          else
            if ( c(j,j) .ne. 0.0D+00 ) then
              c(i,j) = sum2 / c(j,j)
            else
              c(i,j) = 0.0D+00
            end if
          end if

        end do

      end do

      do j = 1, n
        do i = 1, n
          r(i,j) = c(n+1-i,n+1-j)
        end do
      end do

      return
      end
      subroutine r8mat_copy ( m, n, a1, a2 )

c*********************************************************************72
c
cc R8MAT_COPY copies an R8MAT.
c
c  Discussion:
c
c    An R8MAT is an array of R8's.
c
c  Licensing:
c
c    This code is distributed under the GNU LGPL license.
c
c  Modified:
c
c    26 July 2008
c
c  Author:
c
c    John Burkardt
c
c  Parameters:
c
c    Input, integer M, N, the order of the matrix.
c
c    Input, double precision A1(M,N), the matrix to be copied.
c
c    Output, double precision A2(M,N), a copy of the matrix.
c
      implicit none

      integer m
      integer n

      double precision a1(m,n)
      double precision a2(m,n)
      integer i
      integer j

      do j = 1, n
        do i = 1, m
          a2(i,j) = a1(i,j)
        end do
      end do

      return
      end
      subroutine r8mat_det ( n, a, det )

c*********************************************************************72
c
cc R8MAT_DET computes the determinant of an R8MAT.
c
c  Discussion:
c
c    An R8MAT is an array of R8 values.
c
c  Licensing:
c
c    This code is distributed under the GNU LGPL license.
c
c  Modified:
c
c    19 September 2010
c
c  Author:
c
c    Original FORTRAN77 version by Helmut Spaeth.
c    This FORTRAN77 version by John Burkardt.
c
c  Reference:
c
c    Helmut Spaeth,
c    Cluster Analysis Algorithms
c    for Data Reduction and Classification of Objects,
c    Ellis Horwood, 1980, page 125-127.
c
c  Parameters:
c
c    Input, integer N, the order of the matrix.
c
c    Input, double precision A(N,N), the matrix whose determinant is desired.
c
c    Output, double precision DET, the determinant of the matrix.
c
      implicit none

      integer n

      double precision a(n,n)
      double precision b(n,n)
      double precision det
      integer i
      integer j
      integer k
      integer m
      integer piv
      double precision t

      do j = 1, n
        do i = 1, n
          b(i,j) = a(i,j)
        end do
      end do

      det = 1.0D+00

      do k = 1, n

        piv = k
        do i = k + 1, n
          if ( abs ( b(piv,k) ) .lt. abs ( b(i,k) ) ) then
            piv = i
          end if
        end do

        m = piv

        if ( m .ne. k ) then
          det = - det
          t      = b(m,k)
          b(m,k) = b(k,k)
          b(k,k) = t
        end if

        det = det * b(k,k)

        if ( b(k,k) .ne. 0.0D+00 ) then

          do i = k + 1, n
            b(i,k) = - b(i,k) / b(k,k)
          end do

          do j = k + 1, n

            if ( m .ne. k ) then
              t      = b(m,j)
              b(m,j) = b(k,j)
              b(k,j) = t
            end if

            do i = k + 1, n
              b(i,j) = b(i,j) + b(i,k) * b(k,j)
            end do

          end do

        end if

      end do

      return
      end
      function r8mat_det_2d ( a )

c*********************************************************************72
c
cc R8MAT_DET_2D computes the determinant of a 2 by 2 matrix.
c
c  Discussion:
c
c    An R8MAT is an array of R8's.
c
c    The determinant of a 2 by 2 matrix is
c
c      a11 * a22 - a12 * a21.
c
c  Licensing:
c
c    This code is distributed under the GNU LGPL license.
c
c  Modified:
c
c    22 July 2008
c
c  Author:
c
c    John Burkardt
c
c  Parameters:
c
c    Input, double precision A(2,2), the matrix whose determinant is desired.
c
c    Output, double precision RMAT_DET_2D, the determinant of the matrix.
c
      implicit none

      double precision a(2,2)
      double precision r8mat_det_2d

      r8mat_det_2d = a(1,1) * a(2,2) - a(1,2) * a(2,1)

      return
      end
      function r8mat_det_3d ( a )

c*********************************************************************72
c
cc R8MAT_DET_3D computes the determinant of a 3 by 3 matrix.
c
c  Discussion:
c
c    An R8MAT is an array of R8's.
c
c    The determinant of a 3 by 3 matrix is
c
c        a11 * a22 * a33 - a11 * a23 * a32
c      + a12 * a23 * a31 - a12 * a21 * a33
c      + a13 * a21 * a32 - a13 * a22 * a31
c
c  Licensing:
c
c    This code is distributed under the GNU LGPL license.
c
c  Modified:
c
c    22 July 2008
c
c  Author:
c
c    John Burkardt
c
c  Parameters:
c
c    Input, double precision A(3,3), the matrix whose determinant is desired.
c
c    Output, double precision RMAT_DET_3D, the determinant of the matrix.
c
      implicit none

      double precision a(3,3)
      double precision r8mat_det_3d

      r8mat_det_3d =
     &       a(1,1) * ( a(2,2) * a(3,3) - a(2,3) * a(3,2) )
     &     + a(1,2) * ( a(2,3) * a(3,1) - a(2,1) * a(3,3) )
     &     + a(1,3) * ( a(2,1) * a(3,2) - a(2,2) * a(3,1) )

      return
      end
      function r8mat_det_4d ( a )

c*********************************************************************72
c
cc R8MAT_DET_4D computes the determinant of a 4 by 4 R8MAT.
c
c  Discussion:
c
c    An R8MAT is an array of R8's.
c
c  Licensing:
c
c    This code is distributed under the GNU LGPL license.
c
c  Modified:
c
c    31 August 2008
c
c  Author:
c
c    John Burkardt
c
c  Parameters:
c
c    Input, double precision A(4,4), the matrix whose determinant is desired.
c
c    Output, double precision R8MAT_DET_4D, the determinant of the matrix.
c
      implicit none

      double precision a(4,4)
      double precision r8mat_det_4d

      r8mat_det_4d =
     &       a(1,1) * (
     &           a(2,2) * ( a(3,3) * a(4,4) - a(3,4) * a(4,3) )
     &         - a(2,3) * ( a(3,2) * a(4,4) - a(3,4) * a(4,2) )
     &         + a(2,4) * ( a(3,2) * a(4,3) - a(3,3) * a(4,2) ) )
     &     - a(1,2) * (
     &           a(2,1) * ( a(3,3) * a(4,4) - a(3,4) * a(4,3) )
     &         - a(2,3) * ( a(3,1) * a(4,4) - a(3,4) * a(4,1) )
     &         + a(2,4) * ( a(3,1) * a(4,3) - a(3,3) * a(4,1) ) )
     &     + a(1,3) * (
     &           a(2,1) * ( a(3,2) * a(4,4) - a(3,4) * a(4,2) )
     &         - a(2,2) * ( a(3,1) * a(4,4) - a(3,4) * a(4,1) )
     &         + a(2,4) * ( a(3,1) * a(4,2) - a(3,2) * a(4,1) ) )
     &     - a(1,4) * (
     &           a(2,1) * ( a(3,2) * a(4,3) - a(3,3) * a(4,2) )
     &         - a(2,2) * ( a(3,1) * a(4,3) - a(3,3) * a(4,1) )
     &         + a(2,3) * ( a(3,1) * a(4,2) - a(3,2) * a(4,1) ) )

      return
      end
      function r8mat_det_5d ( a )

c*********************************************************************72
c
cc R8MAT_DET_5D computes the determinant of a 5 by 5 R8MAT.
c
c  Discussion:
c
c    An R8MAT is an array of R8's.
c
c  Licensing:
c
c    This code is distributed under the GNU LGPL license.
c
c  Modified:
c
c    02 March 1999
c
c  Author:
c
c    John Burkardt
c
c  Parameters:
c
c    Input, double precision A(5,5), the matrix whose determinant is desired.
c
c    Output, double precision R8MAT_DET_5D, the determinant of the matrix.
c
      implicit none

      double precision a(5,5)
      double precision b(4,4)
      integer i
      integer inc
      integer j
      integer k
      double precision r8mat_det_4d
      double precision r8mat_det_5d
c
c  Expand the determinant into the sum of the determinants of the
c  five 4 by 4 matrices created by dropping row 1, and column k.
c
      r8mat_det_5d = 0.0D+00

      do k = 1, 5

        do i = 1, 4
          do j = 1, 4

            if ( j .lt. k ) then
              inc = 0
            else
              inc = 1
            end if

            b(i,j) = a(i+1,j+inc)

          end do
        end do

        r8mat_det_5d = r8mat_det_5d + (-1)**( k + 1 )
     &    * a(1,k) * r8mat_det_4d ( b )

      end do

      return
      end
      subroutine r8mat_diag_add_scalar ( n, a, s )

c*********************************************************************72
c
cc R8MAT_DIAG_ADD_SCALAR adds a scalar to the diagonal of an R8MAT.
c
c  Discussion:
c
c    An R8MAT is an array of R8's.
c
c  Licensing:
c
c    This code is distributed under the GNU LGPL license.
c
c  Modified:
c
c    31 August 2008
c
c  Author:
c
c    John Burkardt
c
c  Parameters:
c
c    Input, integer N, the number of rows and columns of the matrix.
c
c    Input/output, double precision A(N,N), the N by N matrix to be modified.
c
c    Input, double precision S, the value to be added to the diagonal
c    of the matrix.
c
      implicit none

      integer n

      double precision a(n,n)
      integer i
      double precision s

      do i = 1, n
        a(i,i) = a(i,i) + s
      end do

      return
      end
      subroutine r8mat_diag_add_vector ( n, a, v )

c*********************************************************************72
c
cc R8MAT_DIAG_ADD_VECTOR adds a vector to the diagonal of an R8MAT.
c
c  Discussion:
c
c    An R8MAT is an array of R8's.
c
c  Licensing:
c
c    This code is distributed under the GNU LGPL license.
c
c  Modified:
c
c    02 July 2009
c
c  Author:
c
c    John Burkardt
c
c  Parameters:
c
c    Input, integer N, the number of rows and columns of
c    the matrix.
c
c    Input/output, double precision A(N,N), the N by N matrix.
c
c    Input, real double precision V(N), the vector to be added
c    to the diagonal of A.
c
      implicit none

      integer n

      double precision a(n,n)
      integer i
      double precision v(n)

      do i = 1, n
        a(i,i) = a(i,i) + v(i)
      end do

      return
      end
      subroutine r8mat_diag_get_vector ( n, a, v )

c*********************************************************************72
c
cc R8MAT_DIAG_GET_VECTOR gets the value of the diagonal of an R8MAT.
c
c  Discussion:
c
c    An R8MAT is an array of R8's.
c
c  Licensing:
c
c    This code is distributed under the GNU LGPL license.
c
c  Modified:
c
c    02 July 2009
c
c  Author:
c
c    John Burkardt
c
c  Parameters:
c
c    Input, integer N, the number of rows and columns of
c    the matrix.
c
c    Input, double precision A(N,N), the N by N matrix.
c
c    Output, double precision V(N), the diagonal entries
c    of the matrix.
c
      implicit none

      integer n

      double precision a(n,n)
      integer i
      double precision v(n)

      do i = 1, n
        v(i) = a(i,i)
      end do

      return
      end
      subroutine r8mat_diag_set_scalar ( n, a, s )

c*********************************************************************72
c
cc R8MAT_DIAG_SET_SCALAR sets the diagonal of a matrix to a scalar value.
c
c  Licensing:
c
c    This code is distributed under the GNU LGPL license.
c
c  Modified:
c
c    17 March 2000
c
c  Author:
c
c    John Burkardt
c
c  Parameters:
c
c    Input, integer N, the number of rows and columns of the matrix.
c
c    Input/output, double precision A(N,N), the N by N matrix to be modified.
c
c    Input, double precision S, the value to be assigned to the
c    diagonal of the matrix.
c
      implicit none

      integer n

      double precision a(n,n)
      integer i
      double precision s

      do i = 1, n
        a(i,i) = s
      end do

      return
      end
      subroutine r8mat_diag_set_vector ( n, a, v )

c*********************************************************************72
c
cc R8MAT_DIAG_SET_VECTOR sets the diagonal of an R8MAT to a vector.
c
c  Discussion:
c
c    An R8MAT is an array of R8 values.
c
c  Licensing:
c
c    This code is distributed under the GNU LGPL license.
c
c  Modified:
c
c    08 May 2010
c
c  Author:
c
c    John Burkardt
c
c  Parameters:
c
c    Input, integer N, the number of rows and columns.
c
c    Input/output, double precision A(N,N), the N by N matrix.
c
c    Input, double precision V(N), the vector to be assigned to the
c    diagonal of A.
c
      implicit none

      integer n

      double precision a(n,n)
      integer i
      double precision v(n)

      do i = 1, n
        a(i,i) = v(i)
      end do

      return
      end
      function r8mat_dif_fro ( m, n, a, b )

c*********************************************************************72
c
cc R8MAT_DIF_FRO returns the Frobenius norm of the difference of two R8MAT's.
c
c  Discussion:
c
c    An R8MAT is a matrix of double precision values.
c
c    The Frobenius norm is defined as
c
c      R8MAT_DIF_FRO = sqrt (
c        sum ( 1 <= I <= M ) sum ( 1 <= j <= N ) ( A(I,J) - B(I,J) )^2 )
c
c  Licensing:
c
c    This code is distributed under the GNU LGPL license.
c
c  Modified:
c
c    19 June 2012
c
c  Author:
c
c    John Burkardt
c
c  Parameters:
c
c    Input, integer M, the number of rows in A and B.
c
c    Input, integer N, the number of columns in A and B.
c
c    Input, double precision A(M,N), B(M,N), the matrices
c    for which we want the Frobenius norm of the difference.
c
c    Output, double precision R8MAT_DIF_FRO, the Frobenius norm of
c    the difference of A and B.
c
      implicit none

      integer m
      integer n

      double precision a(m,n)
      double precision b(m,n)
      integer i
      integer j
      double precision r8mat_dif_fro
      double precision value

      value = 0.0D+00
      do j = 1, n
        do i = 1, m
          value = value + ( a(i,j) - b(i,j) )**2
        end do
      end do

      value = sqrt ( value )

      r8mat_dif_fro = value

      return
      end
      subroutine r8mat_expand_linear ( m, n, x, mfat, nfat, xfat )

c*********************************************************************72
c
cc R8MAT_EXPAND_LINEAR linearly interpolates new data into an R8MAT.
c
c  Discussion:
c
c    An R8MAT is an array of R8 values.
c
c    In this routine, the expansion is specified by giving the number
c    of intermediate values to generate between each pair of original
c    data rows and columns.
c
c    The interpolation is not actually linear.  It uses the functions
c
c      1, x, y, and xy.
c
c  Licensing:
c
c    This code is distributed under the GNU LGPL license.
c
c  Modified:
c
c    11 October 2010
c
c  Author:
c
c    John Burkardt
c
c  Parameters:
c
c    Input, integer M, N, the number of rows and columns of
c    input data.
c
c    Input, double precision X(M,N), the original data.
c
c    Input, integer MFAT, NFAT, the number of data values
c    to interpolate between each row, and each column, of original data values.
c
c    Output, double precision XFAT(M2,N2), the fattened data, where
c    M2 = (M-1)*(MFAT+1)+1,
c    N2 = (N-1)*(NFAT+1)+1.
c
      implicit none

      integer m
      integer mfat
      integer n
      integer nfat

      integer i
      integer ihi
      integer ii
      integer iii
      integer ip1
      integer j
      integer jhi
      integer jj
      integer jjj
      integer jp1
      double precision s
      double precision t
      double precision x(m,n)
      double precision x00
      double precision x01
      double precision x10
      double precision x11
      double precision xfat((m-1)*(mfat+1)+1,(n-1)*(nfat+1)+1)

      do i = 1, m

        if ( i .lt. m ) then
          ihi = mfat
        else
          ihi = 0
        end if

        do j = 1, n

          if ( j .lt. n ) then
            jhi = nfat
          else
            jhi = 0
          end if

          if ( i .lt. m ) then
            ip1 = i + 1
          else
            ip1 = i
          end if

          if ( j .lt. n ) then
            jp1 = j + 1
          else
            jp1 = j
          end if

          x00 = x(i,j)
          x10 = x(ip1,j)
          x01 = x(i,jp1)
          x11 = x(ip1,jp1)

          do ii = 0, ihi

            s = dble ( ii ) / dble ( ihi + 1 )

            do jj = 0, jhi

              t = dble ( jj ) / dble ( jhi + 1 )

              iii = 1 + ( i - 1 ) * ( mfat + 1 ) + ii
              jjj = 1 + ( j - 1 ) * ( nfat + 1 ) + jj

              xfat(iii,jjj) =
     &                                          x00
     &            + s     * (       x10       - x00 )
     &            + t     * (             x01 - x00 )
     &            + s * t * ( x11 - x10 - x01 + x00 )

            end do

          end do

        end do

      end do

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

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

      integer m
      integer m2
      integer n
      integer n2

      double precision a(m,n)
      double precision a2(m2,n2)
      integer i
      integer i1
      integer i2
      integer j
      integer j1
      integer j2
      double precision r
      double precision r1
      double precision r2
      double precision s
      double precision s1
      double precision s2

      do i = 1, m2

        if ( m2 .eq. 1 ) then
          r = 0.5D+00
        else
          r = dble ( i - 1 ) / dble ( m2 - 1 )
        end if

        i1 = 1 + int ( r * dble ( m - 1 ) )
        i2 = i1 + 1

        if ( m .lt. i2 ) then
          i1 = m - 1
          i2 = m
        end if

        r1 = dble ( i1 - 1 ) / dble ( m - 1 )

        r2 = dble ( i2 - 1 ) / dble ( m - 1 )

        do j = 1, n2

          if ( n2 .eq. 1 ) then
            s = 0.5D+00
          else
            s = dble ( j - 1 ) / dble ( n2 - 1 )
          end if

          j1 = 1 + int ( s * dble ( n - 1 ) )
          j2 = j1 + 1

          if ( n .lt. j2 ) then
            j1 = n - 1
            j2 = n
          end if

          s1 = dble ( j1 - 1 ) / dble ( n - 1 )

          s2 = dble ( j2 - 1 ) / dble ( n - 1 )

          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
      subroutine r8mat_flip_cols ( m, n, a )

c*********************************************************************72
c
cc R8MAT_FLIP_COLS swaps the columns of an R8MAT.
c
c  Discussion:
c
c    An R8MAT is an MxN array of R8's, stored by (I,J) -> [I+J*M].
c
c    To "flip" the columns of an R8MAT is to start with something like
c
c      11 12 13 14 15
c      21 22 23 24 25
c      31 32 33 34 35
c      41 42 43 44 45
c      51 52 53 54 55
c
c    and return
c
c      15 14 13 12 11
c      25 24 23 22 21
c      35 34 33 32 31
c      45 44 43 42 41
c      55 54 53 52 51
c
c  Licensing:
c
c    This code is distributed under the GNU LGPL license.
c
c  Modified:
c
c    02 December 2011
c
c  Author:
c
c    John Burkardt
c
c  Parameters:
c
c    Input, integer M, N, the number of rows and columns.
c
c    Input/output, double precision A(M,N), the matrix.
c
      implicit none

      integer m
      integer n

      double precision a(m,n)
      integer i
      integer j
      integer jhi
      double precision t

      jhi = n / 2

      do j = 1, jhi
        do i = 1, m
          t          = a(i,j)
          a(i,j)     = a(i,n+1-j)
          a(i,n+1-j) = t
        end do
      end do

      return
      end
      subroutine r8mat_flip_rows ( m, n, a )

c********************************************************************72
c
cc R8MAT_FLIP_ROWS swaps the rows of an R8MAT.
c
c  Discussion:
c
c    An R8MAT is an MxN array of R8's, stored by (I,J) -> [I+J*M].
c
c    To "flip" the rows of an R8MAT is to start with something like
c
c      11 12 13 14 15
c      21 22 23 24 25
c      31 32 33 34 35
c      41 42 43 44 45
c      51 52 53 54 55
c
c    and return
c
c      51 52 53 54 55
c      41 42 43 44 45
c      31 32 33 34 35
c      21 22 23 24 25
c      11 12 13 14 15
c
c  Licensing:
c
c    This code is distributed under the GNU LGPL license.
c
c  Modified:
c
c    02 December 2011
c
c  Author:
c
c    John Burkardt
c
c  Parameters:
c
c    Input, integer M, N, the number of rows and columns.
c
c    Input/output, double precision A(M,N), the matrix.
c
      implicit none

      integer m
      integer n

      double precision a(m,n)
      integer i
      integer ihi
      integer j
      double precision t

      ihi = m / 2

      do i = 1, ihi
        do j = 1, n
          t          = a(i,j)
          a(i,j)     = a(m+1-i,j)
          a(m+1-i,j) = t
        end do
      end do

      return
      end
      subroutine r8mat_fss ( n, a, nb, b, info )

c*********************************************************************72
c
cc R8MAT_FSS factors and solves a system with multiple right hand sides.
c
c  Discussion:
c
c    An R8MAT is an MxN array of R8's, stored by (I,J) -> [I+J*M].
c
c    This routine does not save the LU factors of the matrix, and hence cannot
c    be used to efficiently solve multiple linear systems, or even to
c    factor A at one time, and solve a single linear system at a later time.
c
c    This routine uses partial pivoting, but no pivot vector is required.
c
c  Licensing:
c
c    This code is distributed under the GNU LGPL license. 
c
c  Modified:
c
c    28 November 2011
c
c  Author:
c
c    John Burkardt
c
c  Parameters:
c
c    Input, integer N, the order of the matrix.
c    N must be positive.
c
c    Input/output, double precision A(N,N).
c    On input, A is the coefficient matrix of the linear system.
c    On output, A is in unit upper triangular form, and
c    represents the U factor of an LU factorization of the
c    original coefficient matrix.
c
c    Input, integer NB, the number of right hand sides.
c
c    Input/output, double precision B(N,NB).
c    On input, B is the right hand side of the linear system.
c    On output, B is the solution of the linear system.
c
c    Output, integer INFO, singularity flag.
c    0, no singularity detected.
c    nonzero, the factorization failed on the INFO-th step.
c
      implicit none

      integer n
      integer nb

      double precision a(n,n)
      double precision b(n,nb)
      integer i
      integer info
      integer ipiv
      integer j
      integer jcol
      integer k
      double precision piv
      double precision temp

      info = 0

      do jcol = 1, n
c
c  Find the maximum element in column I.
c
        piv = abs ( a(jcol,jcol) )
        ipiv = jcol
        do i = jcol + 1, n
          if ( piv .lt. abs ( a(i,jcol) ) ) then
            piv = abs ( a(i,jcol) )
            ipiv = i
          end if
        end do

        if ( piv .eq. 0.0D+00 ) then
          info = jcol
          write ( *, '(a)' ) ' '
          write ( *, '(a)' ) 'R8MAT_FSS - Fatal error!'
          write ( *, '(a,i8)' ) '  Zero pivot on step ', info
          return
        end if
c
c  Switch rows JCOL and IPIV, and B.
c
        if ( jcol .ne. ipiv ) then

          do j = 1, n
            temp = a(jcol,j)
            a(jcol,j) = a(ipiv,j)
            a(ipiv,j) = temp
          end do

          do j = 1, nb
            temp = b(jcol,j)
            b(jcol,j) = b(ipiv,j)
            b(ipiv,j) = temp
          end do

        end if
c
c  Scale the pivot row.
c
        do j = jcol + 1, n
          a(jcol,j) = a(jcol,j) / a(jcol,jcol)
        end do
        do j = 1, nb
          b(jcol,j) = b(jcol,j) / a(jcol,jcol)
        end do
        a(jcol,jcol) = 1.0D+00
c
c  Use the pivot row to eliminate lower entries in that column.
c
        do i = jcol + 1, n
          if ( a(i,jcol) .ne. 0.0D+00 ) then
            temp = - a(i,jcol)
            a(i,jcol) = 0.0D+00
            do j = jcol + 1, n
              a(i,j) = a(i,j) + temp * a(jcol,j)
            end do
            do j = 1, nb
              b(i,j) = b(i,j) + temp * b(jcol,j)
            end do
          end if
        end do

      end do
c
c  Back solve.
c
      do k = n, 2, -1
        do i = 1, k - 1
          do j = 1, nb
            b(i,j) = b(i,j) - a(i,k) * b(k,j)
          end do
        end do
      end do

      return
      end
      subroutine r8mat_givens_post ( n, a, row, col, g )

c*********************************************************************72
c
cc R8MAT_GIVENS_POST computes the Givens postmultiplier rotation matrix.
c
c  Discussion:
c
c    An R8MAT is an array of R8 values.
c
c    The Givens post-multiplier matrix G(ROW,COL) has the property that
c    the (ROW,COL)-th entry of A*G is zero.
c
c  Licensing:
c
c    This code is distributed under the GNU LGPL license.
c
c  Modified:
c
c    09 May 2010
c
c  Author:
c
c    John Burkardt
c
c  Parameters:
c
c    Input, integer N, the order of the matrices A and G.
c
c    Input, double precision A(N,N), the matrix to be operated upon.
c
c    Input, integer ROW, COL, the row and column of the
c    entry of A*G which is to be zeroed out.
c
c    Output, double precision G(N,N), the Givens rotation matrix.
c    G is an orthogonal matrix, that is, the inverse of
c    G is the transpose of G.
c
      implicit none

      integer n

      double precision a(n,n)
      integer col
      double precision g(n,n)
      integer row
      double precision theta

      call r8mat_identity ( n, g )

      theta = atan2 ( a(row,col), a(row,row) )

      g(row,row) =  cos ( theta )
      g(row,col) = -sin ( theta )
      g(col,row) =  sin ( theta )
      g(col,col) =  cos ( theta )

      return
      end
      subroutine r8mat_givens_pre ( n, a, row, col, g )

c*********************************************************************72
c
cc R8MAT_GIVENS_PRE computes the Givens premultiplier rotation matrix.
c
c  Discussion:
c
c    An R8MAT is an array of R8 values.
c
c    The Givens premultiplier rotation matrix G(ROW,COL) has the
c    property that the (ROW,COL)-th entry of G*A is zero.
c
c  Licensing:
c
c    This code is distributed under the GNU LGPL license.
c
c  Modified:
c
c    09 May 2010
c
c  Author:
c
c    John Burkardt
c
c  Parameters:
c
c    Input, integer N, the order of the matrices A and G.
c
c    Input, double precision A(N,N), the matrix to be operated upon.
c
c    Input, integer ROW, COL, the row and column of the
c    entry of the G*A which is to be zeroed out.
c
c    Output, double precision G(N,N), the Givens rotation matrix.
c    G is an orthogonal matrix, that is, the inverse of
c    G is the transpose of G.
c
      implicit none

      integer n

      double precision a(n,n)
      integer col
      double precision g(n,n)
      integer row
      double precision theta

      call r8mat_identity ( n, g )

      theta = atan2 ( a(row,col), a(col,col) )

      g(row,row) =  cos ( theta )
      g(row,col) = -sin ( theta )
      g(col,row) =  sin ( theta )
      g(col,col) =  cos ( theta )

      return
      end
      subroutine r8mat_house_axh ( n, a, v, ah )

c*********************************************************************72
c
cc R8MAT_HOUSE_AXH computes A*H where H is a compact Householder matrix.
c
c  Discussion:
c
c    An R8MAT is an array of R8's.
c
c    The Householder matrix H(V) is defined by
c
c      H(V) = I - 2 * v * v' / ( v' * v )
c
c    This routine is not particularly efficient.
c
c  Licensing:
c
c    This code is distributed under the GNU LGPL license.
c
c  Modified:
c
c    05 February 2008
c
c  Author:
c
c    John Burkardt
c
c  Parameters:
c
c    Input, integer N, the order of A.
c
c    Input, double precision A(N,N), the matrix.
c
c    Input, double precision V(N), a vector defining a Householder matrix.
c
c    Output, double precision AH(N,N), the product A*H.
c
      implicit none

      integer n

      double precision a(n,n)
      double precision ah(n,n)
      double precision av(n)
      integer i
      integer j
      double precision v(n)
      double precision v_normsq

      v_normsq = 0.0D+00
      do i = 1, n
        v_normsq = v_normsq + v(i)**2
      end do

      do i = 1, n
        av(i) = 0.0D+00
        do j = 1, n
          av(i) = av(i) + a(i,j) * v(j)
        end do
      end do

      do i = 1, n
        do j = 1, n
          ah(i,j) = a(i,j)
        end do
      end do

      do i = 1, n
        do j = 1, n
          ah(i,j) = ah(i,j) - 2.0D+00 * av(i) * v(j)
        end do
      end do

      do i = 1, n
        do j = 1, n
          ah(i,j) = ah(i,j) / v_normsq
        end do
      end do

      return
      end
      subroutine r8mat_house_form ( n, v, h )

c*********************************************************************72
c
cc R8MAT_HOUSE_FORM constructs a Householder matrix from its compact form.
c
c  Discussion:
c
c    An R8MAT is an array of R8 values.
c
c    H(v) = I - 2 * v * v' / ( v' * v )
c
c  Licensing:
c
c    This code is distributed under the GNU LGPL license.
c
c  Modified:
c
c    09 May 2010
c
c  Author:
c
c    John Burkardt
c
c  Parameters:
c
c    Input, integer N, the order of the matrix.
c
c    Input, double precision V(N), the vector defining the Householder matrix.
c
c    Output, double precision H(N,N), the Householder matrix.
c
      implicit none

      integer n

      double precision beta
      double precision h(n,n)
      integer i
      integer j
      double precision v(n)
c
c  Compute the L2 norm of V.
c
      beta = 0.0D+00
      do i = 1, n
        beta = beta + v(i)**2
      end do
c
c  Form the matrix H.
c
      call r8mat_identity ( n, h )

      do i = 1, n
        do j = 1, n
          h(i,j) = h(i,j) - 2.0D+00 * v(i) * v(j) / beta
        end do
      end do

      return
      end
      subroutine r8mat_house_hxa ( n, a, v, ha )

c*********************************************************************72
c
cc R8MAT_HOUSE_HXA computes H*A where H is a compact Householder matrix.
c
c  Discussion:
c
c    An R8MAT is an array of R8 values.
c
c    The Householder matrix H(V) is defined by
c
c      H(V) = I - 2 * v * v' / ( v' * v )
c
c    This routine is not particularly efficient.
c
c  Licensing:
c
c    This code is distributed under the GNU LGPL license.
c
c  Modified:
c
c    09 May 2010
c
c  Author:
c
c    John Burkardt
c
c  Parameters:
c
c    Input, integer N, the order of A.
c
c    Input, double precision A(N,N), the matrix to be premultiplied.
c
c    Input, double precision V(N), a vector defining a Householder matrix.
c
c    Output, double precision HA(N,N), the product H*A.
c
      implicit none

      integer n

      double precision a(n,n)
      double precision ha(n,n)
      double precision ha_temp(n,n)
      integer i
      integer j
      integer k
      double precision v(n)
      double precision v_normsq

      v_normsq = 0.0D+00
      do i = 1, n
        v_normsq = v_normsq + v(i)**2
      end do
c
c  Compute A*H' = A*H
c
      do i = 1, n
        do j = 1, n
          ha_temp(i,j) = a(i,j)
          do k = 1, n
            ha_temp(i,j) = ha_temp(i,j)
     &        - 2.0D+00 * v(i) * v(k) * a(k,j) / v_normsq
          end do
        end do
      end do
c
c  Copy the temporary result into HA.
c  Doing it this way means the user can identify the input arguments A and HA.
c
      do j = 1, n
        do i = 1, n
          ha(i,j) = ha_temp(i,j)
        end do
      end do

      return
      end
      subroutine r8mat_house_post ( n, a, row, col, h )

c*********************************************************************72
c
cc R8MAT_HOUSE_POST computes a Householder post-multiplier matrix.
c
c  Discussion:
c
c    An R8MAT is an array of R8 values.
c
c    H(ROW,COL) has the property that the ROW-th column of
c    A*H(ROW,COL) is zero from entry COL+1 to the end.
c
c    In the most common case, where a QR factorization is being computed,
c    ROW = COL.
c
c  Licensing:
c
c    This code is distributed under the GNU LGPL license.
c
c  Modified:
c
c    09 May 2010
c
c  Author:
c
c    John Burkardt
c
c  Parameters:
c
c    Input, integer N, the order of the matrices.
c
c    Input, double precision A(N,N), the matrix whose Householder matrix
c    is to be computed.
c
c    Input, integer ROW, COL, specify the location of the
c    entry of the matrix A which is to be preserved.  The entries in
c    the same row, but higher column, will be zeroed out if
c    A is postmultiplied by H.
c
c    Output, double precision H(N,N), the Householder matrix.
c
      implicit none

      integer n

      double precision a(n,n)
      integer col
      double precision h(n,n)
      integer j
      integer row
      double precision v(n)
      double precision w(n)
c
c  Set up the vector V.
c
      do j = 1, col - 1
        w(j) = 0.0D+00
      end do
      do j = col, n
        w(j) = a(row,j)
      end do

      call r8vec_house_column ( n, w, col, v )
c
c  Form the matrix H(V).
c
      call r8mat_house_form ( n, v, h )

      return
      end
      subroutine r8mat_house_pre ( n, a, row, col, h )

c*********************************************************************72
c
cc R8MAT_HOUSE_PRE computes a Householder pre-multiplier matrix.
c
c  Discussion:
c
c    An R8MAT is an array of R8 values.
c
c    H(ROW,COL) has the property that the COL-th column of
c    H(ROW,COL)*A is zero from entry ROW+1 to the end.
c
c    In the most common case, where a QR factorization is being computed,
c    ROW = COL.
c
c  Licensing:
c
c    This code is distributed under the GNU LGPL license.
c
c  Modified:
c
c    09 May 2010
c
c  Author:
c
c    John Burkardt
c
c  Parameters:
c
c    Input, integer N, the order of the matrices.
c
c    Input, double precision A(N,N), the matrix whose Householder matrix
c    is to be computed.
c
c    Input, integer ROW, COL, specify the location of the
c    entry of the matrix A which is to be preserved.  The entries in
c    the same column, but higher rows, will be zeroed out if A is
c    premultiplied by H.
c
c    Output, double precision H(N,N), the Householder matrix.
c
      implicit none

      integer n

      double precision a(n,n)
      integer col
      double precision h(n,n)
      integer i
      integer row
      double precision v(n)
      double precision w(n)
c
c  Set up the vector V.
c
      do i = 1, row - 1
        w(i) = 0.0D+00
      end do
      do i = row, n
        w(i) = a(i,col)
      end do

      call r8vec_house_column ( n, w, row, v )
c
c  Form the matrix H(V).
c
      call r8mat_house_form ( n, v, h )

      return
      end
      subroutine r8mat_identity ( n, a )

c*********************************************************************72
c
cc R8MAT_IDENTITY stores the identity matrix in an R8MAT.
c
c  Discussion:
c
c    An R8MAT is an array of R8's.
c
c  Licensing:
c
c    This code is distributed under the GNU LGPL license.
c
c  Modified:
c
c    24 March 2000
c
c  Author:
c
c    John Burkardt
c
c  Parameters:
c
c    Input, integer N, the order of A.
c
c    Output, double precision A(N,N), the N by N identity matrix.
c
      implicit none

      integer n

      double precision a(n,n)
      integer i
      integer j

      do j = 1, n
        do i = 1, n
          a(i,j) = 0.0D+00
        end do
      end do

      do i = 1, n
        a(i,i) = 1.0D+00
      end do

      return
      end
      function r8mat_in_01 ( m, n, a )

c*********************************************************************72
c
cc R8MAT_IN_01 is TRUE if the entries of an R8MAT are in the range [0,1].
c
c  Discussion:
c
c    An R8MAT is an array of R8's.
c
c  Licensing:
c
c    This code is distributed under the GNU LGPL license.
c
c  Modified:
c
c    03 July 2009
c
c  Author:
c
c    John Burkardt
c
c  Parameters:
c
c    Input, integer M, the number of rows in A.
c
c    Input, integer N, the number of columns in A.
c
c    Input, double precision A(M,N), the matrix.
c
c    Output, logical R8MAT_IN_01, is TRUE if every entry of A is
c    between 0 and 1.
c
      implicit none

      integer m
      integer n

      double precision a(m,n)
      integer i
      integer j
      logical r8mat_in_01

      do j = 1, n
        do i = 1, m
          if ( a(i,j) .lt. 0.0D+00 .or. 1.0D+00 .lt. a(i,j) ) then
            r8mat_in_01 = .false.
            return
          end if
        end do
      end do

      r8mat_in_01 = .true.

      return
      end
      subroutine r8mat_indicator ( m, n, table )

c*********************************************************************72
c
cc R8MAT_INDICATOR sets up an "indicator" R8MAT.
c
c  Discussion:
c
c    An R8MAT is an array of R8's.
c
c    The value of each entry suggests its location, as in:
c
c      11  12  13  14
c      21  22  23  24
c      31  32  33  34
c
c  Licensing:
c
c    This code is distributed under the GNU LGPL license.
c
c  Modified:
c
c    28 May 2008
c
c  Author:
c
c    John Burkardt
c
c  Parameters:
c
c    Input, integer M, the number of rows of the matrix.
c    M must be positive.
c
c    Input, integer N, the number of columns of the matrix.
c    N must be positive.
c
c    Output, double precision TABLE(M,N), the table.
c
      implicit none

      integer m
      integer n

      integer fac
      integer i
      integer i4_log_10
      integer j
      double precision table(m,n)

      fac = 10 ** ( i4_log_10 ( n ) + 1 )

      do i = 1, m
        do j = 1, n
          table(i,j) = dble ( fac * i + j )
        end do
      end do

      return
      end
      function r8mat_insignificant ( m, n, r, s )

c*********************************************************************72
c
cc R8MAT_INSIGNIFICANT determines if an R8MAT is insignificant.
c
c  Licensing:
c
c    This code is distributed under the GNU LGPL license.
c
c  Modified:
c
c    26 November 2011
c
c  Author:
c
c    John Burkardt
c
c  Parameters:
c
c    Input, integer M, N, the dimension of the matrices.
c
c    Input, double precision R(M,N), the vector to be compared against.
c
c    Input, double precision S(M,N), the vector to be compared.
c
c    Output, logical R8MAT_INSIGNIFICANT, is TRUE if S is insignificant
c    compared to R.
c
      implicit none

      integer m
      integer n

      integer i
      integer j
      double precision r(m,n)
      double precision r8_epsilon
      logical r8mat_insignificant
      double precision s(m,n)
      double precision t
      double precision tol
      logical value

      value = .true.

      do j = 1, n
        do i = 1, m

          t = r(i,j) + s(i,j)
          tol = r8_epsilon ( ) * abs ( r(i,j) )

          if ( tol .lt. abs ( r(i,j) - t ) ) then 
            value = .false.
            go to 10
          end if

        end do
      end do
  
10    continue

      r8mat_insignificant = value

      return
      end
      subroutine r8mat_inverse_2d ( a, b, det )

c*********************************************************************72
c
cc R8MAT_INVERSE_2D inverts a 2 by 2 R8MAT using Cramer's rule.
c
c  Discussion:
c
c    An R8MAT is an array of R8's.
c
c    If the determinant is zero, then A is singular, and does not have an
c    inverse.  In that case, B is simply set to zero, and a
c    message is printed.
c
c    If the determinant is nonzero, then its value is roughly an estimate
c    of how nonsingular the matrix A is.
c
c  Licensing:
c
c    This code is distributed under the GNU LGPL license.
c
c  Modified:
c
c    31 August 2008
c
c  Author:
c
c    John Burkardt
c
c  Parameters:
c
c    Input, double precision A(2,2), the matrix to be inverted.
c
c    Output, double precision B(2,2), the inverse of the matrix A.
c
c    Output, double precision DET, the determinant of the matrix A.
c
      implicit none

      double precision a(2,2)
      double precision b(2,2)
      double precision det
      double precision r8mat_det_2d
c
c  Compute the determinant of A.
c
      det = r8mat_det_2d ( a )

      if ( det .eq. 0.0D+00 ) then

        b(1,1) = 0.0D+00
        b(1,2) = 0.0D+00
        b(2,1) = 0.0D+00
        b(2,2) = 0.0D+00

      else

        b(1,1) =  a(2,2) / det
        b(1,2) = -a(1,2) / det
        b(2,1) = -a(2,1) / det
        b(2,2) =  a(1,1) / det

      end if

      return
      end
      subroutine r8mat_inverse_3d ( a, b, det )

c*********************************************************************72
c
cc R8MAT_INVERSE_3D inverts a 3 by 3 R8MAT using Cramer's rule.
c
c  Discussion:
c
c    An R8MAT is an array of R8's.
c
c    If the determinant is zero, then A is singular, and does not have an
c    inverse.  In that case, B is simply set to zero, and a
c    message is printed.
c
c    If the determinant is nonzero, then its value is roughly an estimate
c    of how nonsingular the matrix A is.
c
c  Licensing:
c
c    This code is distributed under the GNU LGPL license.
c
c  Modified:
c
c    03 July 2009
c
c  Author:
c
c    John Burkardt
c
c  Parameters:
c
c    Input, double precision A(3,3), the matrix to be inverted.
c
c    Output, double precision B(3,3), the inverse of the matrix A.
c
c    Output, double precision DET, the determinant of the matrix A.
c
      implicit none

      double precision a(3,3)
      double precision b(3,3)
      double precision det
      double precision r8mat_det_3d
c
c  Compute the determinant of A.
c
      det = r8mat_det_3d ( a )
c
c  If the determinant is zero, bail out.
c
      if ( det .eq. 0.0D+00 ) then
        call r8mat_zero ( 3, 3, b )
        return
      end if
c
c  Compute the entries of the inverse matrix using an explicit
c  formula.
c
      b(1,1) =  ( a(2,2) * a(3,3) - a(2,3) * a(3,2) ) / det
      b(1,2) = -( a(1,2) * a(3,3) - a(1,3) * a(3,2) ) / det
      b(1,3) =  ( a(1,2) * a(2,3) - a(1,3) * a(2,2) ) / det

      b(2,1) = -( a(2,1) * a(3,3) - a(2,3) * a(3,1) ) / det
      b(2,2) =  ( a(1,1) * a(3,3) - a(1,3) * a(3,1) ) / det
      b(2,3) = -( a(1,1) * a(2,3) - a(1,3) * a(2,1) ) / det

      b(3,1) =  ( a(2,1) * a(3,2) - a(2,2) * a(3,1) ) / det
      b(3,2) = -( a(1,1) * a(3,2) - a(1,2) * a(3,1) ) / det
      b(3,3) =  ( a(1,1) * a(2,2) - a(1,2) * a(2,1) ) / det

      return
      end
      subroutine r8mat_inverse_4d ( a, b, det )

c*********************************************************************72
c
cc R8MAT_INVERSE_4D inverts a 4 by 4 R8MAT using Cramer's rule.
c
c  Discussion:
c
c    An R8MAT is an array of R8 values.
c
c    If the determinant is zero, then A is singular, and does not have an
c    inverse.  In that case, B is simply set to zero, and a
c    message is printed.
c
c    If the determinant is nonzero, then its value is roughly an estimate
c    of how nonsingular the matrix A is.
c
c  Licensing:
c
c    This code is distributed under the GNU LGPL license.
c
c  Modified:
c
c    13 September 2011
c
c  Author:
c
c    John Burkardt
c
c  Parameters:
c
c    Input, double precision A(4,4), the matrix to be inverted.
c
c    Output, double precision B(4,4), the inverse of the matrix A.
c
c    Output, double precision DET, the determinant of the matrix A.
c
      implicit none

      double precision a(4,4)
      double precision b(4,4)
      double precision det
      integer i
      integer j
      double precision r8mat_det_4d
c
c  Compute the determinant of A.
c
      det = r8mat_det_4d ( a )
c
c  If the determinant is zero, bail out.
c
      if ( det .eq. 0.0D+00 ) then

        do j = 1, 4
          do i = 1, 4
            b(1:4,1:4) = 0.0D+00
          end do
        end do

        return
      end if
c
c  Compute the entries of the inverse matrix using an explicit formula.
c
      b(1,1) = +( 
     &      + a(2,2) * ( a(3,3) * a(4,4) - a(3,4) * a(4,3) ) 
     &      + a(2,3) * ( a(3,4) * a(4,2) - a(3,2) * a(4,4) ) 
     &      + a(2,4) * ( a(3,2) * a(4,3) - a(3,3) * a(4,2) ) 
     &      ) / det

      b(2,1) = -( 
     &      + a(2,1) * ( a(3,3) * a(4,4) - a(3,4) * a(4,3) ) 
     &      + a(2,3) * ( a(3,4) * a(4,1) - a(3,1) * a(4,4) ) 
     &      + a(2,4) * ( a(3,1) * a(4,3) - a(3,3) * a(4,1) ) 
     &      ) / det

      b(3,1) = +( 
     &      + a(2,1) * ( a(3,2) * a(4,4) - a(3,4) * a(4,2) ) 
     &      + a(2,2) * ( a(3,4) * a(4,1) - a(3,1) * a(4,4) ) 
     &      + a(2,4) * ( a(3,1) * a(4,2) - a(3,2) * a(4,1) ) 
     &      ) / det

      b(4,1) = -( 
     &      + a(2,1) * ( a(3,2) * a(4,3) - a(3,3) * a(4,2) ) 
     &      + a(2,2) * ( a(3,3) * a(4,1) - a(3,1) * a(4,3) ) 
     &      + a(2,3) * ( a(3,1) * a(4,2) - a(3,2) * a(4,1) ) 
     &      ) / det

      b(1,2) = -( 
     &      + a(1,2) * ( a(3,3) * a(4,4) - a(3,4) * a(4,3) ) 
     &      + a(1,3) * ( a(3,4) * a(4,2) - a(3,2) * a(4,4) ) 
     &      + a(1,4) * ( a(3,2) * a(4,3) - a(3,3) * a(4,2) ) 
     &      ) / det

      b(2,2) = +( 
     &      + a(1,1) * ( a(3,3) * a(4,4) - a(3,4) * a(4,3) ) 
     &      + a(1,3) * ( a(3,4) * a(4,1) - a(3,1) * a(4,4) ) 
     &      + a(1,4) * ( a(3,1) * a(4,3) - a(3,3) * a(4,1) ) 
     &      ) / det

      b(3,2) = -( 
     &      + a(1,1) * ( a(3,2) * a(4,4) - a(3,4) * a(4,2) ) 
     &      + a(1,2) * ( a(3,4) * a(4,1) - a(3,1) * a(4,4) ) 
     &      + a(1,4) * ( a(3,1) * a(4,2) - a(3,2) * a(4,1) ) 
     &      ) / det

      b(4,2) = +( 
     &      + a(1,1) * ( a(3,2) * a(4,3) - a(3,3) * a(4,2) ) 
     &      + a(1,2) * ( a(3,3) * a(4,1) - a(3,1) * a(4,3) ) 
     &      + a(1,3) * ( a(3,1) * a(4,2) - a(3,2) * a(4,1) ) 
     &      ) / det

      b(1,3) = +( 
     &      + a(1,2) * ( a(2,3) * a(4,4) - a(2,4) * a(4,3) ) 
     &      + a(1,3) * ( a(2,4) * a(4,2) - a(2,2) * a(4,4) ) 
     &      + a(1,4) * ( a(2,2) * a(4,3) - a(2,3) * a(4,2) ) 
     &      ) / det

      b(2,3) = -( 
     &      + a(1,1) * ( a(2,3) * a(4,4) - a(2,4) * a(4,3) ) 
     &      + a(1,3) * ( a(2,4) * a(4,1) - a(2,1) * a(4,4) ) 
     &      + a(1,4) * ( a(2,1) * a(4,3) - a(2,3) * a(4,1) ) 
     &      ) / det

      b(3,3) = +( 
     &      + a(1,1) * ( a(2,2) * a(4,4) - a(2,4) * a(4,2) ) 
     &      + a(1,2) * ( a(2,4) * a(4,1) - a(2,1) * a(4,4) ) 
     &      + a(1,4) * ( a(2,1) * a(4,2) - a(2,2) * a(4,1) ) 
     &      ) / det

      b(4,3) = -( 
     &      + a(1,1) * ( a(2,2) * a(4,3) - a(2,3) * a(4,2) ) 
     &      + a(1,2) * ( a(2,3) * a(4,1) - a(2,1) * a(4,3) ) 
     &      + a(1,3) * ( a(2,1) * a(4,2) - a(2,2) * a(4,1) ) 
     &      ) / det

      b(1,4) = -( 
     &      + a(1,2) * ( a(2,3) * a(3,4) - a(2,4) * a(3,3) ) 
     &      + a(1,3) * ( a(2,4) * a(3,2) - a(2,2) * a(3,4) ) 
     &      + a(1,4) * ( a(2,2) * a(3,3) - a(2,3) * a(3,2) ) 
     &      ) / det

      b(2,4) = +( 
     &      + a(1,1) * ( a(2,3) * a(3,4) - a(2,4) * a(3,3) ) 
     &      + a(1,3) * ( a(2,4) * a(3,1) - a(2,1) * a(3,4) ) 
     &      + a(1,4) * ( a(2,1) * a(3,3) - a(2,3) * a(3,1) ) 
     &      ) / det

      b(3,4) = -( 
     &      + a(1,1) * ( a(2,2) * a(3,4) - a(2,4) * a(3,2) ) 
     &      + a(1,2) * ( a(2,4) * a(3,1) - a(2,1) * a(3,4) ) 
     &      + a(1,4) * ( a(2,1) * a(3,2) - a(2,2) * a(3,1) ) 
     &      ) / det

      b(4,4) = +( 
     &      + a(1,1) * ( a(2,2) * a(3,3) - a(2,3) * a(3,2) ) 
     &      + a(1,2) * ( a(2,3) * a(3,1) - a(2,1) * a(3,3) ) 
     &      + a(1,3) * ( a(2,1) * a(3,2) - a(2,2) * a(3,1) ) 
     &      ) / det

      return
      end
      subroutine r8mat_is_identity ( n, a, error_frobenius )

c*********************************************************************72
c
cc R8MAT_IS_IDENTITY determines if an R8MAT is the identity.
c
c  Discussion:
c
c    An R8MAT is a matrix of double precision values.
c
c    The routine returns the Frobenius norm of A - I.
c
c  Licensing:
c
c    This code is distributed under the GNU LGPL license.
c
c  Modified:
c
c    10 February 2012
c
c  Author:
c
c    John Burkardt
c
c  Parameters:
c
c    Input, integer N, the order of the matrix.
c
c    Input, double precision A(N,N), the matrix.
c
c    Output, double precision ERROR_FROBENIUS, the Frobenius norm
c    of the difference matrix A - I, which would be exactly zero
c    if A were the identity matrix.
c
      implicit none

      integer n

      double precision a(n,n)
      double precision error_frobenius
      integer i
      integer j
      double precision value

      error_frobenius = 0.0D+00

      do i = 1, n
        do j = 1, n
          if ( i .eq. j ) then
            error_frobenius = error_frobenius + ( a(i,j) - 1.0D+00 )**2
          else
            error_frobenius = error_frobenius + a(i,j)**2
          end if
        end do 
      end do

      error_frobenius = sqrt ( error_frobenius )

      return
      end
      subroutine r8mat_is_symmetric ( m, n, a, error_frobenius )

c*********************************************************************72
c
cc R8MAT_IS_SYMMETRIC checks an R8MAT for symmetry.
c
c  Discussion:
c
c    An R8MAT is a matrix of real ( kind = 8 ) values.
c
c  Licensing:
c
c    This code is distributed under the GNU LGPL license.
c
c  Modified:
c
c    19 June 2011
c
c  Author:
c
c    John Burkardt
c
c  Parameters:
c
c    Input, integer M, N, the order of the matrix.
c
c    Input, double precision A(M,N), the matrix.
c
c    Output, double precision ERROR_FROBENIUS, measures the 
c    Frobenius norm of ( A - A' ), which would be zero if the matrix
c    were exactly symmetric.
c
      implicit none

      integer m
      integer n

      double precision a(m,n)
      real    ( kind = 8 ) error_frobenius
      integer i
      integer j
      real    ( kind = 8 ) r8_huge

      if ( m .ne. n ) then
        error_frobenius = r8_huge ( )
        return
      end if

      error_frobenius = 0.0D+00
      do j = 1, n
        do i = 1, m
          error_frobenius = error_frobenius + ( a(i,j) - a(j,i) )**2
        end do
      end do

      error_frobenius = sqrt ( error_frobenius )

      return
      end
      subroutine r8mat_jac ( m, n, eps, fx, x, fprime )

c*********************************************************************72
c
cc R8MAT_JAC estimates a dense jacobian matrix of the function FX.
c
c  Discussion:
c
c    An R8MAT is an MxN array of R8's, stored by (I,J) -> [I+J*M].
c
c    FPRIME(I,J) = d F(I) / d X(J).
c
c    The jacobian is assumed to be dense, and the LINPACK/LAPACK
c    double precision general matrix storage mode ("DGE") is used.
c
c    Forward differences are used, requiring N+1 function evaluations.
c
c    Values of EPS have typically been chosen between
c    sqrt ( EPSMCH ) and sqrt ( sqrt ( EPSMCH ) ) where EPSMCH is the
c    machine tolerance.
c
c    If EPS is too small, then F(X+EPS) will be the same as
c    F(X), and the jacobian will be full of zero entries.
c
c    If EPS is too large, the finite difference estimate will
c    be inaccurate.
c
c  Licensing:
c
c    This code is distributed under the GNU LGPL license.
c
c  Modified:
c
c    11 February 2012
c
c  Author:
c
c    John Burkardt
c
c  Parameters:
c
c    Input, integer M, the number of functions.
c
c    Input, integer N, the number of variables.
c
c    Input, double precision EPS, a tolerance to be used for shifting the
c    X values during the finite differencing.  No single value
c    of EPS will be reliable for all vectors X and functions FX.
c
c    Input, external FX, the name of the user written
c    routine which evaluates the function at a given point X, of the form:
c      subroutine fx ( m, n, x, f )
c      integer m
c      integer n
c      double precision f(m)
c      double precision x(n)
c      f(1:m) = ...
c      return
c      end
c
c    Input, double precision X(N), the point where the jacobian
c    is to be estimated.
c
c    Output, double precision FPRIME(M,N), the M by N estimated jacobian
c    matrix.
c
      implicit none

      integer m
      integer n

      double precision del
      double precision eps
      double precision fprime(m,n)
      external fx
      integer i
      integer j
      double precision x(n)
      double precision xsave
      double precision work1(m)
      double precision work2(m)
c
c  Evaluate the function at the base point, X.
c
      call fx ( m, n, x, work2 )
c
c  Now, one by one, vary each component J of the base point X, and
c  estimate DF(I)/DX(J) = ( F(X+) - F(X) )/ DEL.
c
      do j = 1, n

        xsave = x(j)
        del = eps * ( 1.0D+00 + abs ( x(j) ) )
        x(j) = x(j) + del
        call fx ( m, n, x, work1 )
        x(j) = xsave
        do i = 1, m
          fprime(i,j) = ( work1(i) - work2(i) ) / del
        end do
      end do

      return
      end
      subroutine r8mat_l_inverse ( n, a, b )

c*********************************************************************72
c
cc R8MAT_L_INVERSE inverts a lower triangular R8MAT.
c
c  Discussion:
c
c    An R8MAT is an array of R8 values.
c
c    A lower triangular matrix is a matrix whose only nonzero entries
c    occur on or below the diagonal.
c
c    The inverse of a lower triangular matrix is a lower triangular matrix.
c
c  Licensing:
c
c    This code is distributed under the GNU LGPL license.
c
c  Modified:
c
c    14 May 2010
c
c  Author:
c
c    John Burkardt
c
c  Reference:
c
c    Albert Nijenhuis, Herbert Wilf,
c    Combinatorial Algorithms for Computers and Calculators,
c    Academic Press, 1978,
c    ISBN: 0-12-519260-6,
c    LC: QA164.N54.
c
c  Parameters:
c
c    Input, integer N, number of rows and columns in the matrix.
c
c    Input, double precision A(N,N), the lower triangular matrix.
c
c    Output, double precision B(N,N), the inverse matrix.
c
      implicit none

      integer n

      double precision a(n,n)
      double precision b(n,n)
      integer i
      integer j
      integer k

      do j = 1, n

        do i = 1, n

          if ( i .lt. j ) then
            b(i,j) = 0.0D+00
          else if ( j .eq. i ) then
            b(i,j) = 1.0D+00 / a(i,j)
          else
            b(i,j) = 0.0D+00
            do k = 1, i - 1
              b(i,j) = b(i,j) - a(i,k) * b(k,j)
            end do
            b(i,j) = b(i,j) / a(i,i)
          end if

        end do
      end do

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

c*********************************************************************72
c
cc R8MAT_L_SOLVE solves a lower triangular linear system.
c
c  Discussion:
c
c    An R8MAT is an array of R8's.
c
c  Licensing:
c
c    This code is distributed under the GNU LGPL license.
c
c  Modified:
c
c    07 June 2008
c
c  Author:
c
c    John Burkardt
c
c  Parameters:
c
c    Input, integer N, the number of rows and columns of
c    the matrix A.
c
c    Input, double precision A(N,N), the N by N lower triangular matrix.
c
c    Input, double precision B(N), the right hand side of the linear system.
c
c    Output, double precision X(N), the solution of the linear system.
c
      implicit none

      integer n

      double precision a(n,n)
      double precision b(n)
      double precision dot
      integer i
      integer j
      double precision x(n)
c
c  Solve L * x = b.
c
      do i = 1, n
        dot = 0.0D+00
        do j = 1, i - 1
          dot = dot + a(i,j) * x(j)
        end do
        x(i) = ( b(i) - dot ) / a(i,i)
      end do

      return
      end
      subroutine r8mat_l1_inverse ( n, a, b )

c*********************************************************************72
c
cc R8MAT_L1_INVERSE inverts a unit lower triangular R8MAT.
c
c  Discussion:
c
c    An R8MAT is an MxN array of R8's, stored by (I,J) -> [I+J*M].
c
c    A unit lower triangular matrix is a matrix with only 1's on the main
c    diagonal, and only 0's above the main diagonal.
c
c    The inverse of a unit lower triangular matrix is also
c    a unit lower triangular matrix.
c
c    This routine can invert a matrix in place, that is, with no extra
c    storage.  If the matrix is stored in A, then the call
c
c      call r8mat_l1_inverse ( n, a, a )
c
c    will result in A being overwritten by its inverse.
c
c  Licensing:
c
c    This code is distributed under the GNU LGPL license.
c
c  Modified:
c
c    11 February 2012
c
c  Author:
c
c    John Burkardt
c
c  Reference:
c
c    Albert Nijenhuis, Herbert Wilf,
c    Combinatorial Algorithms for Computers and Calculators,
c    Academic Press, 1978,
c    ISBN: 0-12-519260-6,
c    LC: QA164.N54.
c
c  Parameters:
c
c    Input, integer N, number of rows and columns in the matrix.
c
c    Input, double precision A(N,N), the unit lower triangular matrix.
c
c    Output, double precision B(N,N), the inverse matrix.
c
      implicit none

      integer n

      double precision a(n,n)
      double precision b(n,n)
      double precision dot
      integer i
      integer j
      integer k

      do i = 1, n

        do j = 1, n

          if ( i .lt. j ) then
            b(i,j) = 0.0D+00
          else if ( j .eq. i ) then
            b(i,j) = 1.0D+00
          else
            dot = 0.0D+00
            do k = 1, i - 1
              dot = dot + a(i,k) * b(k,j)
            end do
            b(i,j) = - dot
          end if

        end do
      end do

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

c*********************************************************************72
c
cc R8MAT_LT_SOLVE solves a transposed lower triangular linear system.
c
c  Discussion:
c
c    An R8MAT is an array of R8's.
c
c    Given the lower triangular matrix A, the linear system to be solved is:
c
c      A' * x = b
c
c  Licensing:
c
c    This code is distributed under the GNU LGPL license.
c
c  Modified:
c
c    08 April 2009
c
c  Author:
c
c    John Burkardt
c
c  Parameters:
c
c    Input, integer N, the number of rows and columns of the matrix A.
c
c    Input, double precision A(N,N), the N by N lower triangular matrix.
c
c    Input, double precision B(N), the right hand side of the linear system.
c
c    Output, double precision X(N), the solution of the linear system.
c
      implicit none

      integer n

      double precision a(n,n)
      double precision b(n)
      integer i
      double precision r8vec_dot_product
      double precision x(n)
c
c  Solve L'*x = b.
c
      do i = n, 1, -1
        x(i) = ( b(i) - r8vec_dot_product ( n - i, x(i+1), a(i+1,i) ) )
     &  / a(i,i)
      end do

      return
      end
      function r8mat_max ( m, n, a )

c*********************************************************************72
c
cc R8MAT_MAX returns the maximum entry of an R8MAT.
c
c  Discussion:
c
c    An R8MAT is an array of R8's.
c
c  Licensing:
c
c    This code is distributed under the GNU LGPL license.
c
c  Modified:
c
c    19 May 2008
c
c  Author:
c
c    John Burkardt
c
c  Parameters:
c
c    Input, integer M, the number of rows in A.
c
c    Input, integer N, the number of columns in A.
c
c    Input, double precision A(M,N), the matrix.
c
c    Output, double precision R8MAT_MAX, the maximum entry of A.
c
      implicit none

      integer m
      integer n

      double precision a(m,n)
      integer i
      integer j
      double precision r8mat_max
      double precision value

      value = a(1,1)
      do j = 1, n
        do i = 1, m
          value = max ( value, a(i,j) )
        end do
      end do

      r8mat_max = value

      return
      end
      subroutine r8mat_max_index ( m, n, a, i, j )

c*********************************************************************72
c
cc R8MAT_MAX_INDEX returns the location of the maximum entry of an R8MAT.
c
c  Discussion:
c
c    An R8MAT is an array of R8 values.
c
c  Licensing:
c
c    This code is distributed under the GNU LGPL license.
c
c  Modified:
c
c    28 November 2011
c
c  Author:
c
c    John Burkardt
c
c  Parameters:
c
c    Input, integer M, the number of rows in A.
c
c    Input, integer N, the number of columns in A.
c
c    Input, double precision A(M,N), the M by N matrix.
c
c    Output, integer I, J, the indices of the maximum entry of A.
c
      implicit none

      integer m
      integer n

      double precision a(m,n)
      integer i
      integer ii
      integer j
      integer jj

      i = -1
      j = -1

      do jj = 1, n
        do ii = 1, m
          if ( ii .eq. 1 .and. jj .eq. 1 ) then
            i = ii
            j = jj
          else if ( a(i,j) .lt. a(ii,jj) ) then
            i = ii
            j = jj
          end if
        end do
      end do

      return
      end
      function r8mat_maxcol_minrow ( m, n, a )

c*********************************************************************72
c
cc R8MAT_MAXCOL_MINROW gets the maximum column minimum row of an M by N R8MAT.
c
c  Discussion:
c
c    An R8MAT is an array of R8 values.
c
c    R8MAT_MAXCOL_MINROW = max ( 1 <= I <= N ) ( min ( 1 <= J <= M ) A(I,J) )
c
c    For a given matrix, R8MAT_MAXCOL_MINROW <= R8MAT_MINROW_MAXCOL.
c
c  Licensing:
c
c    This code is distributed under the GNU LGPL license.
c
c  Modified:
c
c    28 November 2011
c
c  Author:
c
c    John Burkardt
c
c  Parameters:
c
c    Input, integer M, the number of rows in A.
c
c    Input, integer N, the number of columns in A.
c
c    Input, double precision A(M,N), the matrix.
c
c    Output, double precision R8MAT_MAXCOL_MINROW, the maximum column
c    minimum row entry of A.
c
      implicit none

      integer m
      integer n

      double precision a(m,n)
      integer i
      integer j
      double precision r8mat_maxcol_minrow
      double precision r8mat_minrow

      r8mat_maxcol_minrow = 0.0D+00

      do i = 1, m

        r8mat_minrow = a(i,1)
        do j = 2, n
         r8mat_minrow = min ( r8mat_minrow, a(i,j) )
        end do

        if ( i .eq. 1 ) then
          r8mat_maxcol_minrow = r8mat_minrow
        else
          r8mat_maxcol_minrow = max ( r8mat_maxcol_minrow, 
     &      r8mat_minrow )
        end if

      end do

      return
      end
      function r8mat_maxrow_mincol ( m, n, a )

c*********************************************************************72
c
cc R8MAT_MAXROW_MINCOL gets the maximum row minimum column of an M by N R8MAT.
c
c  Discussion:
c
c    An R8MAT is an array of R8 values.
c
c    R8MAT_MAXROW_MINCOL = max ( 1 <= J <= N ) ( min ( 1 <= I <= M ) A(I,J) )
c
c    For a given matrix, R8MAT_MAXROW_MINCOL <= R8MAT_MINCOL_MAXROW.
c
c  Licensing:
c
c    This code is distributed under the GNU LGPL license.
c
c  Modified:
c
c    28 November 2011
c
c  Author:
c
c    John Burkardt
c
c  Parameters:
c
c    Input, integer M, the number of rows in A.
c
c    Input, integer N, the number of columns in A.
c
c    Input, double precision A(M,N), the matrix.
c
c    Output, double precision R8MAT_MAXROW_MINCOL, the maximum row
c    minimum column entry of A.
c
      implicit none

      integer m
      integer n

      double precision a(m,n)
      integer i
      integer j
      double precision r8mat_maxrow_mincol
      double precision r8mat_mincol

      r8mat_maxrow_mincol = 0.0D+00

      do j = 1, n

        r8mat_mincol = a(i,j)
        do i = 1, m
          r8mat_mincol = min ( r8mat_mincol, a(i,j) )
        end do

        if ( j .eq. 1 ) then
          r8mat_maxrow_mincol = r8mat_mincol
        else
          r8mat_maxrow_mincol = max ( r8mat_maxrow_mincol, 
     &      r8mat_mincol )
        end if

      end do

      return
      end
      function r8mat_min ( m, n, a )

c*********************************************************************72
c
cc R8MAT_MIN returns the minimum entry of an R8MAT.
c
c  Discussion:
c
c    An R8MAT is an array of R8's.
c
c  Licensing:
c
c    This code is distributed under the GNU LGPL license.
c
c  Modified:
c
c    19 May 2008
c
c  Author:
c
c    John Burkardt
c
c  Parameters:
c
c    Input, integer M, the number of rows in A.
c
c    Input, integer N, the number of columns in A.
c
c    Input, double precision A(M,N), the matrix.
c
c    Output, double precision R8MAT_MIN, the minimum entry of A.
c
      implicit none

      integer m
      integer n

      double precision a(m,n)
      integer i
      integer j
      double precision r8mat_min
      double precision value

      value = a(1,1)
      do j = 1, n
        do i = 1, m
          value = min ( value, a(i,j) )
        end do
      end do

      r8mat_min = value

      return
      end
      subroutine r8mat_min_index ( m, n, a, i, j )

c*********************************************************************72
c
cc R8MAT_MIN_INDEX returns the location of the minimum entry of an R8MAT.
c
c  Discussion:
c
c    An R8MAT is an array of R8 values.
c
c  Licensing:
c
c    This code is distributed under the GNU LGPL license.
c
c  Modified:
c
c    28 November 2011
c
c  Author:
c
c    John Burkardt
c
c  Parameters:
c
c    Input, integer M, the number of rows in A.
c
c    Input, integer N, the number of columns in A.
c
c    Input, double precision A(M,N), the M by N matrix.
c
c    Output, integer I, J, the indices of the minimum entry of A.
c
      implicit none

      integer m
      integer n

      double precision a(m,n)
      integer i
      integer ii
      integer j
      integer jj

      i = -1
      j = -1

      do jj = 1, n
        do ii = 1, m
          if ( ii .eq. 1 .and. jj .eq. 1 ) then
            i = ii
            j = jj
          else if ( a(ii,jj) .lt. a(i,j) ) then
            i = ii
            j = jj
          end if
        end do
      end do

      return
      end
      function r8mat_mincol_maxrow ( m, n, a )

c*********************************************************************72
c
cc R8MAT_MINCOL_MAXROW gets the minimum column maximum row of an M by N R8MAT.
c
c  Discussion:
c
c    An R8MAT is an array of R8 values.
c
c    R8MAT_MINCOL_MAXROW = min ( 1 <= I <= N ) ( max ( 1 <= J <= M ) A(I,J) )
c
c    For a given matrix, R8MAT_MAXROW_MINCOL <= R8MAT_MINCOL_MAXROW.
c
c  Licensing:
c
c    This code is distributed under the GNU LGPL license.
c
c  Modified:
c
c    28 November 2011
c
c  Author:
c
c    John Burkardt
c
c  Parameters:
c
c    Input, integer M, the number of rows in A.
c
c    Input, integer N, the number of columns in A.
c
c    Input, double precision A(M,N), the matrix.
c
c    Output, double precision R8MAT_MINCOL_MAXROW, the minimum column
c    maximum row entry of A.
c
      implicit none

      integer m
      integer n

      double precision a(m,n)
      integer i
      integer j
      double precision r8mat_mincol_maxrow
      double precision r8mat_maxrow

      r8mat_mincol_maxrow = 0.0D+00

      do i = 1, m

        r8mat_maxrow = a(i,1)
        do j = 2, n
          r8mat_maxrow = max ( r8mat_maxrow, a(i,j) )
        end do

        if ( i .eq. 1 ) then
          r8mat_mincol_maxrow = r8mat_maxrow
        else
          r8mat_mincol_maxrow = min ( r8mat_mincol_maxrow, 
     &      r8mat_maxrow )
        end if

      end do

      return
      end
      function r8mat_minrow_maxcol ( m, n, a )

c*********************************************************************72
c
cc R8MAT_MINROW_MAXCOL gets the minimum row maximum column of an M by N R8MAT.
c
c  Discussion:
c
c    An R8MAT is an array of R8 values.
c
c    R8MAT_MINROW_MAXCOL = min ( 1 <= J <= N ) ( max ( 1 <= I <= M ) A(I,J) )
c
c    For a given matrix, R8MAT_MAXCOL_MINROW <= R8MAT_MINROW_MAXCOL.
c
c  Licensing:
c
c    This code is distributed under the GNU LGPL license.
c
c  Modified:
c
c    28 November 2011
c
c  Author:
c
c    John Burkardt
c
c  Parameters:
c
c    Input, integer M, the number of rows in A.
c
c    Input, integer N, the number of columns in A.
c
c    Input, double precision A(M,N), the matrix.
c
c    Output, double precision R8MAT_MINROW_MAXCOL, the minimum row
c    maximum column entry of A.
c
      implicit none

      integer m
      integer n

      double precision a(m,n)
      integer i
      integer j
      double precision r8mat_minrow_maxcol
      double precision r8mat_maxcol

      r8mat_minrow_maxcol = 0.0D+00
   
      do j = 1, n

        r8mat_maxcol = a(1,j)
        do i = 2, m
          r8mat_maxcol = max ( r8mat_maxcol, a(i,j) )
        end do

        if ( j .eq. 1 ) then
          r8mat_minrow_maxcol = r8mat_maxcol
        else
          r8mat_minrow_maxcol = min ( r8mat_minrow_maxcol, 
     &      r8mat_maxcol )
        end if

      end do

      return
      end
      subroutine r8mat_minvm ( n1, n2, a, b, c )

c*********************************************************************72
c
cc R8MAT_MINVM computes inverse(A) * B for R8MAT's.
c
c  Discussion:
c
c    An R8MAT is an array of R8 values.
c
c  Licensing:
c
c    This code is distributed under the GNU LGPL license.
c
c  Modified:
c
c    28 November 2011
c
c  Author:
c
c    John Burkardt
c
c  Parameters:
c
c    Input, integer N1, N2, the order of the matrices.
c
c    Input, double precision A(N1,N1), B(N1,N2), the matrices.
c
c    Output, double precision C(N1,N2), the result, C = inverse(A) * B.
c
      implicit none

      integer n1
      integer n2

      double precision a(n1,n1)
      double precision alu(n1,n1)
      double precision b(n1,n2)
      double precision c(n1,n2)
      integer info

      call r8mat_copy ( n1, n1, a, alu )
      call r8mat_copy ( n1, n2, b, c )

      call r8mat_fss ( n1, alu, n2, c, info )
 
      if ( info .ne. 0 ) then
        write ( *, '(a)' ) ' '
        write ( *, '(a)' ) 'R8MAT_MINVM - Fatal error!'
        write ( *, '(a)' ) '  The matrix A was numerically singular.'
        stop
      end if

      return
      end
      subroutine r8mat_mm ( n1, n2, n3, a, b, c )

c*********************************************************************72
c
cc R8MAT_MM multiplies two R8MAT's.
c
c  Discussion:
c
c    An R8MAT is an array of R8 values.
c
c    In FORTRAN90, this operation is more efficiently done by the
c    command:
c
c      C(1:N1,1:N3) = MATMUL ( A(1:N1,1;N2), B(1:N2,1:N3) )
c
c  Licensing:
c
c    This code is distributed under the GNU LGPL license.
c
c  Modified:
c
c    12 December 2004
c
c  Author:
c
c    John Burkardt
c
c  Parameters:
c
c    Input, integer N1, N2, N3, the order of the matrices.
c
c    Input, double precision A(N1,N2), B(N2,N3), the matrices to multiply.
c
c    Output, double precision C(N1,N3), the product matrix C = A * B.
c
      implicit none

      integer n1
      integer n2
      integer n3

      double precision a(n1,n2)
      double precision b(n2,n3)
      double precision c(n1,n3)
      integer i
      integer j
      integer k

      do i = 1, n1
        do j = 1, n3
          c(i,j) = 0.0D+00
          do k = 1, n2
            c(i,j) = c(i,j) + a(i,k) * b(k,j)
          end do
        end do
      end do

      return
      end
      subroutine r8mat_mmt ( n1, n2, n3, a, b, c )

c*********************************************************************72
c
cc R8MAT_MMT multiplies computes C = A * B' for two R8MAT's.
c
c  Discussion:
c
c    An R8MAT is an array of R8 values.
c
c    In FORTRAN90, this operation is more efficiently done by the
c    command:
c
c      C(1:N1,1:N3) = matmul ( A(1:N1,1;N2), transpose ( B(1:N3,1:N2) ) )
c
c  Licensing:
c
c    This code is distributed under the GNU LGPL license.
c
c  Modified:
c
c    13 November 2012
c
c  Author:
c
c    John Burkardt
c
c  Parameters:
c
c    Input, integer N1, N2, N3, the order of the matrices.
c
c    Input, double precision A(N1,N2), B(N3,N2), the matrices to multiply.
c
c    Output, double precision C(N1,N3), the product matrix C = A * B'.
c
      implicit none

      integer n1
      integer n2
      integer n3

      double precision a(n1,n2)
      double precision b(n3,n2)
      double precision c(n1,n3)
      integer i
      integer j
      integer k

      do i = 1, n1
        do j = 1, n3
          c(i,j) = 0.0D+00
          do k = 1, n2
            c(i,j) = c(i,j) + a(i,k) * b(j,k)
          end do
        end do
      end do

      return
      end
      subroutine r8mat_mtm ( n1, n2, n3, a, b, c )

c*********************************************************************72
c
cc R8MAT_MTM multiplies computes C = A' * B for two R8MAT's.
c
c  Discussion:
c
c    An R8MAT is an array of R8 values.
c
c    In FORTRAN90, this operation is more efficiently done by the
c    command:
c
c      C(1:N1,1:N3) = matmul ( transpose ( A(1:N2,1:N1) ), B(1:N2,1:N3) )
c
c  Licensing:
c
c    This code is distributed under the GNU LGPL license.
c
c  Modified:
c
c    07 September 2012
c
c  Author:
c
c    John Burkardt
c
c  Parameters:
c
c    Input, integer N1, N2, N3, the order of the matrices.
c
c    Input, double precision A(N2,N1), B(N2,N3), the matrices to multiply.
c
c    Output, double precision C(N1,N3), the product matrix C = A' * B.
c
      implicit none

      integer n1
      integer n2
      integer n3

      double precision a(n2,n1)
      double precision b(n2,n3)
      double precision c(n1,n3)
      integer i
      integer j
      integer k

      do i = 1, n1
        do j = 1, n3
          c(i,j) = 0.0D+00
          do k = 1, n2
            c(i,j) = c(i,j) + a(k,i) * b(k,j)
          end do
        end do
      end do

      return
      end
      subroutine r8mat_mtv ( m, n, a, x, y )

c*****************************************************************************80
c
cc R8MAT_MTV multiplies a transposed matrix times a vector
c
c  Discussion:
c
c    An R8MAT is an array of R8 values.
c
c  Licensing:
c
c    This code is distributed under the GNU LGPL license.
c
c  Modified:
c
c    02 December 2011
c
c  Author:
c
c    John Burkardt
c
c  Parameters:
c
c    Input, integer M, N, the number of rows and columns of
c    the matrix.
c
c    Input, double precision A(M,N), the M by N matrix.
c
c    Input, double precision X(M), the vector to be multiplied by A.
c
c    Output, double precision Y(N), the product A'*X.
c
      implicit none

      integer m
      integer n

      double precision a(m,n)
      integer i
      integer j
      double precision x(m)
      double precision y(n)

      do i = 1, n
        y(i) = 0.0D+00
        do j = 1, m
          y(i) = y(i) + a(j,i) * x(j)
        end do
      end do

      return
      end
      subroutine r8mat_mv ( m, n, a, x, y )

c*********************************************************************72
c
cc R8MAT_MV multiplies a matrix times a vector.
c
c  Discussion:
c
c    An R8MAT is an array of R8's.
c
c    In FORTRAN90, this operation can be more efficiently carried
c    out by the command
c
c      Y(1:M) = MATMUL ( A(1:M,1:N), X(1:N) )
c
c  Licensing:
c
c    This code is distributed under the GNU LGPL license.
c
c  Modified:
c
c    12 December 2004
c
c  Author:
c
c    John Burkardt
c
c  Parameters:
c
c    Input, integer M, N, the number of rows and columns of the matrix.
c
c    Input, double precision A(M,N), the M by N matrix.
c
c    Input, double precision X(N), the vector to be multiplied by A.
c
c    Output, double precision Y(M), the product A*X.
c
      implicit none

      integer m
      integer n

      double precision a(m,n)
      integer i
      integer j
      double precision x(n)
      double precision y(m)

      do i = 1, m
        y(i) = 0.0D+00
        do j = 1, n
          y(i) = y(i) + a(i,j) * x(j)
        end do
      end do

      return
      end
      subroutine r8mat_nint ( m, n, a )

c*********************************************************************72
c
cc R8MAT_NINT rounds the entries of an R8MAT.
c
c  Discussion:
c
c    An R8MAT is an array of R8 values.
c
c  Licensing:
c
c    This code is distributed under the GNU LGPL license.
c
c  Modified:
c
c    22 November 2011
c
c  Author:
c
c    John Burkardt
c
c  Parameters:
c
c    Input, integer M, N, the number of rows and columns of A.
c
c    Input/output, double precision A(M,N), the matrix to be NINT'ed.
c
      implicit none
   
      integer m
      integer n

      double precision a(m,n)
      integer i
      integer j

      do j = 1, n
        do i = 1, m
          a(i,j) = dble ( nint ( a(i,j) ) )
        end do
      end do
      return
      end
      function r8mat_norm_eis ( m, n, a )

c*********************************************************************72
c
cc R8MAT_NORM_EIS returns the EISPACK norm of an R8MAT.
c
c  Discussion:
c
c    An R8MAT is an array of R8's.
c
c    The EISPACK norm is defined as:
c
c      R8MAT_NORM_EIS =
c        sum ( 1 <= I <= M ) sum ( 1 <= J <= N ) abs ( A(I,J) )
c
c  Licensing:
c
c    This code is distributed under the GNU LGPL license.
c
c  Modified:
c
c    23 August 2008
c
c  Author:
c
c    John Burkardt
c
c  Parameters:
c
c    Input, integer M, the number of rows in A.
c
c    Input, integer N, the number of columns in A.
c
c    Input, double precision A(M,N), the matrix whose EISPACK norm is desired.
c
c    Output, double precision R8MAT_NORM_EIS, the EISPACK norm of A.
c
      implicit none

      integer m
      integer n

      double precision a(m,n)
      integer i
      integer j
      double precision r8mat_norm_eis

      r8mat_norm_eis = 0.0D+00
      do j = 1, n
        do i = 1, m
          r8mat_norm_eis = r8mat_norm_eis + abs ( a(i,j) )
        end do
      end do

      return
      end
      function r8mat_norm_fro ( m, n, a )

c*********************************************************************72
c
cc R8MAT_NORM_FRO returns the Frobenius norm of an R8MAT.
c
c  Discussion:
c
c    An R8MAT is an array of R8's.
c
c    The Frobenius norm is defined as
c
c      R8MAT_NORM_FRO = sqrt (
c        sum ( 1 .le. I .le. M ) sum ( 1 .le. j .le. N ) A(I,J)^2 )
c
c    The matrix Frobenius norm is not derived from a vector norm, but
c    is compatible with the vector L2 norm, so that:
c
c      r8vec_norm_l2 ( A * x ) <= r8mat_norm_fro ( A ) * r8vec_norm_l2 ( x ).
c
c  Licensing:
c
c    This code is distributed under the GNU LGPL license.
c
c  Modified:
c
c    26 July 2008
c
c  Author:
c
c    John Burkardt
c
c  Parameters:
c
c    Input, integer M, the number of rows in A.
c
c    Input, integer N, the number of columns in A.
c
c    Input, double precision A(M,N), the matrix whose Frobenius
c    norm is desired.
c
c    Output, double precision R8MAT_NORM_FRO, the Frobenius norm of A.
c
      implicit none

      integer m
      integer n

      double precision a(m,n)
      integer i
      integer j
      double precision r8mat_norm_fro
      double precision value

      value = 0.0D+00
      do j = 1, n
        do i = 1, m
          value = value + a(i,j) * a(i,j)
        end do
      end do
      value = sqrt ( value )

      r8mat_norm_fro = value

      return
      end
      function r8mat_norm_fro_affine ( m, n, a1, a2 )

c*********************************************************************72
c
cc R8MAT_NORM_FRO_AFFINE returns the Frobenius norm of an R8MAT difference.
c
c  Discussion:
c
c    An R8MAT is an array of R8's.
c
c    The Frobenius norm is defined as
c
c      R8MAT_NORM_FRO = sqrt (
c        sum ( 1 .le. I .le. M ) sum ( 1 .le. j .le. N ) A(I,J)^2 )
c
c    The matrix Frobenius norm is not derived from a vector norm, but
c    is compatible with the vector L2 norm, so that:
c
c      r8vec_norm_l2 ( A * x ) <= r8mat_norm_fro ( A ) * r8vec_norm_l2 ( x ).
c
c  Licensing:
c
c    This code is distributed under the GNU LGPL license.
c
c  Modified:
c
c    26 September 2012
c
c  Author:
c
c    John Burkardt
c
c  Parameters:
c
c    Input, integer M, the number of rows.
c
c    Input, integer N, the number of columns.
c
c    Input, double precision A1(M,N), A2(M,N), the matrices for which the
c    Frobenius norm of the difference is desired.
c
c    Output, double precision R8MAT_NORM_FRO_AFFINE, the Frobenius norm 
C    of A1 - A2.
c
      implicit none

      integer m
      integer n

      double precision a1(m,n)
      double precision a2(m,n)
      integer i
      integer j
      double precision r8mat_norm_fro_affine
      double precision value

      value = 0.0D+00
      do j = 1, n
        do i = 1, m
          value = value + ( a1(i,j) - a2(i,j) )**2 
        end do
      end do
      value = sqrt ( value )

      r8mat_norm_fro_affine = value

      return
      end
      function r8mat_norm_l1 ( m, n, a )

c*********************************************************************72
c
cc R8MAT_NORM_L1 returns the matrix L1 norm of an R8MAT.
c
c  Discussion:
c
c    An R8MAT is an array of R8's.
c
c    The matrix L1 norm is defined as:
c
c      R8MAT_NORM_L1 = max ( 1 <= J <= N )
c        sum ( 1 <= I <= M ) abs ( A(I,J) ).
c
c    The matrix L1 norm is derived from the vector L1 norm, and
c    satisifies:
c
c      r8vec_norm_l1 ( A * x ) <= r8mat_norm_l1 ( A ) * r8vec_norm_l1 ( x ).
c
c  Licensing:
c
c    This code is distributed under the GNU LGPL license.
c
c  Modified:
c
c    31 August 2008
c
c  Author:
c
c    John Burkardt
c
c  Parameters:
c
c    Input, integer M, the number of rows in A.
c
c    Input, integer N, the number of columns in A.
c
c    Input, double precision A(M,N), the matrix whose L1 norm is desired.
c
c    Output, double precision R8MAT_NORM_L1, the L1 norm of A.
c
      implicit none

      integer m
      integer n

      double precision a(m,n)
      integer i
      integer j
      double precision r8mat_norm_l1
      double precision sum2

      r8mat_norm_l1 = 0.0D+00

      do j = 1, n
        sum2 = 0.0D+00
        do i = 1, m
          sum2 = sum2 + abs ( a(i,j) )
        end do
        r8mat_norm_l1 = max ( r8mat_norm_l1, sum2 )
      end do

      return
      end
      function r8mat_norm_l2 ( m, n, a )

c*********************************************************************72
c
cc R8MAT_NORM_L2 returns the matrix L2 norm of an R8MAT.
c
c  Discussion:
c
c    An R8MAT is an array of R8 values.
c
c    The matrix L2 norm is defined as:
c
c      R8MAT_NORM_L2 = sqrt ( max ( 1 <= I <= M ) LAMBDA(I) )
c
c    where LAMBDA contains the eigenvalues of A * A'.
c
c    The matrix L2 norm is derived from the vector L2 norm, and
c    satisifies:
c
c      r8vec_norm_l2 ( A * x ) <= r8mat_norm_l2 ( A ) * r8vec_norm_l2 ( x ).
c
c  Licensing:
c
c    This code is distributed under the GNU LGPL license.
c
c  Modified:
c
c    23 November 2011
c
c  Author:
c
c    John Burkardt
c
c  Parameters:
c
c    Input, integer M, the number of rows in A.
c
c    Input, integer N, the number of columns in A.
c
c    Input, double precision A(M,N), the matrix whose L2 norm is desired.
c
c    Output, double precision R8MAT_NORM_L2, the L2 norm of A.
c
      implicit none

      integer m
      integer n

      double precision a(m,n)
      double precision b(m,m)
      double precision d
      double precision diag(m)
      integer i
      integer j
      integer k
      double precision r8mat_norm_l2
      double precision r8vec_max
c
c  Compute B = A * A'.
c
      do j = 1, m
        do i = 1, m
          b(i,j) = 0.0D+00
          do k = 1, n
            b(i,j) = b(i,j) + a(i,k) * a(j,k)
          end do
        end do
      end do
c
c  Diagonalize B.
c
      call r8mat_symm_jacobi ( m, b )
c
c  Find the maximum eigenvalue, and take its square root.
c
      call r8mat_diag_get_vector ( m, b, diag )

      d = r8vec_max ( m, diag )

      r8mat_norm_l2 = sqrt ( d )

      return
      end
      function r8mat_norm_li ( m, n, a )

c*********************************************************************72
c
cc R8MAT_NORM_LI returns the matrix L-oo norm of an R8MAT.
c
c  Discussion:
c
c    An R8MAT is an array of R8 values.
c
c    The matrix L-oo norm is defined as:
c
c      R8MAT_NORM_LI =  max ( 1 <= I <= M ) sum ( 1 <= J <= N ) abs ( A(I,J) ).
c
c    The matrix L-oo norm is derived from the vector L-oo norm,
c    and satisifies:
c
c      r8vec_norm_li ( A * x ) <= r8mat_norm_li ( A ) * r8vec_norm_li ( x ).
c
c  Licensing:
c
c    This code is distributed under the GNU LGPL license.
c
c  Modified:
c
c    15 May 2010
c
c  Author:
c
c    John Burkardt
c
c  Parameters:
c
c    Input, integer M, the number of rows in A.
c
c    Input, integer N, the number of columns in A.
c
c    Input, double precision A(M,N), the matrix whose L-oo
c    norm is desired.
c
c    Output, double precision R8MAT_NORM_LI, the L-oo norm of A.
c
      implicit none

      integer m
      integer n

      double precision a(m,n)
      integer i
      integer j
      double precision r8mat_norm_li
      double precision t

      r8mat_norm_li = 0.0D+00

      do i = 1, m
        t = 0.0D+00
        do j = 1, n
          t = t + abs ( a(i,j) )
        end do
        r8mat_norm_li = max ( r8mat_norm_li, t )
      end do

      return
      end
      subroutine r8mat_normal_01 ( m, n, seed, r )

c*********************************************************************72
c
cc R8MAT_NORMAL_01 returns a unit pseudonormal R8MAT.
c
c  Licensing:
c
c    This code is distributed under the GNU LGPL license.
c
c  Modified:
c
c    12 November 2010
c
c  Author:
c
c    John Burkardt
c
c  Reference:
c
c    Paul Bratley, Bennett Fox, Linus Schrage,
c    A Guide to Simulation,
c    Springer Verlag, pages 201-202, 1983.
c
c    Bennett Fox,
c    Algorithm 647:
c    Implementation and Relative Efficiency of Quasirandom
c    Sequence Generators,
c    ACM Transactions on Mathematical Software,
c    Volume 12, Number 4, pages 362-376, 1986.
c
c    Peter Lewis, Allen Goodman, James Miller,
c    A Pseudo-Random Number Generator for the System/360,
c    IBM Systems Journal,
c    Volume 8, pages 136-143, 1969.
c
c  Parameters:
c
c    Input, integer M, N, the number of rows and columns in the array.
c
c    Input/output, integer SEED, the "seed" value, which should NOT be 0.
c    On output, SEED has been updated.
c
c    Output, double precision R(M,N), the array of pseudonormal values.
c
      implicit none

      integer m
      integer n

      integer seed
      double precision r(m,n)

      call r8vec_normal_01 ( m * n, seed, r )

      return
      end
      subroutine r8mat_orth_uniform ( n, seed, a )

c*********************************************************************72
c
cc R8MAT_ORTH_UNIFORM returns a random orthogonal R8MAT.
c
c  Discussion:
c
c    An R8MAT is an array of R8's.
c
c    Thanks to Eugene Petrov, B I Stepanov Institute of Physics,
c    National Academy of Sciences of Belarus, for convincingly
c    pointing out the severe deficiencies of an earlier version of
c    this routine.
c
c    Essentially, the computation involves saving the Q factor of the
c    QR factorization of a matrix whose entries are normally distributed.
c    However, it is only necessary to generate this matrix a column at
c    a time, since it can be shown that when it comes time to annihilate
c    the subdiagonal elements of column K, these (transformed) elements of
c    column K are still normally distributed random values.  Hence, there
c    is no need to generate them at the beginning of the process and
c    transform them K-1 times.
c
c    For computational efficiency, the individual Householder transformations
c    could be saved, as recommended in the reference, instead of being
c    accumulated into an explicit matrix format.
c
c  Properties:
c
c    The inverse of A is equal to A'.
c
c    A * A'  = A' * A = I.
c
c    Columns and rows of A have unit Euclidean norm.
c
c    Distinct pairs of columns of A are orthogonal.
c
c    Distinct pairs of rows of A are orthogonal.
c
c    The L2 vector norm of A*x = the L2 vector norm of x for any vector x.
c
c    The L2 matrix norm of A*B = the L2 matrix norm of B for any matrix B.
c
c    The determinant of A is +1 or -1.
c
c    All the eigenvalues of A have modulus 1.
c
c    All singular values of A are 1.
c
c    All entries of A are between -1 and 1.
c
c  Licensing:
c
c    This code is distributed under the GNU LGPL license.
c
c  Modified:
c
c    04 November 2004
c
c  Author:
c
c    John Burkardt
c
c  Reference:
c
c    Pete Stewart,
c    Efficient Generation of Random Orthogonal Matrices With an Application
c    to Condition Estimators,
c    SIAM Journal on Numerical Analysis,
c    Volume 17, Number 3, June 1980, pages 403-409.
c
c  Parameters:
c
c    Input, integer N, the order of A.
c
c    Input/output, integer SEED, a seed for the random number generator.
c
c    Output, double precision A(N,N), the orthogonal matrix.
c
      implicit none

      integer n

      double precision a(n,n)
      integer i
      integer j
      double precision r8_normal_01
      integer seed
      double precision v(n)
      double precision x(n)
c
c  Start with A = the identity matrix.
c
      do i = 1, n
        do j = 1, n
          if ( i .eq. j ) then
            a(i,j) = 1.0D+00
          else
            a(i,j) = 0.0D+00
          end if
        end do
      end do
c
c  Now behave as though we were computing the QR factorization of
c  some other random matrix.  Generate the N elements of the first column,
c  compute the Householder matrix H1 that annihilates the subdiagonal elements,
c  and set A := A * H1' = A * H.
c
c  On the second step, generate the lower N-1 elements of the second column,
c  compute the Householder matrix H2 that annihilates them,
c  and set A := A * H2' = A * H2 = H1 * H2.
c
c  On the N-1 step, generate the lower 2 elements of column N-1,
c  compute the Householder matrix HN-1 that annihilates them, and
c  and set A := A * H(N-1)' = A * H(N-1) = H1 * H2 * ... * H(N-1).
c  This is our random orthogonal matrix.
c
      do j = 1, n - 1
c
c  Set the vector that represents the J-th column to be annihilated.
c
        do i = 1, j - 1
          x(i) = 0.0D+00
        end do

        do i = j, n
          x(i) = r8_normal_01 ( seed )
        end do
c
c  Compute the vector V that defines a Householder transformation matrix
c  H(V) that annihilates the subdiagonal elements of X.
c
        call r8vec_house_column ( n, x, j, v )
c
c  Postmultiply the matrix A by H'(V) = H(V).
c
        call r8mat_house_axh ( n, a, v, a )

      end do

      return
      end
      subroutine r8mat_plot ( m, n, a, title )

c*********************************************************************72
c
cc R8MAT_PLOT "plots" an R8MAT, with an optional title.
c
c  Discussion:
c
c    An R8MAT is an array of R8 values.
c
c  Licensing:
c
c    This code is distributed under the GNU LGPL license.
c
c  Modified:
c
c    02 December 2011
c
c  Author:
c
c    John Burkardt
c
c  Parameters:
c
c    Input, integer M, the number of rows in A.
c
c    Input, integer N, the number of columns in A.
c
c    Input, double precision A(M,N), the matrix.
c
c    Input, character * ( * ) TITLE, a title.
c
      implicit none

      integer m
      integer n

      double precision a(m,n)
      integer i
      integer j
      integer jhi
      integer jlo
      character r8mat_plot_symbol
      character * ( 70 ) string
      character * ( * ) title

      write ( *, '(a)' ) ' '
      write ( *, '(a)' ) trim ( title )

      do jlo = 1, n, 70
        jhi = min ( jlo + 70-1, n )
        write ( *, '(a)' ) ' '
        write ( *, '(8x,2x,70i1)' ) ( mod ( j, 10 ), j = jlo, jhi )
        write ( *, '(a)' ) ' '

        do i = 1, m
          do j = jlo, jhi
            string(j+1-jlo:j+1-jlo) = r8mat_plot_symbol ( a(i,j) )
          end do
          write ( *, '(i8,2x,a)' ) i, string(1:jhi+1-jlo)
        end do
      end do
 
      return
      end
      function r8mat_plot_symbol ( r )

c*********************************************************************72
c
cc R8MAT_PLOT_SYMBOL returns a symbol for an element of an R8MAT.
c
c  Discussion:
c
c    An R8MAT is an array of R8 values.
c
c  Licensing:
c
c    This code is distributed under the GNU LGPL license.
c
c  Modified:
c
c    24 November 2011
c
c  Author:
c
c    John Burkardt
c
c  Parameters:
c
c    Input, double precision R, a value whose symbol is desired.
c
c    Output, character R8MAT_PLOT_SYMBOL, is
c    '-' if R is negative,
c    '0' if R is zero,
c    '+' if R is positive.
c
      implicit none

      character r8mat_plot_symbol
      double precision r

      if ( r .lt. 0.0D+00 ) then
        r8mat_plot_symbol = '-'
      else if ( r .eq. 0.0D+00 ) then
        r8mat_plot_symbol = '0'
      else if ( 0.0D+00 .lt. r ) then
        r8mat_plot_symbol = '+'
      end if

      return
      end
      subroutine r8mat_poly_char ( n, a, p )

c*********************************************************************72
c
cc R8MAT_POLY_CHAR computes the characteristic polynomial of an R8MAT.
c
c  Discussion:
c
c    An R8MAT is an array of R8 values.
c
c  Licensing:
c
c    This code is distributed under the GNU LGPL license.
c
c  Modified:
c
c    24 November 2011
c
c  Author:
c
c    John Burkardt
c
c  Parameters:
c
c    Input, integer N, the order of the matrix A.
c
c    Input, double precision A(N,N), the N by N matrix.
c
c    Output, double precision P(0:N), the coefficients of the characteristic
c    polynomial of A.  P(N) contains the coefficient of X^N
c    (which will be 1), P(I) contains the coefficient of X^I,
c    and P(0) contains the constant term.
c
      implicit none

      integer n

      double precision a(n,n)
      integer i
      integer j
      integer k
      integer order
      double precision p(0:n)
      double precision r8mat_trace
      double precision trace
      double precision work1(n,n)
      double precision work2(n,n)
c
c  Initialize WORK1 to the identity matrix.
c
      call r8mat_identity ( n, work1 )

      p(n) = 1.0D+00

      do order = n - 1, 0, -1
c
c  Work2 = A * WORK1.
c
        do j = 1, n
          do i = 1, n
            work2(i,j) = 0.0D+00
            do k = 1, n
              work2(i,j) = work2(i,j) + a(i,k) * work1(k,j)
            end do
          end do
        end do
c
c  Take the trace.
c
        trace = r8mat_trace ( n, work2 )
c
c  P(ORDER) = -Trace ( WORK2 ) / ( N - ORDER )
c
        p(order) = - trace / dble ( n - order )
c
c  WORK1 := WORK2 + P(ORDER) * Identity.
c
        do j = 1, n
          do i = 1, n
            work1(i,j) = work2(i,j)
          end do
        end do

        do i = 1, n
          work1(i,i) = work1(i,i) + p(order)
        end do

      end do

      return
      end
      subroutine r8mat_power ( n, a, npow, b )

c*********************************************************************72
c
cc R8MAT_POWER computes a nonnegative power of an R8MAT.
c
c  Discussion:
c
c    An R8MAT is an array of R8 values.
c
c    The algorithm is:
c
c      B = I
c      do NPOW times:
c        B = A * B
c      end
c
c  Licensing:
c
c    This code is distributed under the GNU LGPL license.
c
c  Modified:
c
c    23 April 2005
c
c  Author:
c
c    John Burkardt
c
c  Parameters:
c
c    Input, integer N, the order of A.
c
c    Input, double precision A(N,N), the matrix to be raised to a power.
c
c    Input, integer NPOW, the power to which A is to be raised.
c    NPOW must be nonnegative.
c
c    Output, double precision B(N,N), the value of A^NPOW.
c
      implicit none

      integer n

      double precision a(n,n)
      double precision b(n,n)
      double precision c(n,n)
      integer i
      integer ipow
      integer j
      integer k
      integer npow

      if ( npow .lt. 0 ) then
        write ( *, '(a)' ) ' '
        write ( *, '(a)' ) 'R8MAT_POWER - Fatal error!'
        write ( *, '(a)' ) '  Input value of NPOW < 0.'
        write ( *, '(a,i8)' ) '  NPOW = ', npow
        stop
      end if

      call r8mat_identity ( n, b )

      do ipow = 1, npow

        do j = 1, n
          do i = 1, n
            c(i,j) = b(i,j)
          end do
        end do

        do j = 1, n
          do i = 1, n
            do k = 1, n
              b(i,j) = b(i,j) + a(i,k) * c(k,j)
            end do
          end do
        end do

      end do

      return
      end
      subroutine r8mat_power_method ( n, a, r, v )

c*********************************************************************72
c
cc R8MAT_POWER_METHOD applies the power method to an R8MAT.
c
c  Discussion:
c
c    An R8MAT is an array of R8 values.
c
c    If the power method has not converged, then calling the routine
c    again immediately with the output from the previous call will
c    continue the iteration.
c
c  Licensing:
c
c    This code is distributed under the GNU LGPL license.
c
c  Modified:
c
c    02 December 2011
c
c  Author:
c
c    John Burkardt
c
c  Parameters:
c
c    Input, integer N, the order of A.
c
c    Input, double precision A(N,N), the matrix.
c
c    Output, double precision R, the estimated eigenvalue.
c
c    Input/output, double precision V(N), on input, an estimate
c    for the eigenvector.  On output, an improved estimate for the
c    eigenvector.
c
      implicit none

      integer n

      double precision a(n,n)
      double precision av(n)
      double precision eps
      integer i
      integer it
      double precision it_eps
      parameter ( it_eps = 0.0001D+00 )
      integer it_max 
      parameter ( it_max = 100 )
      integer it_min
      parameter ( it_min = 10 )
      integer j
      double precision r
      double precision r2
      double precision r8_epsilon
      double precision r_old
      double precision v(n)

      eps = sqrt ( r8_epsilon ( ) )

      r = 0.0D+00
      do i = 1, n
        r = r + v(i)**2
      end do
      r = sqrt ( r )

      if ( r .eq. 0.0D+00 ) then
        do i = 1, n
          v(i) = 1.0D+00
        end do
        r = sqrt ( dble ( n ) )
      end if

      do i = 1, n
        v(i) = v(i) / r
      end do

      do it = 1, it_max

        call r8mat_mm ( n, n, n, a, v, av )

        r_old = r
 
        r = 0.0D+00
        do i = 1, n
          r = r + av(i)**2
        end do
        r = sqrt ( r )

        if ( it_min .lt. it ) then
          if ( abs ( r - r_old ) .le. 
     &      it_eps * ( 1.0D+00 + abs ( r ) ) ) then
            go to 10
          end if
        end if

        do i = 1, n
          v(i) = av(i)
        end do

        if ( r .ne. 0.0D+00 ) then
          do i = 1, n
            v(i) = v(i) / r
          end do
        end if
c
c  Perturb V a bit, to avoid cases where the initial guess is exactly
c  the eigenvector of a smaller eigenvalue.
c
        if ( it .lt. it_max / 2 ) then
          j = 1 + mod ( it - 1, n )
          v(j) = v(j) + eps * ( 1.0D+00 + abs ( v(j) ) )
          r2 = 0.0D+00
          do i = 1, n
            r2 = r2 + v(i)**2
          end do
          r2 = sqrt ( r2 )
          do i = 1, n
            v(i) = v(i) / r2
          end do
        end if

      end do

10    continue

      return
      end
      subroutine r8mat_print ( m, n, a, title )

c*********************************************************************72
c
cc R8MAT_PRINT prints an R8MAT.
c
c  Discussion:
c
c    An R8MAT is an array of R8's.
c
c  Licensing:
c
c    This code is distributed under the GNU LGPL license.
c
c  Modified:
c
c    20 May 2004
c
c  Author:
c
c    John Burkardt
c
c  Parameters:
c
c    Input, integer M, the number of rows in A.
c
c    Input, integer N, the number of columns in A.
c
c    Input, double precision A(M,N), the matrix.
c
c    Input, character ( len = * ) TITLE, a title.
c
      implicit none

      integer m
      integer n

      double precision a(m,n)
      character ( len = * ) title

      call r8mat_print_some ( m, n, a, 1, 1, m, n, title )

      return
      end
      subroutine r8mat_print_some ( m, n, a, ilo, jlo, ihi, jhi,
     &  title )

c*********************************************************************72
c
cc R8MAT_PRINT_SOME prints some of an R8MAT.
c
c  Discussion:
c
c    An R8MAT is an array of R8's.
c
c  Licensing:
c
c    This code is distributed under the GNU LGPL license.
c
c  Modified:
c
c    25 January 2007
c
c  Author:
c
c    John Burkardt
c
c  Parameters:
c
c    Input, integer M, N, the number of rows and columns.
c
c    Input, double precision A(M,N), an M by N matrix to be printed.
c
c    Input, integer ILO, JLO, the first row and column to print.
c
c    Input, integer IHI, JHI, the last row and column to print.
c
c    Input, character ( len = * ) TITLE, a title.
c
      implicit none

      integer incx
      parameter ( incx = 5 )
      integer m
      integer n

      double precision a(m,n)
      character * ( 14 ) ctemp(incx)
      integer i
      integer i2hi
      integer i2lo
      integer ihi
      integer ilo
      integer inc
      integer j
      integer j2
      integer j2hi
      integer j2lo
      integer jhi
      integer jlo
      character * ( * ) title

      write ( *, '(a)' ) ' '
      write ( *, '(a)' ) trim ( title )

      if ( m .le. 0 .or. n .le. 0 ) then
        write ( *, '(a)' ) ' '
        write ( *, '(a)' ) '  (None)'
        return
      end if

      do j2lo = max ( jlo, 1 ), min ( jhi, n ), incx

        j2hi = j2lo + incx - 1
        j2hi = min ( j2hi, n )
        j2hi = min ( j2hi, jhi )

        inc = j2hi + 1 - j2lo

        write ( *, '(a)' ) ' '

        do j = j2lo, j2hi
          j2 = j + 1 - j2lo
          write ( ctemp(j2), '(i7,7x)') j
        end do

        write ( *, '(''  Col   '',5a14)' ) ( ctemp(j), j = 1, inc )
        write ( *, '(a)' ) '  Row'
        write ( *, '(a)' ) ' '

        i2lo = max ( ilo, 1 )
        i2hi = min ( ihi, m )

        do i = i2lo, i2hi

          do j2 = 1, inc

            j = j2lo - 1 + j2

            write ( ctemp(j2), '(g14.6)' ) a(i,j)

          end do

          write ( *, '(i5,a,5a14)' ) i, ':', ( ctemp(j), j = 1, inc )

        end do

      end do

      return
      end
      subroutine r8mat_ref ( m, n, a )

c*********************************************************************72
c
cc R8MAT_REF computes the row echelon form of a matrix.
c
c  Discussion:
c
c    An R8MAT is an array of R8 values.
c
c    A matrix is in row echelon form if:
c
c    * The first nonzero entry in each row is 1.
c
c    * The leading 1 in a given row occurs in a column to
c      the right of the leading 1 in the previous row.
c
c    * Rows which are entirely zero must occur last.
c
c  Example:
c
c    Input matrix:
c
c     1.0  3.0  0.0  2.0  6.0  3.0  1.0
c    -2.0 -6.0  0.0 -2.0 -8.0  3.0  1.0
c     3.0  9.0  0.0  0.0  6.0  6.0  2.0
c    -1.0 -3.0  0.0  1.0  0.0  9.0  3.0
c
c    Output matrix:
c
c     1.0  3.0  0.0  2.0  6.0  3.0  1.0
c     0.0  0.0  0.0  1.0  2.0  4.5  1.5
c     0.0  0.0  0.0  0.0  0.0  1.0  0.3
c     0.0  0.0  0.0  0.0  0.0  0.0  0.0
c
c  Licensing:
c
c    This code is distributed under the GNU LGPL license.
c
c  Modified:
c
c    02 December 2011
c
c  Author:
c
c    John Burkardt
c
c  Parameters:
c
c    Input, integer M, N, the number of rows and columns of
c    the matrix A.
c
c    Input/output, double precision A(M,N).  On input, the matrix to be
c    analyzed.  On output, the REF form of the matrix.
c
      implicit none

      integer m
      integer n

      double precision a(m,n)
      integer i
      integer j
      integer lead
      integer r
      double precision temp

      lead = 1

      do r = 1, m

        if ( n .lt. lead ) then
          go to 30
        end if

        i = r
 
10      continue

        if ( a(i,lead) .eq. 0.0D+00 ) then

          i = i + 1

          if ( m .lt. i ) then
            i = r
            lead = lead + 1
            if ( n .lt. lead ) then
              lead = -1
              go to 20
            end if
          end if

          go to 10

        end if

20      continue

        if ( lead .lt. 0 ) then
          go to 30
        end if

        do j = 1, n
          temp   = a(i,j)
          a(i,j) = a(r,j)
          a(r,j) = temp
        end do

        do j = 1, n
          a(r,j) = a(r,j) / a(r,lead)
        end do

        do i = r + 1, m
          do j = 1, n
            a(i,j) = a(i,j) - a(i,lead) * a(r,j)
          end do
        end do

        lead = lead + 1

      end do

30    continue

      return
      end
      function r8mat_rms ( m, n, a )

c*********************************************************************72
c
cc R8MAT_RMS returns the RMS norm of an R8MAT.
c
c  Discussion:
c
c    An R8MAT is an array of R8 values.
c
c    The matrix RMS norm is defined as:
c
c      R8MAT_RMS = sqrt ( 
c        sum ( 1 <= J <= N ) sum ( 1 <= I <= M ) A(I,J)^2 / M / N ).
c
c  Licensing:
c
c    This code is distributed under the GNU LGPL license.
c
c  Modified:
c
c    14 December 2011
c
c  Author:
c
c    John Burkardt
c
c  Parameters:
c
c    Input, integer M, N, the dimensions of the matrix.
c
c    Input, double precision A(M,N), the matrix.
c
c    Output, double precision R8MAT_RMS, the RMS norm of A.
c
      implicit none

      integer m
      integer n

      double precision a(m,n)
      integer i
      integer j
      double precision r8mat_rms
      double precision value

      value = 0.0D+00

      do j = 1, n
        do i = 1, m
          value = value + a(i,j) * a(i,j)
        end do
      end do

      value = sqrt ( value / dble ( m ) / dble ( n ) )

      r8mat_rms = value

      return
      end
      subroutine r8mat_scale ( m, n, s, a )

c*********************************************************************72
c
cc R8MAT_SCALE multiplies an R8MAT by a scalar.
c
c  Discussion:
c
c    An R8MAT is an array of R8 values.
c
c  Licensing:
c
c    This code is distributed under the GNU LGPL license.
c
c  Modified:
c
c    01 December 2011
c
c  Author:
c
c    John Burkardt
c
c  Parameters:
c
c    Input, integer M, N, the number of rows and columns.
c
c    Input, double precision S, the scale factor.
c
c    Input/output, double precision A(M,N), the matrix to be scaled.
c
      implicit none

      integer m
      integer n

      double precision a(m,n)
      integer i
      integer j
      double precision s

      do j = 1, n
        do i = 1, m
          a(i,j) = a(i,j) * s
        end do
      end do

      return
      end
      subroutine r8mat_solve ( n, rhs_num, a, info )

c*********************************************************************72
c
cc R8MAT_SOLVE uses Gauss-Jordan elimination to solve an N by N linear system.
c
c  Discussion:
c
c    An R8MAT is an array of R8's.
c
c  Licensing:
c
c    This code is distributed under the GNU LGPL license.
c
c  Modified:
c
c    08 July 2009
c
c  Author:
c
c    John Burkardt
c
c  Parameters:
c
c    Input, integer N, the order of the matrix.
c
c    Input, integer RHS_NUM, the number of right hand sides.
c    RHS_NUM must be at least 0.
c
c    Input/output, double precision A(N,N+rhs_num), contains in rows and
c    columns 1 to N the coefficient matrix, and in columns N+1 through
c    N+rhs_num, the right hand sides.  On output, the coefficient matrix
c    area has been destroyed, while the right hand sides have
c    been overwritten with the corresponding solutions.
c
c    Output, integer INFO, singularity flag.
c    0, the matrix was not singular, the solutions were computed;
c    J, factorization failed on step J, and the solutions could not
c    be computed.
c
      implicit none

      integer n
      integer rhs_num

      double precision a(n,n+rhs_num)
      double precision apivot
      double precision factor
      integer i
      integer info
      integer ipivot
      integer j
      integer k

      info = 0

      do j = 1, n
c
c  Choose a pivot row.
c
        ipivot = j
        apivot = a(j,j)

        do i = j+1, n
          if ( abs ( apivot ) .lt. abs ( a(i,j) ) ) then
            apivot = a(i,j)
            ipivot = i
          end if
        end do

        if ( apivot .eq. 0.0D+00 ) then
          info = j
          return
        end if
c
c  Interchange.
c
        do i = 1, n + rhs_num
          call r8_swap ( a(ipivot,i), a(j,i) )
        end do
c
c  A(J,J) becomes 1.
c
        a(j,j) = 1.0D+00
        do k = j + 1, n + rhs_num
          a(j,k) = a(j,k) / apivot
        end do
c
c  A(I,J) becomes 0.
c
        do i = 1, n

          if ( i .ne. j ) then

            factor = a(i,j)
            a(i,j) = 0.0D+00
            do k = j + 1, n + rhs_num
              a(i,k) = a(i,k) - factor * a(j,k)
            end do

          end if

        end do

      end do

      return
      end
      subroutine r8mat_solve_2d ( a, b, det, x )

c*********************************************************************72
c
cc R8MAT_SOLVE_2D solves a 2 by 2 linear system using Cramer's rule.
c
c  Discussion:
c
c    An R8MAT is an array of R8's.
c
c    If DET is zero, then A is singular, and does not have an
c    inverse.  In that case, X is simply set to zero, and a
c    message is printed.
c
c    If DET is nonzero, then its value is roughly an estimate
c    of how nonsingular the matrix A is.
c
c  Licensing:
c
c    This code is distributed under the GNU LGPL license.
c
c  Modified:
c
c    08 July 2009
c
c  Author:
c
c    John Burkardt
c
c  Parameters:
c
c    Input, double precision A(2,2), the matrix.
c
c    Input, double precision B(2), the right hand side.
c
c    Output, double precision DET, the determinant of the matrix A.
c
c    Output, double precision X(2), the solution of the system,
c    if DET is nonzero.
c
      implicit none

      double precision a(2,2)
      double precision b(2)
      double precision det
      double precision x(2)
c
c  Compute the determinant.
c
      det = a(1,1) * a(2,2) - a(1,2) * a(2,1)
c
c  If the determinant is zero, bail out.
c
      if ( det .eq. 0.0D+00 ) then
        x(1) = 0.0D+00
        x(2) = 0.0D+00
        return
      end if
c
c  Compute the solution.
c
      x(1) = (  a(2,2) * b(1) - a(1,2) * b(2) ) / det
      x(2) = ( -a(2,1) * b(1) + a(1,1) * b(2) ) / det

      return
      end
      subroutine r8mat_solve_3d ( a, b, det, x )

c*********************************************************************72
c
cc R8MAT_SOLVE_3D solves a 3 by 3 linear system using Cramer's rule.
c
c  Discussion:
c
c    An R8MAT is an array of R8 values.
c
c    If the determinant DET is returned as zero, then the matrix A is
c    singular, and does not have an inverse.  In that case, X is
c    returned as the zero vector.
c
c    If DET is nonzero, then its value is roughly an estimate
c    of how nonsingular the matrix A is.
c
c  Licensing:
c
c    This code is distributed under the GNU LGPL license.
c
c  Modified:
c
c    15 May 2010
c
c  Author:
c
c    John Burkardt
c
c  Parameters:
c
c    Input, double precision A(3,3), the matrix.
c
c    Input, double precision B(3), the right hand side.
c
c    Output, double precision DET, the determinant of the matrix A.
c
c    Output, double precision X(3), the solution of the system,
c    if DET is nonzero.
c
      implicit none

      double precision a(3,3)
      double precision b(3)
      double precision det
      double precision x(3)
c
c  Compute the determinant.
c
      det =  a(1,1) * ( a(2,2) * a(3,3) - a(2,3) * a(3,2) )
     &     + a(1,2) * ( a(2,3) * a(3,1) - a(2,1) * a(3,3) )
     &     + a(1,3) * ( a(2,1) * a(3,2) - a(2,2) * a(3,1) )
c
c  If the determinant is zero, bail out.
c
      if ( det .eq. 0.0D+00 ) then
        x(1) = 0.0D+00
        x(2) = 0.0D+00
        x(3) = 0.0D+00
        return
      end if
c
c  Compute the solution.
c
      x(1) = (   ( a(2,2) * a(3,3) - a(2,3) * a(3,2) ) * b(1)
     &         - ( a(1,2) * a(3,3) - a(1,3) * a(3,2) ) * b(2)
     &         + ( a(1,2) * a(2,3) - a(1,3) * a(2,2) ) * b(3) ) / det

      x(2) = ( - ( a(2,1) * a(3,3) - a(2,3) * a(3,1) ) * b(1)
     &         + ( a(1,1) * a(3,3) - a(1,3) * a(3,1) ) * b(2)
     &         - ( a(1,1) * a(2,3) - a(1,3) * a(2,1) ) * b(3) ) / det

      x(3) = (   ( a(2,1) * a(3,2) - a(2,2) * a(3,1) ) * b(1)
     &         - ( a(1,1) * a(3,2) - a(1,2) * a(3,1) ) * b(2)
     &         + ( a(1,1) * a(2,2) - a(1,2) * a(2,1) ) * b(3) ) / det

      return
      end
      subroutine r8mat_solve2 ( n, a, b, x, ierror )

c*********************************************************************72
c
cc R8MAT_SOLVE2 computes the solution of an N by N linear system.
c
c  Discussion:
c
c    An R8MAT is an array of R8 values.
c
c    The linear system may be represented as
c
c      A*X = B
c
c    If the linear system is singular, but consistent, then the routine will
c    still produce a solution.
c
c  Licensing:
c
c    This code is distributed under the GNU LGPL license.
c
c  Modified:
c
c    19 August 2010
c
c  Author:
c
c    John Burkardt
c
c  Parameters:
c
c    Input, integer N, the number of equations.
c
c    Input/output, double precision A(N,N).
c    On input, A is the coefficient matrix to be inverted.
c    On output, A has been overwritten.
c
c    Input/output, double precision B(N).
c    On input, B is the right hand side of the system.
c    On output, B has been overwritten.
c
c    Output, double precision X(N), the solution of the linear system.
c
c    Output, integer IERROR.
c    0, no error detected.
c    1, consistent singularity.
c    2, inconsistent singularity.
c
      implicit none

      integer n

      double precision a(n,n)
      double precision amax
      double precision b(n)
      integer i
      integer ierror
      integer imax
      integer ipiv(n)
      integer j
      integer k
      double precision x(n)

      ierror = 0

      do i = 1, n
        ipiv(i) = 0
      end do

      do i = 1, n
        x(i) = 0.0D+00
      end do
c
c  Process the matrix.
c
      do k = 1, n
c
c  In column K:
c    Seek the row IMAX with the properties that:
c      IMAX has not already been used as a pivot;
c      A(IMAX,K) is larger in magnitude than any other candidate.
c
        amax = 0.0D+00
        imax = 0
        do i = 1, n
          if ( ipiv(i) .eq. 0 ) then
            if ( amax .lt. abs ( a(i,k) ) ) then
              imax = i
              amax = abs ( a(i,k) )
            end if
          end if
        end do
c
c  If you found a pivot row IMAX, then,
c    eliminate the K-th entry in all rows that have not been used for pivoting.
c
        if ( imax .ne. 0 ) then

          ipiv(imax) = k
          do j = k + 1, n
            a(imax,j) = a(imax,j) / a(imax,k)
          end do
          b(imax) = b(imax) / a(imax,k)
          a(imax,k) = 1.0D+00

          do i = 1, n

            if ( ipiv(i) .eq. 0 ) then
              do j = k + 1, n
                a(i,j) = a(i,j) - a(i,k) * a(imax,j)
              end do
              b(i) = b(i) - a(i,k) * b(imax)
              a(i,k) = 0.0D+00
            end if

          end do

        end if

      end do
c
c  Now, every row with nonzero IPIV begins with a 1, and
c  all other rows are all zero.  Begin solution.
c
      do j = n, 1, -1

        imax = 0
        do k = 1, n
          if ( ipiv(k) .eq. j ) then
            imax = k
          end if
        end do

        if ( imax .eq. 0 ) then

          x(j) = 0.0D+00

          if ( b(j) .eq. 0.0D+00 ) then
            ierror = 1
            write ( *, '(a)' ) ' '
            write ( *, '(a)' ) 'R8MAT_SOLVE2 - Warning:'
            write ( *, '(a,i8)' )
     &        '  Consistent singularity, equation = ', j
          else
            ierror = 2
            write ( *, '(a)' ) ' '
            write ( *, '(a)' ) 'R8MAT_SOLVE2 - Error:'
            write ( *, '(a,i8)' )
     &        '  Inconsistent singularity, equation = ', j
          end if

        else

          x(j) = b(imax)

          do i = 1, n
            if ( i .ne. imax ) then
              b(i) = b(i) - a(i,j) * x(j)
            end if
          end do

        end if

      end do

      return
      end
      function r8mat_sum ( m, n, a )

c*********************************************************************72
c
cc R8MAT_SUM sums the entries of an R8MAT.
c
c  Discussion:
c
c    An R8MAT is an array of R8 values.
c
c  Licensing:
c
c    This code is distributed under the GNU LGPL license.
c
c  Modified:
c
c    04 January 2012
c
c  Author:
c
c    John Burkardt
c
c  Parameters:
c
c    Input, integer M, N, the number of rows and columns.
c
c    Input, double precision A(M,N), the array.
c
c    Output, double precision R8MAT_SUM, the sum of the entries.
c
      implicit none

      integer m
      integer n

      double precision a(m,n)
      integer i
      integer j
      double precision r8mat_sum
      double precision value

      value = 0.0D+00
      do j = 1, n
        do i = 1, m
          value = value + a(i,j)
        end do
      end do

      r8mat_sum = value

      return
      end
      subroutine r8mat_symm_eigen ( n, x, q, a )

c*********************************************************************72
c
cc R8MAT_SYMM_EIGEN returns a symmetric matrix with given eigensystem.
c
c  Discussion:
c
c    An R8MAT is an array of R8 values.
c
c    The user must supply the desired eigenvalue vector, and the desired
c    eigenvector matrix.  The eigenvector matrix must be orthogonal.  A
c    suitable random orthogonal matrix can be generated by R8MAT_ORTH_UNIFORM.
c
c  Licensing:
c
c    This code is distributed under the GNU LGPL license.
c
c  Modified:
c
c    15 May 2010
c
c  Author:
c
c    John Burkardt
c
c  Parameters:
c
c    Input, integer N, the order of A.
c
c    Input, double precision X(N), the desired eigenvalues for the matrix.
c
c    Input, double precision Q(N,N), the eigenvector matrix of A.
c
c    Output, double precision A(N,N), a symmetric matrix with
c    eigenvalues X and eigenvectors the columns of Q.
c
      implicit none

      integer n

      double precision a(n,n)
      integer i
      integer j
      integer k
      double precision q(n,n)
      double precision x(n)
c
c  Set A = Q * Lambda * Q'.
c
      do i = 1, n
        do j = 1, n
          a(i,j) = 0.0D+00
          do k = 1, n
            a(i,j) = a(i,j) + q(i,k) * x(k) * q(j,k)
          end do
        end do
      end do

      return
      end
      subroutine r8mat_symm_jacobi ( n, a )

c*********************************************************************72
c
cc R8MAT_SYMM_JACOBI applies Jacobi eigenvalue iteration to a symmetric matrix.
c
c  Discussion:
c
c    An R8MAT is an array of R8 values.
c
c    This code was modified so that it treats as zero the off-diagonal
c    elements that are sufficiently close to, but not exactly, zero.
c
c  Licensing:
c
c    This code is distributed under the GNU LGPL license.
c
c  Modified:
c
c    22 November 2011
c
c  Author:
c
c    John Burkardt
c
c  Parameters:
c
c    Input, integer N, the order of A.
c
c    Input/output, double precision A(N,N), a symmetric N by N matrix.
c    On output, the matrix has been overwritten by an approximately
c    diagonal matrix, with the eigenvalues on the diagonal.
c
      implicit none

      integer n

      double precision a(n,n)
      double precision c
      double precision r8mat_norm_fro
      double precision eps
      parameter ( eps = 0.00001D+00 )
      integer i
      integer it
      integer it_max
      parameter ( it_max = 100 )
      integer j
      integer k
      double precision norm_fro
      double precision s
      double precision sum2
      double precision t
      double precision t1
      double precision t2
      double precision u

      norm_fro = r8mat_norm_fro ( n, n, a )

      it = 0

10    continue

        it = it + 1

        do i = 1, n
          do j = 1, i - 1

            if ( eps * norm_fro .lt. 
     &           abs ( a(i,j) ) + abs ( a(j,i) ) ) then

              u = ( a(j,j) - a(i,i) ) / ( a(i,j) + a(j,i) )

              t = sign ( 1.0D+00, u ) 
     &          / ( abs ( u ) + sqrt ( u * u + 1.0D+00 ) )
              c = 1.0D+00 / sqrt ( t * t + 1.0D+00 )
              s = t * c
c
c  A -> A * Q.
c
              do k = 1, n
                t1 = a(i,k)
                t2 = a(j,k)
                a(i,k) = t1 * c - t2 * s
                a(j,k) = t1 * s + t2 * c
              end do
c
c  A -> QT * A
c
              do k = 1, n
                t1 = a(k,i)
                t2 = a(k,j)
                a(k,i) = c * t1 - s * t2
                a(k,j) = s * t1 + c * t2
              end do

            end if
          end do
        end do
c
c  Test the size of the off-diagonal elements.
c
        sum2 = 0.0D+00
        do i = 1, n
          do j = 1, i - 1
            sum2 = sum2 + abs ( a(i,j) )
          end do
        end do

        if ( sum2 .le. eps * ( norm_fro + 1.0D+00 ) ) then
          go to 20
        end if

        if ( it_max .le. it ) then
          go to 20
        end if

      go to 10

20    continue

      return
      end
      function r8mat_trace ( n, a )

c*********************************************************************72
c
cc R8MAT_TRACE computes the trace of an R8MAT.
c
c  Discussion:
c
c    An R8MAT is an array of R8 values.
c
c    The trace of a square matrix is the sum of the diagonal elements.
c
c  Licensing:
c
c    This code is distributed under the GNU LGPL license.
c
c  Modified:
c
c    15 May 2010
c
c  Author:
c
c    John Burkardt
c
c  Parameters:
c
c    Input, integer N, the order of the matrix A.
c
c    Input, double precision A(N,N), the matrix whose trace is desired.
c
c    Output, double precision R8MAT_TRACE, the trace of the matrix.
c
      implicit none

      integer n

      double precision a(n,n)
      integer i
      double precision r8mat_trace

      r8mat_trace = 0.0D+00
      do i = 1, n
        r8mat_trace = r8mat_trace + a(i,i)
      end do

      return
      end
      subroutine r8mat_transpose ( m, n, a, at )

c*********************************************************************72
c
cc R8MAT_TRANSPOSE makes a transposed copy of a matrix.
c
c  Discussion:
c
c    An R8MAT is an array of R8's.
c
c  Licensing:
c
c    This code is distributed under the GNU LGPL license.
c
c  Modified:
c
c    13 June 2011
c
c  Author:
c
c    John Burkardt
c
c  Parameters:
c
c    Input, integer M, N, the number of rows and columns of the matrix A.
c
c    Input, double precision A(N,N), the matrix to be transposed.
c
c    Output, double precision AT(N,M), the matrix to be transposed.
c
      implicit none

      integer m
      integer n

      double precision a(m,n)
      double precision at(n,m)
      integer i
      integer j

      do j = 1, m
        do i = 1, n
          at(i,j) = a(j,i)
        end do
      end do

      return
      end
      subroutine r8mat_transpose_in_place ( n, a )

c*********************************************************************72
c
cc R8MAT_TRANSPOSE_IN_PLACE transposes a square matrix in place.
c
c  Discussion:
c
c    An R8MAT is an array of R8's.
c
c  Licensing:
c
c    This code is distributed under the GNU LGPL license.
c
c  Modified:
c
c    27 June 2008
c
c  Author:
c
c    John Burkardt
c
c  Parameters:
c
c    Input, integer N, the number of rows and columns of the matrix A.
c
c    Input/output, double precision A(N,N), the matrix to be transposed.
c
      implicit none

      integer n

      double precision a(n,n)
      integer i
      integer j
      double precision t

      do j = 1, n
        do i = 1, j - 1
          t      = a(i,j)
          a(i,j) = a(j,i)
          a(j,i) = t
        end do
      end do

      return
      end
      subroutine r8mat_transpose_print ( m, n, a, title )

c*********************************************************************72
c
cc R8MAT_TRANSPOSE_PRINT prints an R8MAT, transposed.
c
c  Discussion:
c
c    An R8MAT is an array of R8's.
c
c  Licensing:
c
c    This code is distributed under the GNU LGPL license.
c
c  Modified:
c
c    28 April 2008
c
c  Author:
c
c    John Burkardt
c
c  Parameters:
c
c    Input, integer M, N, the number of rows and columns.
c
c    Input, double precision A(M,N), an M by N matrix to be printed.
c
c    Input, character*(*) TITLE, a title.
c
      implicit none

      integer m
      integer n

      double precision a(m,n)
      character*(*) title

      call r8mat_transpose_print_some ( m, n, a, 1, 1, m, n, title )

      return
      end
      subroutine r8mat_transpose_print_some ( m, n, a, ilo, jlo, ihi,
     &  jhi, title )

c*********************************************************************72
c
cc R8MAT_TRANSPOSE_PRINT_SOME prints some of an R8MAT transposed.
c
c  Discussion:
c
c    An R8MAT is an array of R8's.
c
c  Licensing:
c
c    This code is distributed under the GNU LGPL license.
c
c  Modified:
c
c    28 April 2008
c
c  Author:
c
c    John Burkardt
c
c  Parameters:
c
c    Input, integer M, N, the number of rows and columns.
c
c    Input, double precision A(M,N), an M by N matrix to be printed.
c
c    Input, integer ILO, JLO, the first row and column to print.
c
c    Input, integer IHI, JHI, the last row and column to print.
c
c    Input, character * ( * ) TITLE, a title.
c
      implicit none

      integer incx
      parameter ( incx = 5 )
      integer m
      integer n

      double precision a(m,n)
      character * ( 14 ) ctemp(incx)
      integer i
      integer i2
      integer i2hi
      integer i2lo
      integer ihi
      integer ilo
      integer inc
      integer j
      integer j2hi
      integer j2lo
      integer jhi
      integer jlo
      character * ( * ) title

      write ( *, '(a)' ) ' '
      write ( *, '(a)' ) trim ( title )

      if ( m .le. 0 .or. n .le. 0 ) then
        write ( *, '(a)' ) ' '
        write ( *, '(a)' ) '  (None)'
        return
      end if

      do i2lo = max ( ilo, 1 ), min ( ihi, m ), incx

        i2hi = i2lo + incx - 1
        i2hi = min ( i2hi, m )
        i2hi = min ( i2hi, ihi )

        inc = i2hi + 1 - i2lo

        write ( *, '(a)' ) ' '

        do i = i2lo, i2hi
          i2 = i + 1 - i2lo
          write ( ctemp(i2), '(i8,6x)') i
        end do

        write ( *, '(''       Row'',5a14)' ) ctemp(1:inc)
        write ( *, '(a)' ) '       Col'

        j2lo = max ( jlo, 1 )
        j2hi = min ( jhi, n )

        do j = j2lo, j2hi

          do i2 = 1, inc
            i = i2lo - 1 + i2
            write ( ctemp(i2), '(g14.6)' ) a(i,j)
          end do

          write ( *, '(2x,i8,a,5a14)' ) j, ':', ( ctemp(i), i = 1, inc )

        end do

      end do

      return
      end
      subroutine r8mat_u_inverse ( n, a, b )

c*********************************************************************72
c
cc R8MAT_U_INVERSE inverts an upper triangular R8MAT.
c
c  Discussion:
c
c    An R8MAT is an array of R8 values.
c
c    An upper triangular matrix is a matrix whose only nonzero entries
c    occur on or above the diagonal.
c
c    The inverse of an upper triangular matrix is an upper triangular matrix.
c
c  Licensing:
c
c    This code is distributed under the GNU LGPL license.
c
c  Modified:
c
c    15 May 2010
c
c  Author:
c
c    John Burkardt
c
c  Reference:
c
c    Albert Nijenhuis, Herbert Wilf,
c    Combinatorial Algorithms for Computers and Calculators,
c    Academic Press, 1978,
c    ISBN: 0-12-519260-6,
c    LC: QA164.N54.
c
c  Parameters:
c
c    Input, integer N, number of rows and columns in the matrix.
c
c    Input, double precision A(N,N), the upper triangular matrix.
c
c    Output, double precision B(N,N), the inverse matrix.
c
      implicit none

      integer n

      double precision a(n,n)
      double precision b(n,n)
      integer i
      integer j
      integer k

      do j = n, 1, -1

        do i = n, 1, -1

          if ( j .lt. i ) then
            b(i,j) = 0.0D+00
          else if ( i .eq. j ) then
            b(i,j) = 1.0D+00 / a(i,j)
          else
            b(i,j) = 0.0D+00
            do k = i + 1, j
              b(i,j) = b(i,j) - a(i,k) * b(k,j)
            end do
            b(i,j) = b(i,j) / a(i,i)
          end if

        end do
      end do

      return
      end
      subroutine r8mat_u1_inverse ( n, a, b )

c*********************************************************************72
c
cc R8MAT_U1_INVERSE inverts a unit upper triangular R8MAT.
c
c  Discussion:
c
c    An R8MAT is an array of R8 values.
c
c    A unit upper triangular matrix is a matrix with only 1's on the main
c    diagonal, and only 0's below the main diagonal.
c
c    The inverse of a unit upper triangular matrix is also
c    a unit upper triangular matrix.
c
c    This routine can invert a matrix in place, that is, with no extra
c    storage.  If the matrix is stored in A, then the call
c
c      call r8mat_u1_inverse ( n, a, a )
c
c    will result in A being overwritten by its inverse.
c
c  Licensing:
c
c    This code is distributed under the GNU LGPL license.
c
c  Modified:
c
c    16 May 2010
c
c  Author:
c
c    Original FORTRAN77 version by Albert Nijenhuis, Herbert Wilf.
c    FORTRAN90 version by John Burkardt.
c
c  Reference:
c
c    Albert Nijenhuis, Herbert Wilf,
c    Combinatorial Algorithms for Computers and Calculators,
c    Academic Press, 1978,
c    ISBN: 0-12-519260-6,
c    LC: QA164.N54.
c
c  Parameters:
c
c    Input, integer N, number of rows and columns in the matrix.
c
c    Input, double precision A(N,N), the unit upper triangular matrix.
c
c    Output, double precision B(N,N), the inverse matrix.
c
      implicit none

      integer n

      double precision a(n,n)
      double precision b(n,n)
      integer i
      integer j
      integer k

      do j = n, 1, -1

        do i = n, 1, -1

          if ( j .lt. i ) then
            b(i,j) = 0.0D+00
          else if ( i .eq. j ) then
            b(i,j) = 1.0D+00
          else
            b(i,j) = 0.0D+00
            do k = i + 1, j
              b(i,j) = b(i,j) - a(i,k) * b(k,j)
            end do
          end if

        end do
      end do

      return
      end
      subroutine r8mat_uniform_01 ( m, n, seed, r )

c*********************************************************************72
c
cc R8MAT_UNIFORM_01 returns a unit pseudorandom R8MAT.
c
c  Discussion:
c
c    An R8MAT is an array of R8's.
c
c  Licensing:
c
c    This code is distributed under the GNU LGPL license.
c
c  Modified:
c
c    11 August 2004
c
c  Author:
c
c    John Burkardt
c
c  Reference:
c
c    Paul Bratley, Bennett Fox, Linus Schrage,
c    A Guide to Simulation,
c    Springer Verlag, pages 201-202, 1983.
c
c    Bennett Fox,
c    Algorithm 647:
c    Implementation and Relative Efficiency of Quasirandom
c    Sequence Generators,
c    ACM Transactions on Mathematical Software,
c    Volume 12, Number 4, pages 362-376, 1986.
c
c    Peter Lewis, Allen Goodman, James Miller,
c    A Pseudo-Random Number Generator for the System/360,
c    IBM Systems Journal,
c    Volume 8, pages 136-143, 1969.
c
c  Parameters:
c
c    Input, integer M, N, the number of rows and columns in the array.
c
c    Input/output, integer SEED, the "seed" value, which should NOT be 0.
c    On output, SEED has been updated.
c
c    Output, double precision R(M,N), the array of pseudorandom values.
c
      implicit none

      integer m
      integer n

      integer i
      integer j
      integer k
      integer seed
      double precision r(m,n)

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

      do j = 1, n

        do i = 1, m

          k = seed / 127773

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

          if ( seed .lt. 0 ) then
            seed = seed + 2147483647
          end if

          r(i,j) = dble ( seed ) * 4.656612875D-10

        end do
      end do

      return
      end
      subroutine r8mat_uniform_ab ( m, n, a, b, seed, r )

c*********************************************************************72
c
cc R8MAT_UNIFORM_AB returns a scaled pseudorandom R8MAT.
c
c  Discussion:
c
c    A <= R(I,J) <= B.
c
c  Licensing:
c
c    This code is distributed under the GNU LGPL license. 
c
c  Modified:
c
c    05 February 2005
c
c  Author:
c
c    John Burkardt
c
c  Reference:
c
c    Paul Bratley, Bennett Fox, Linus Schrage,
c    A Guide to Simulation,
c    Second Edition,
c    Springer, 1987,
c    ISBN: 0387964673,
c    LC: QA76.9.C65.B73.
c
c    Bennett Fox,
c    Algorithm 647:
c    Implementation and Relative Efficiency of Quasirandom
c    Sequence Generators,
c    ACM Transactions on Mathematical Software,
c    Volume 12, Number 4, December 1986, pages 362-376.
c
c    Pierre L'Ecuyer,
c    Random Number Generation,
c    in Handbook of Simulation,
c    edited by Jerry Banks,
c    Wiley, 1998,
c    ISBN: 0471134031,
c    LC: T57.62.H37.
c
c    Peter Lewis, Allen Goodman, James Miller,
c    A Pseudo-Random Number Generator for the System/360,
c    IBM Systems Journal,
c    Volume 8, Number 2, 1969, pages 136-143.
c
c  Parameters:
c
c    Input, integer M, N, the number of rows and columns in the array.
c
c    Input, double precision A, B, the lower and upper limits.
c
c    Input/output, integer SEED, the "seed" value, which should NOT be 0.
c    On output, SEED has been updated.
c
c    Output, double precision R(M,N), the array of pseudorandom values.
c
      implicit none

      integer m
      integer n

      double precision a
      double precision b
      integer i
      integer i4_huge
      parameter ( i4_huge = 2147483647 )
      integer j
      integer k
      integer seed
      double precision r(m,n)

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

      do j = 1, n

        do i = 1, m

          k = seed / 127773

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

          if ( seed .lt. 0 ) then
            seed = seed + i4_huge
          end if

          r(i,j) = a + ( b - a ) * dble ( seed ) * 4.656612875D-10

        end do
      end do

      return
      end
      subroutine r8mat_uniform_abvec ( m, n, a, b, seed, r )

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

      integer m
      integer n

      double precision a(m)
      double precision b(m)
      integer i
      integer i4_huge
      parameter ( i4_huge = 2147483647 )
      integer j
      integer k
      integer seed
      double precision r(m,n)

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

      do j = 1, n

        do i = 1, m

          k = seed / 127773

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

          if ( seed .lt. 0 ) then
            seed = seed + i4_huge
          end if

          r(i,j) = a(i) + ( b(i) - a(i) ) * dble ( seed ) 
     &      * 4.656612875D-10

        end do
      end do

      return
      end
      subroutine r8mat_vand2 ( n, x, a )

c*********************************************************************72
c
cc R8MAT_VAND2 returns the N by N row Vandermonde matrix A.
c
c  Discussion:
c
c    An R8MAT is an array of R8 values.
c
c    The row Vandermonde matrix returned by this routine reads "across"
c    rather than down.  In particular, each row begins with a 1, followed by
c    some value X, followed by successive powers of X.
c
c  Formula:
c
c    A(I,J) = X(I)**(J-1)
c
c  Properties:
c
c    A is nonsingular if, and only if, the X values are distinct.
c
c    The determinant of A is
c
c      det(A) = product ( 2 <= I <= N ) (
c        product ( 1 <= J <= I-1 ) ( ( X(I) - X(J) ) ) ).
c
c    The matrix A is generally ill-conditioned.
c
c  Example:
c
c    N = 5, X = (2, 3, 4, 5, 6)
c
c    1 2  4   8   16
c    1 3  9  27   81
c    1 4 16  64  256
c    1 5 25 125  625
c    1 6 36 216 1296
c
c  Licensing:
c
c    This code is distributed under the GNU LGPL license.
c
c  Modified:
c
c    16 May 2010
c
c  Author:
c
c    John Burkardt
c
c  Parameters:
c
c    Input, integer N, the order of the matrix desired.
c
c    Input, double precision X(N), the values that define A.
c
c    Output, double precision A(N,N), the N by N row Vandermonde matrix.
c
      implicit none

      integer n

      double precision a(n,n)
      integer i
      integer j
      double precision x(n)

      do i = 1, n
        do j = 1, n

          if ( j .eq. 1 .and. x(i) .eq. 0.0D+00 ) then
            a(i,j) = 1.0D+00
          else
            a(i,j) = x(i)**(j-1)
          end if

        end do
      end do

      return
      end
      subroutine r8mat_zero ( m, n, a )

c*********************************************************************72
c
cc R8MAT_ZERO zeroes an R8MAT.
c
c  Discussion:
c
c    An R8MAT is an array of R8 values.
c
c  Licensing:
c
c    This code is distributed under the GNU LGPL license.
c
c  Modified:
c
c    18 July 2010
c
c  Author:
c
c    John Burkardt
c
c  Parameters:
c
c    Input, integer M, N, the number of rows and columns.
c
c    Output, double precision A(M,N), the matrix of zeroes.
c
      implicit none

      integer m
      integer n

      double precision a(m,n)
      integer i
      integer j

      do j = 1, n
        do i = 1, m
          a(i,j) = 0.0D+00
        end do
      end do

      return
      end
      subroutine r8plu_det ( n, pivot, lu, det )

c*********************************************************************72
c
cc R8PLU_DET computes the determinant of an R8PLU matrix.
c
c  Discussion:
c
c    The matrix should have been factored by R8MAT_TO_R8PLU.
c
c  Licensing:
c
c    This code is distributed under the GNU LGPL license.
c
c  Modified:
c
c    16 May 2010
c
c  Author:
c
c    John Burkardt
c
c  Reference:
c
c    Jack Dongarra, Jim Bunch, Cleve Moler, Pete Stewart,
c    LINPACK User's Guide,
c    SIAM, 1979,
c    ISBN13: 978-0-898711-72-1.
c
c  Parameters:
c
c    Input, integer N, the order of the matrix.
c    N must be positive.
c
c    Input, integer PIVOT(N), the pivot vector computed
c    by R8MAT_TO_R8PLU.
c
c    Input, double precision LU(N,N), the LU factors computed
c    by R8MAT_TO_R8PLU.
c
c    Output, double precision DET, the determinant of the matrix.
c
      implicit none

      integer n

      double precision det
      integer i
      double precision lu(n,n)
      integer pivot(n)

      det = 1.0D+00

      do i = 1, n
        det = det * lu(i,i)
        if ( pivot(i) .ne. i ) then
          det = - det
        end if
      end do

      return
      end
      subroutine r8poly_degree ( na, a, degree )

c*********************************************************************72
c
cc R8POLY_DEGREE returns the degree of a polynomial.
c
c  Discussion:
c
c    The degree of a polynomial is the index of the highest power
c    of X with a nonzero coefficient.
c
c    The degree of a constant polynomial is 0.  The degree of the
c    zero polynomial is debatable, but this routine returns the
c    degree as 0.
c
c  Licensing:
c
c    This code is distributed under the GNU LGPL license.
c
c  Modified:
c
c    21 March 2001
c
c  Author:
c
c    John Burkardt
c
c  Parameters:
c
c    Input, integer NA, the dimension of A.
c
c    Input, double precision A(0:NA), the coefficients of the polynomials.
c
c    Output, integer DEGREE, the degree of A.
c
      implicit none

      integer na

      double precision a(0:na)
      integer degree

      degree = na

10    continue

      if ( 0 .lt. degree ) then

        if ( a(degree) .ne. 0.0D+00 ) then
          return
        end if

        degree = degree - 1

        go to 10

      end if

      return
      end
      subroutine r8poly_order ( na, a, order )

c*********************************************************************72
c
cc R8POLY_ORDER returns the order of a polynomial.
c
c  Discussion:
c
c    The order of a polynomial is one more than the degree.
c
c    The order of a constant polynomial is 1.  The order of the
c    zero polynomial is debatable, but this routine returns the
c    order as 1.
c
c  Licensing:
c
c    This code is distributed under the GNU LGPL license.
c
c  Modified:
c
c    02 December 2011
c
c  Author:
c
c    John Burkardt
c
c  Parameters:
c
c    Input, integer NA, the dimension of A.
c
c    Input, double precision A(0:NA), the coefficients of the polynomials.
c
c    Output, integer ORDER, the order of A.
c
      implicit none

      integer na

      double precision a(0:na)
      integer order

      order = na + 1

10    continue

      if ( 1 .lt. order ) then

        if ( a(order-1) .ne. 0.0D+00 ) then
          return
        end if

        order = order - 1

        go to 10

      end if

      return
      end
      subroutine r8poly_print ( n, a, title )

c*********************************************************************72
c
cc R8POLY_PRINT prints out a polynomial.
c
c  Licensing:
c
c    This code is distributed under the GNU LGPL license.
c
c  Modified:
c
c    22 July 2010
c
c  Author:
c
c    John Burkardt
c
c  Parameters:
c
c    Input, integer N, the dimension of A.
c
c    Input, double precision A(0:N), the polynomial coefficients.
c    A(0) is the constant term and
c    A(N) is the coefficient of X**N.
c
c    Input, character * ( * ) TITLE, a title.
c
      implicit none

      integer n

      double precision a(0:n)
      integer i
      double precision mag
      integer n2
      character plus_minus
      character * ( * )  title

      write ( *, '(a)' ) ' '
      write ( *, '(a)' ) trim ( title )
      write ( *, '(a)' ) ' '

      call r8poly_degree ( n, a, n2 )

      if ( n2 .le. 0 ) then
        write ( *, '( ''  p(x) = 0'' )' )
        return
      end if

      if ( a(n2) .lt. 0.0D+00 ) then
        plus_minus = '-'
      else
        plus_minus = ' '
      end if

      mag = abs ( a(n2) )

      if ( 2 .le. n2 ) then
        write ( *, '( ''  p(x) = '', a1, g14.6, '' * x ^ '', i3 )' )
     &    plus_minus, mag, n2
      else if ( n2 .eq. 1 ) then
        write ( *, '( ''  p(x) = '', a1, g14.6, '' * x'' )' )
     &    plus_minus, mag
      else if ( n2 .eq. 0 ) then
        write ( *, '( ''  p(x) = '', a1, g14.6 )' ) plus_minus, mag
      end if

      do i = n2 - 1, 0, -1

        if ( a(i) .lt. 0.0D+00 ) then
          plus_minus = '-'
        else
          plus_minus = '+'
        end if

        mag = abs ( a(i) )

        if ( mag .ne. 0.0D+00 ) then

          if ( 2 .le. i ) then
            write ( *,
     &        ' ( ''         '', a1, g14.6, '' * x ^ '', i3 )' )
     &        plus_minus, mag, i
          else if ( i .eq. 1 ) then
            write ( *,
     &        ' ( ''         '', a1, g14.6, '' * x'' )' )
     &        plus_minus, mag
          else if ( i .eq. 0 ) then
            write ( *, ' ( ''         '', a1, g14.6 )' )
     &        plus_minus, mag
          end if
        end if

      end do

      return
      end
      subroutine r8poly_shift ( scale, shift, n, poly_cof )

c*********************************************************************72
c
cc R8POLY_SHIFT adjusts the coefficients of a polynomial for a new argument.
c
c  Discussion:
c
c    Assuming P(X) is a polynomial in the argument X, of the form:
c
c      P(X) =
c          C(N) * X^N
c        + ...
c        + C(1) * X
c        + C(0),
c
c    and that Z is related to X by the formula:
c
c      Z = SCALE * X + SHIFT
c
c    then this routine computes coefficients C for the polynomial Q(Z):
c
c      Q(Z) =
c          C(N) * Z^N
c        + ...
c        + C(1) * Z
c        + C(0)
c
c    so that:
c
c      Q(Z(X)) = P(X)
c
c  Example:
c
c    P(X) = 2 * X^2 - X + 6
c
c    Z = 2.0 * X + 3.0
c
c    Q(Z) = 0.5 *         Z^2 -  3.5 * Z + 12
c
c    Q(Z(X)) = 0.5 * ( 4.0 * X^2 + 12.0 * X +  9 )
c            - 3.5 * (              2.0 * X +  3 )
c                                           + 12
c
c            = 2.0         * X^2 -  1.0 * X +  6
c
c            = P(X)
c
c  Licensing:
c
c    This code is distributed under the GNU LGPL license.
c
c  Modified:
c
c    02 December 2011
c
c  Reference:
c
c    William Press, Brian Flannery, Saul Teukolsky, William Vetterling,
c    Numerical Recipes: The Art of Scientific Computing,
c    Cambridge University Press.
c
c  Parameters:
c
c    Input, double precision SHIFT, SCALE, the shift and scale applied to X,
c    so that Z = SCALE * X + SHIFT.
c
c    Input, integer N, the number of coefficients.
c
c    Input/output, double precision POLY_COF(0:N).
c    On input, the coefficient array in terms of the X variable.
c    On output, the coefficient array in terms of the Z variable.
c
      implicit none

      integer n

      integer i
      integer j
      double precision poly_cof(0:n)
      double precision scale
      double precision shift

      do i = 1, n
        do j = i, n
          poly_cof(j) = poly_cof(j) / scale
        end do
      end do

      do i = 0, n - 1
        do j = n - 1, i, -1
          poly_cof(j) = poly_cof(j) - shift * poly_cof(j+1)
        end do
      end do

      return
      end
      subroutine r8poly_value ( m, c, n, x, p )

c*********************************************************************72
c
cc R8POLY_VALUE evaluates a polynomial.
c
c  Discussion:
c
c    The polynomial 
c
c      p(x) = c1 + c2 * x + c3 * x^2 + ... + cm * x^(m-1)
c
c    is to be evaluated at the vector of values X.
c
c  Licensing:
c
c    This code is distributed under the GNU LGPL license.
c
c  Modified:
c
c    21 September 2012
c
c  Author:
c
c    John Burkardt
c
c  Parameters:
c
c    Input, integer M, the degree.
c
c    Input, double precision C(0:M), the polynomial coefficients.  
c    C(1) is the constant term.
c
c    Input, integer N, the number of evaluation points.
c
c    Input, double precision X(N), the evaluation points.
c
c    Output, double precision P(N), the value of the polynomial at the 
c    evaluation points.
c
      implicit none

      integer m
      integer n

      double precision c(0:m)
      integer i
      integer j
      double precision p(n)
      double precision x(n)

      do j = 1, n
        p(j) = c(m)
      end do

      do i = m - 1, 0, -1
        do j = 1, n 
          p(j) = p(j) * x(j) + c(i)
        end do
      end do

      return
      end
      subroutine r8poly_value_horner ( n, c, x, cx )

c*********************************************************************72
c
cc R8POLY_VALUE_HORNER evaluates a polynomial using Horner's method.
c
c  Licensing:
c
c    This code is distributed under the GNU LGPL license.
c
c  Modified:
c
c    08 August 1999
c
c  Author:
c
c    John Burkardt
c
c  Parameters:
c
c    Input, integer N, the dimension of C.
c
c    Input, double precision C(0:N), the polynomial coefficients.
c    C(I) is the coefficient of X^I.
c
c    Input, double precision X, the point at which the polynomial is
c    to be evaluated.
c
c    Output, double precision CX, the value of the polynomial at X.
c
      implicit none

      integer n

      double precision c(0:n)
      double precision cx
      integer i
      double precision x

      cx = c(n)
      do i = n - 1, 0, -1
        cx = cx * x + c(i)
      end do

      return
      end
      function r8poly_value_old ( n, a, x )

c*********************************************************************72
c
cc R8POLY_VALUE_OLD evaluates an R8POLY
c
c  Discussion:
c
c    For sanity's sake, the value of N indicates the NUMBER of
c    coefficients, or more precisely, the ORDER of the polynomial,
c    rather than the DEGREE of the polynomial.  The two quantities
c    differ by 1, but cause a great deal of confusion.
c
c    Given N and A, the form of the polynomial is:
c
c      p(x) = a(1) + a(2) * x + ... + a(n-1) * x^(n-2) + a(n) * x^(n-1)
c
c  Licensing:
c
c    This code is distributed under the GNU LGPL license.
c
c  Modified:
c
c    05 August 2010
c
c  Author:
c
c    John Burkardt
c
c  Parameters:
c
c    Input, integer N, the order of the polynomial.
c
c    Input, double precision A(N), the coefficients of the polynomial.
c    A(1) is the constant term.
c
c    Input, double precision X, the point at which the polynomial is
c    to be evaluated.
c
c    Output, double precision R8POLY_VALUE_OLD, the value of the polynomial at X.
c
      implicit none

      integer n

      double precision a(n)
      integer i
      double precision r8poly_value_old
      double precision x

      r8poly_value_old = a(n)
      do i = n - 1, 1, -1
        r8poly_value_old = r8poly_value_old * x + a(i)
      end do

      return
      end
      subroutine r8poly_value_2d ( m, c, n, x, y, p )

c*********************************************************************72
c
cc R8POLY_VALUE_2D evaluates a polynomial in 2 variables, X and Y.
c
c  Discussion:
c
c    We assume the polynomial is of total degree M, and has the form:
c
c      p(x,y) = c00 
c             + c10 * x                + c01 * y
c             + c20 * x^2   + c11 * xy + c02 * y^2
c             + ...
c             + cm0 * x^(m) + ...      + c0m * y^m.
c
c  Licensing:
c
c    This code is distributed under the GNU LGPL license.
c
c  Modified:
c
c    23 September 2012
c
c  Author:
c
c    John Burkardt
c
c  Parameters:
c
c    Input, integer M, the degree of the polynomial.
c
c    Input, double precision C(T(M+1)), the polynomial coefficients.  
c    C(1) is the constant term.  T(M+1) is the M+1-th triangular number.
c    The coefficients are stored consistent with the following ordering
c    of monomials: 1, X, Y, X^2, XY, Y^2, X^3, X^2Y, XY^2, Y^3, X^4, ...
c
c    Input, integer N, the number of evaluation points.
c
c    Input, double precision X(N), Y(N), the evaluation points.
c
c    Output, double precision P(N), the value of the polynomial at the 
c    evaluation points.
c
      implicit none

      integer n

      double precision c(*)
      integer ex
      integer ey
      integer i
      integer j
      integer m
      double precision p(n)
      integer s
      double precision x(n)
      double precision y(n)

      do i = 1, n
        p(i) = 0.0D+00
      end do

      j = 0
      do s = 0, m
        do ex = s, 0, -1
          ey = s - ex
          j = j + 1
          do i = 1, n
            p(i) = p(i) + c(j) * x(i) ** ex * y(i) ** ey
          end do
        end do
      end do

      return
      end
      subroutine r8row_compare ( m, n, a, i, j, value )

c*********************************************************************72
c
cc R8ROW_COMPARE compares rows in an R8ROW.
c
c  Discussion:
c
c    An R8ROW is an M by N array of R8's, regarded as an array of M rows,
c    each of length N.
c
c  Example:
c
c    Input:
c
c      M = 4, N = 3, I = 2, J = 4
c
c      A = (
c        1  5  9
c        2  6 10
c        3  7 11
c        4  8 12 )
c
c    Output:
c
c      VALUE = -1
c
c  Licensing:
c
c    This code is distributed under the GNU LGPL license.
c
c  Modified:
c
c    25 May 2012
c
c  Author:
c
c    John Burkardt
c
c  Parameters:
c
c    Input, integer M, N, the number of rows and columns.
c
c    Input, double precision A(M,N), the M by N array.
c
c    Input, integer I, J, the rows to be compared.
c    I and J must be between 1 and M.
c
c    Output, integer VALUE, the results of the comparison:
c    -1, row I < row J,
c     0, row I = row J,
c    +1, row J < row I.
c
      implicit none

      integer m
      integer n

      double precision a(m,n)
      integer i
      integer j
      integer k
      integer value
c
c  Check.
c
      if ( i .lt. 1 .or. m .lt. i ) then
        write ( *, '(a)' ) ' '
        write ( *, '(a)' ) 'R8ROW_COMPARE - Fatal error!'
        write ( *, '(a)' ) '  Row index I is out of bounds.'
        write ( *, '(a,i8)' ) '  I = ', i
        stop
      end if

      if ( j .lt. 1 .or. m .lt. j ) then
        write ( *, '(a)' ) ' '
        write ( *, '(a)' ) 'R8ROW_COMPARE - Fatal error!'
        write ( *, '(a)' ) '  Row index J is out of bounds.'
        write ( *, '(a,i8)' ) '  J = ', j
        stop
      end if

      value = 0

      if ( i .eq. j ) then
        return
      end if

      k = 1

10    continue

      if ( k .le. n ) then

        if ( a(i,k) .lt. a(j,k) ) then
          value = -1
          return
        else if ( a(j,k) .lt. a(i,k) ) then
          value = +1
          return
        end if

        k = k + 1

        go to 10

      end if

      return
      end
      subroutine r8row_max ( m, n, a, amax )

c*********************************************************************72
c
cc R8ROW_MAX returns the maximums of an R8ROW.
c
c  Discussion:
c
c    An R8ROW is an M by N array of R8 values, regarded
c    as an array of M rows of length N.
c
c  Example:
c
c    A =
c      1  2  3
c      2  6  7
c
c    MAX =
c      3
c      7
c
c  Licensing:
c
c    This code is distributed under the GNU LGPL license.
c
c  Modified:
c
c    16 May 2010
c
c  Author:
c
c    John Burkardt
c
c  Parameters:
c
c    Input, integer M, N, the number of rows and columns
c    in the array.
c
c    Input, double precision A(M,N), the array to be examined.
c
c    Output, double precision AMAX(M), the maximums of the rows.
c
      implicit none

      integer m
      integer n

      double precision a(m,n)
      double precision amax(m)
      integer i
      integer j

      do i = 1, m

        amax(i) = a(i,1)
        do j = 2, n
          if ( amax(i) .lt. a(i,j) ) then
            amax(i) = a(i,j)
          end if
        end do

      end do

      return
      end
      subroutine r8row_mean ( m, n, a, mean )

c*********************************************************************72
c
cc R8ROW_MEAN returns the means of an R8ROW.
c
c  Discussion:
c
c    An R8ROW is an M by N array of R8 values, regarded
c    as an array of M rows of length N.
c
c  Example:
c
c    A =
c      1  2  3
c      2  6  7
c
c    MEAN =
c      2
c      5
c
c  Licensing:
c
c    This code is distributed under the GNU LGPL license.
c
c  Modified:
c
c    02 December 2011
c
c  Author:
c
c    John Burkardt
c
c  Parameters:
c
c    Input, integer M, N, the number of rows and columns.
c
c    Input, double precision A(M,N), the array to be examined.
c
c    Output, double precision MEAN(M), the means, or averages, of the rows.
c
      implicit none

      integer m
      integer n

      double precision a(m,n)
      integer i
      integer j
      double precision mean(m)

      do i = 1, m
        mean(i) = 0.0D+00
        do j = 1, n
          mean(i) = mean(i) + a(i,j)
        end do
        mean(i) = mean(i) / dble ( n )
      end do

      return
      end
      subroutine r8row_min ( m, n, a, amin )

c*********************************************************************72
c
cc R8ROW_MIN returns the minimums of an R8ROW.
c
c  Discussion:
c
c    An R8ROW is an M by N array of R8 values, regarded
c    as an array of M rows of length N.
c
c  Example:
c
c    A =
c      1  2  3
c      2  6  7
c
c    MIN =
c      1
c      2
c
c  Licensing:
c
c    This code is distributed under the GNU LGPL license.
c
c  Modified:
c
c    02 December 2011
c
c  Author:
c
c    John Burkardt
c
c  Parameters:
c
c    Input, integer M, N, the number of rows and columns
c    in the array.
c
c    Input, double precision A(M,N), the array to be examined.
c
c    Output, double precision AMIN(M), the minimums of the rows.
c
      implicit none

      integer m
      integer n

      double precision a(m,n)
      double precision amin(m)
      integer i
      integer j

      do i = 1, m

        amin(i) = a(i,1)
        do j = 2, n
          if ( a(i,j) .lt. amin(i) ) then
            amin(i) = a(i,j)
          end if
        end do

      end do

      return
      end
      subroutine r8row_part_quick_a ( m, n, a, l, r )

c*********************************************************************72
c
cc R8ROW_PART_QUICK_A reorders the rows of an R8ROW.
c
c  Discussion:
c
c    An R8ROW is an M by N array of R8's, regarded as an array of M rows,
c    each of length N.
c
c    The routine reorders the rows of A.  Using A(1,1:N) as a
c    key, all entries of A that are less than or equal to the key will
c    precede the key, which precedes all entries that are greater than the key.
c
c  Example:
c
c    Input:
c
c      M = 8, N = 2
c      A = ( 2 4
c            8 8
c            6 2
c            0 2
c           10 6
c           10 0
c            0 6
c            5 8 )
c
c    Output:
c
c      L = 2, R = 4
c
c      A = ( 0 2    LEFT
c            0 6
c            ----
c            2 4    KEY
c            ----
c            8 8    RIGHT
c            6 2
c           10 6
c           10 0
c            5 8 )
c
c  Licensing:
c
c    This code is distributed under the GNU LGPL license.
c
c  Modified:
c
c    26 May 2012
c
c  Author:
c
c    John Burkardt
c
c  Parameters:
c
c    Input, integer M, the row dimension of A.
c
c    Input, integer N, the column dimension of A, and the
c    length of a row.
c
c    Input/output, double precision A(M,N).  On input, the array to be checked.
c    On output, A has been reordered as described above.
c
c    Output, integer L, R, the indices of A that define the three
c    segments.  Let KEY = the input value of A(1,1:N).  Then
c    I <= L                 A(I,1:N) < KEY;
c         L < I < R         A(I,1:N) = KEY;
c                 R <= I    KEY < A(I,1:N).
c
      implicit none

      integer m
      integer n

      double precision a(m,n)
      integer i
      integer j
      integer k
      double precision key(n)
      integer l
      integer r
      logical r8vec_eq
      logical r8vec_gt
      logical r8vec_lt

      if ( m .lt. 1 ) then
        write ( *, '(a)' ) ' '
        write ( *, '(a)' ) 'R8ROW_PART_QUICK_A - Fatal error!'
        write ( *, '(a)' ) '  M < 1.'
        return
      end if

      if ( m .eq. 1 ) then
        l = 0
        r = 2
        return
      end if

      do i = 1, n
        key(i) = a(1,i)
      end do
      k = 1
c
c  The elements of unknown size have indices between L+1 and R-1.
c
      l = 1
      r = m + 1

      do j = 2, m

        if ( r8vec_gt ( n, a(l+1,1:n), key ) ) then
          r = r - 1
          call r8vec_swap ( n, a(r,1:n), a(l+1,1:n) )
        else if ( r8vec_eq ( n, a(l+1,1:n), key ) ) then
          k = k + 1
          call r8vec_swap ( n, a(k,1:n), a(l+1,1:n) )
          l = l + 1
        else if ( r8vec_lt ( n, a(l+1,1:n), key ) ) then
          l = l + 1
        end if

      end do
c
c  Shift small elements to the left.
c
      do j = 1, l - k
        do i = 1, n
          a(j,i) = a(j+k,i)
        end do
      end do
c
c  Shift KEY elements to center.
c
      do j = l - k + 1, l
        do i = 1, n
          a(j,i) = key(i)
        end do
      end do
c
c  Update L.
c
      l = l - k

      return
      end
      subroutine r8row_sort_heap_a ( m, n, a )

c*********************************************************************72
c
cc R8ROW_SORT_HEAP_A ascending heapsorts an R8ROWL.
c
c  Discussion:
c
c    An R8ROW is an M by N array of R8's, regarded as an array of M rows,
c    each of length N.
c
c    In lexicographic order, the statement "X < Y", applied to two real
c    vectors X and Y of length M, means that there is some index I, with
c    1 <= I <= M, with the property that
c
c      X(J) = Y(J) for J < I,
c    and
c      X(I) < Y(I).
c
c    In other words, the first time they differ, X is smaller.
c
c  Licensing:
c
c    This code is distributed under the GNU LGPL license.
c
c  Modified:
c
c    25 May 2012
c
c  Author:
c
c    John Burkardt
c
c  Parameters:
c
c    Input, integer M, N, the number of rows and columns.
c
c    Input/output, double precision A(M,N).
c    On input, the array of M rows of N-vectors.
c    On output, the rows of A have been sorted in lexicographic order.
c
      implicit none

      integer m
      integer n

      double precision a(m,n)
      integer i
      integer indx
      integer isgn
      integer j

      if ( m .le. 1 ) then
        return
      end if
c
c  Initialize.
c
      i = 0
      indx = 0
      isgn = 0
      j = 0
c
c  Call the external heap sorter.
c
10    continue

        call sort_heap_external ( m, indx, i, j, isgn )
c
c  Interchange the I and J objects.
c
        if ( 0 .lt. indx ) then

          call r8row_swap ( m, n, a, i, j )
c
c  Compare the I and J objects.
c
        else if ( indx .lt. 0 ) then

          call r8row_compare ( m, n, a, i, j, isgn )

        else if ( indx .eq. 0 ) then

          go to 20

        end if

      go to 10

20    continue

      return
      end
      subroutine r8row_sort_heap_index_a ( m, n, a, indx )

c*********************************************************************72
c
cc R8ROW_SORT_HEAP_INDEX_A does an indexed heap ascending sort of an R8ROW.
c
c  Discussion:
c
c    An R8ROW is an M by N array of R8's, regarded as an array of M rows,
c    each of length N.
c
c    The sorting is not actually carried out.  Rather an index array is
c    created which defines the sorting.  This array may be used to sort
c    or index the array, or to sort or index related arrays keyed on the
c    original array.
c
c    A(I1,*) < A(I1,*) if the first nonzero entry of A(I1,*)-A(I2,*)
c    is negative.
c
c    Once the index array is computed, the sorting can be carried out
c    "implicitly:
c
c      A(INDX(1:M),1:N) is sorted.
c
c  Licensing:
c
c    This code is distributed under the GNU LGPL license.
c
c  Modified:
c
c    26 May 2012
c
c  Author:
c
c    John Burkardt
c
c  Parameters:
c
c    Input, integer M, the number of rows in each column of A.
c
c    Input, integer N, the number of columns in A.
c
c    Input, double precision A(M,N), the array.
c
c    Output, integer INDX(M), the sort index.  The I-th element
c    of the sorted array is row INDX(I).
c
      implicit none

      integer m
      integer n

      double precision a(m,n)
      integer i
      integer indx(m)
      integer indxt
      integer ir
      integer isgn
      integer j
      integer k
      integer l
      double precision row(n)
      double precision row2(n)

      do i = 1, m
        indx(i) = i
      end do

      if ( m .eq. 1 ) then
        return
      end if

      l = ( m / 2 ) + 1
      ir = m

10    continue

        if ( 1 .lt. l ) then

          l = l - 1
          indxt = indx(l)
          do k = 1, n
            row(k) = a(indxt,k)
          end do

        else

          indxt = indx(ir)
          do k = 1, n
            row(k) = a(indxt,k)
          end do
          indx(ir) = indx(1)
          ir = ir - 1

          if ( ir .eq. 1 ) then
            indx(1) = indxt
            go to 30
          end if

        end if

        i = l
        j = l + l

20      continue

        if ( j .le. ir ) then

          if ( j .lt. ir ) then

            call r8row_compare ( m, n, a, indx(j), indx(j+1), isgn )

            if ( isgn .lt. 0 ) then
              j = j + 1
            end if

          end if

          do k = 1, n
            row2(k) = a(indx(j),k)
          end do

          call r8vec_compare ( n, row, row2, isgn )

          if ( isgn .lt. 0 ) then
            indx(i) = indx(j)
            i = j
            j = j + j
          else
            j = ir + 1
          end if

          go to 20

        end if

        indx(i) = indxt

      go to 10

30    continue

      return
      end
      subroutine r8row_sort_quick_a ( m, n, a )

c*********************************************************************72
c
cc R8ROW_SORT_QUICK_A ascending quick sorts an R8ROW.
c
c  Discussion:
c
c    An R8ROW is an M by N array of R8's, regarded as an array of M rows,
c    each of length N.
c
c  Licensing:
c
c    This code is distributed under the GNU LGPL license.
c
c  Modified:
c
c    26 May 2012
c
c  Author:
c
c    John Burkardt
c
c  Parameters:
c
c    Input, integer M, the number of rows of A.
c
c    Input, integer N, the number of columns of A,
c    and the length of a row.
c
c    Input/output, double precision A(M,N).
c    On input, the array to be sorted.
c    On output, the array has been sorted.
c
      implicit none

      integer level_max
      parameter ( level_max = 30 )
      integer m
      integer n

      double precision a(m,n)
      integer base
      integer l_segment
      integer level
      integer m_segment
      integer rsave(level_max)
      integer r_segment

      if ( n .le. 0 ) then
        return
      end if

      if ( m < 1 ) then
        write ( *, '(a)' ) ' '
        write ( *, '(a)' ) 'R8ROW_SORT_QUICK_A - Fatal error!'
        write ( *, '(a)' ) '  M < 1.'
        write ( *, '(a,i8)' ) '  M = ', m
        stop
      end if

      if ( m .eq. 1 ) then
        return
      end if

      level = 1
      rsave(level) = m + 1
      base = 1
      m_segment = m

10    continue
c
c  Partition the segment.
c
        call r8row_part_quick_a ( m_segment, n, 
     &    a(base:base+m_segment-1,1:n), l_segment, r_segment )
c
c  If the left segment has more than one element, we need to partition it.
c
        if ( 1 .lt. l_segment ) then

          if ( level_max < level ) then
            write ( *, '(a)' ) ' '
            write ( *, '(a)' ) 'R8ROW_SORT_QUICK_A - Fatal error!'
            write ( *, '(a,i8)' ) 
     &        '  Exceeding recursion maximum of ', level_max
            stop
          end if

          level = level + 1
          m_segment = l_segment
          rsave(level) = r_segment + base - 1
c
c  The left segment and the middle segment are sorted.
c  Must the right segment be partitioned?
c
        else if ( r_segment .lt. m_segment ) then

          m_segment = m_segment + 1 - r_segment
          base = base + r_segment - 1
c
c  Otherwise, we back up a level if there is an earlier one.
c
        else

20        continue

            if ( level .le. 1 ) then
              return
            end if

            base = rsave(level)
            m_segment = rsave(level-1) - rsave(level)
            level = level - 1

            if ( 0 .lt. m_segment ) then
              go to 30
            end if

          go to 20

30        continue

        end if

      go to 10

      return
      end
      subroutine r8row_sorted_unique_count ( m, n, a, unique_num )

c*********************************************************************72
c
cc R8ROW_SORTED_UNIQUE_COUNT counts unique elements in an R8ROW.
c
c  Discussion:
c
c    An R8ROW is an M by N array of R8 values, regarded
c    as an array of M rows of length N.
c
c    The rows of the array may be ascending or descending sorted.
c
c  Licensing:
c
c    This code is distributed under the GNU LGPL license.
c
c  Modified:
c
c    02 December 2011
c
c  Author:
c
c    John Burkardt
c
c  Parameters:
c
c    Input, integer M, N, the number of rows and columns.
c
c    Input, double precision A(M,N), a sorted array, containing
c    M rows of data.
c
c    Output, integer UNIQUE_NUM, the number of unique rows.
c
      implicit none

      integer m
      integer n

      double precision a(m,n)
      integer i1
      integer i2
      integer j
      integer unique_num

      if ( n .le. 0 ) then
        unique_num = 0
        return
      end if

      unique_num = 1
      i1 = 1

      do i2 = 2, m

        do j = 1, n

          if ( a(i1,j) .ne. a(i2,j) ) then
            unique_num = unique_num + 1
            i1 = i2
            go to 10
          end if

        end do

10      continue

      end do

      return
      end
      subroutine r8row_sum ( m, n, a, rowsum )

c*********************************************************************72
c
cc R8ROW_SUM returns the sums of the rows of an R8ROW.
c
c  Discussion:
c
c    An R8ROW is an M by N array of R8 values, regarded
c    as an array of M rows of length N.
c
c  Licensing:
c
c    This code is distributed under the GNU LGPL license.
c
c  Modified:
c
c    06 December 2004
c
c  Author:
c
c    John Burkardt
c
c  Parameters:
c
c    Input, integer M, N, the number of rows and columns.
c
c    Input, double precision A(M,N), the M by N array.
c
c    Output, double precision ROWSUM(M), the sum of the entries of
c    each row.
c
      implicit none

      integer m
      integer n

      double precision a(m,n)
      integer i
      double precision rowsum(m)

      do i = 1, m
        rowsum(i) = sum ( a(i,1:n) )
      end do

      return
      end
      subroutine r8row_swap ( m, n, a, i1, i2 )

c*********************************************************************72
c
cc R8ROW_SWAP swaps two rows of an R8ROW.
c
c  Discussion:
c
c    An R8ROW is an M by N array of R8 values, regarded
c    as an array of M rows of length N.
c
c  Licensing:
c
c    This code is distributed under the GNU LGPL license.
c
c  Modified:
c
c    05 December 2004
c
c  Author:
c
c    John Burkardt
c
c  Parameters:
c
c    Input, integer M, N, the number of rows and columns.
c
c    Input/output, double precision A(M,N), the M by N array.
c
c    Input, integer I1, I2, the two rows to swap.
c
      implicit none

      integer m
      integer n

      double precision a(m,n)
      integer i1
      integer i2
      double precision row(n)

      if ( i1 .lt. 1 .or. m .lt. i1 ) then
        write ( *, '(a)' ) ' '
        write ( *, '(a)' ) 'R8ROW_SWAP - Fatal error!'
        write ( *, '(a)' ) '  I1 is out of range.'
        write ( *, '(a,i8)' ) '  I1 = ', i1
        stop
      end if

      if ( i2 .lt. 1 .or. m .lt. i2 ) then
        write ( *, '(a)' ) ' '
        write ( *, '(a)' ) 'R8ROW_SWAP - Fatal error!'
        write ( *, '(a)' ) '  I2 is out of range.'
        write ( *, '(a,i8)' ) '  I2 = ', i2
        stop
      end if

      if ( i1 .eq. i2 ) then
        return
      end if

      row(1:n) = a(i1,1:n)
      a(i1,1:n) = a(i2,1:n)
      a(i2,1:n) = row(1:n)

      return
      end
      subroutine r8row_to_r8vec ( m, n, a, x )

c*********************************************************************72
c
cc R8ROW_TO_R8VEC converts an R8ROW into an R8VEC.
c
c  Discussion:
c
c    An R8ROW is an M by N array of R8 values, regarded
c    as an array of M rows of length N.
c
c  Example:
c
c    M = 3, N = 4
c
c    A =
c      11 12 13 14
c      21 22 23 24
c      31 32 33 34
c
c    X = ( 11, 12, 13, 14, 21, 22, 23, 24, 31, 32, 33, 34 )
c
c  Licensing:
c
c    This code is distributed under the GNU LGPL license.
c
c  Modified:
c
c    13 July 2000
c
c  Author:
c
c    John Burkardt
c
c  Parameters:
c
c    Input, integer M, N, the number of rows and columns.
c
c    Input, double precision A(M,N), the M by N array.
c
c    Output, double precision X(M*N), a vector containing the M rows of A.
c
      implicit none

      integer m
      integer n

      double precision a(m,n)
      integer i
      integer j
      double precision x(m*n)

      j = 1
      do i = 1, m
        x(j:j+n-1) = a(i,1:n)
        j = j + n
      end do

      return
      end
      subroutine r8vec_01_to_ab ( n, a, amax, amin )

c*********************************************************************72
c
cc R8VEC_01_TO_AB shifts and rescales an R8VEC to lie within given bounds.
c
c  Discussion:
c
c    An R8VEC is a vector of R8 values.
c
c    On input, A contains the original data, which is presumed to lie
c    between 0 and 1.  However, it is not necessary that this be so.
c
c    On output, A has been shifted and rescaled so that all entries which
c    on input lay in [0,1] now lie between AMIN and AMAX.  Other entries will
c    be mapped in a corresponding way.
c
c  Licensing:
c
c    This code is distributed under the GNU LGPL license.
c
c  Modified:
c
c    26 August 2008
c
c  Author:
c
c    John Burkardt
c
c  Parameters:
c
c    Input, integer N, the number of data values.
c
c    Input/output, double precision A(N), the vector to be rescaled.
c
c    Input, double precision AMAX, AMIN, the maximum and minimum values
c    allowed for A.
c
      implicit none

      integer n

      double precision a(n)
      double precision amax
      double precision amax2
      double precision amax3
      double precision amin
      double precision amin2
      double precision amin3
      integer i

      if ( amax .eq. amin ) then
        a(1:n) = amin
        return
      end if

      amax2 = max ( amax, amin )
      amin2 = min ( amax, amin )

      amin3 = a(1)
      do i = 2, n
        amin3 = min ( amin3, a(i) )
      end do

      amax3 = a(1)
      do i = 2, n
        amax3 = max ( amax3, a(i) )
      end do

      if ( amax3 .ne. amin3 ) then

        do i = 1, n

          a(i) = ( ( amax3 - a(i)         ) * amin2
     &           + (         a(i) - amin3 ) * amax2 )
     &           / ( amax3        - amin3 )
        end do

      else

        do i = 1, n
          a(i) = 0.5D+00 * ( amax2 + amin2 )
        end do
      end if

      return
      end
      subroutine r8vec_ab_to_01 ( n, a )

c*********************************************************************72
c
cc R8VEC_AB_TO_01 shifts and rescales an R8VEC to lie within [0,1].
c
c  Discussion:
c
c    An R8VEC is a vector of R8 values.
c
c    On input, A contains the original data.  On output, A has been shifted
c    and scaled so that all entries lie between 0 and 1.
c
c  Formula:
c
c    A(I) := ( A(I) - AMIN ) / ( AMAX - AMIN )
c
c  Licensing:
c
c    This code is distributed under the GNU LGPL license.
c
c  Modified:
c
c    27 August 2008
c
c  Author:
c
c    John Burkardt
c
c  Parameters:
c
c    Input, integer N, the number of data values.
c
c    Input/output, double precision A(N), the data to be rescaled.
c
      implicit none

      integer n

      double precision a(n)
      double precision amax
      double precision amin
      integer i

      amin = a(1)
      do i = 2, n
        amin = min ( amin, a(i) )
      end do

      amax = a(1)
      do i = 2, n
        amax = max ( amax, a(i) )
      end do

      if ( amin .eq. amax ) then
        do i = 1, n
          a(i) = 0.5D+00
        end do
      else
        do i = 1, n
          a(i) = ( a(i) - amin ) / ( amax - amin )
        end do
      end if

      return
      end
      subroutine r8vec_ab_to_cd ( n, a, bmin, bmax, b )

c*********************************************************************72
c
cc R8VEC_AB_TO_CD shifts and rescales an R8VEC from one interval to another.
c
c  Discussion:
c
c    An R8VEC is a vector of R8 values.
c
c    The mininum entry of A is mapped to BMIN, the maximum entry
c    to BMAX, and values in between are mapped linearly.
c
c  Licensing:
c
c    This code is distributed under the GNU LGPL license.
c
c  Modified:
c
c    30 August 2008
c
c  Author:
c
c    John Burkardt
c
c  Parameters:
c
c    Input, integer N, the number of data values.
c
c    Input, double precision A(N), the data to be remapped.
c
c    Input, double precision BMIN, BMAX, the values to which min(A) and max(A)
c    are to be assigned.
c
c    Output, double precision B(N), the remapped data.
c
      implicit none

      integer n

      double precision a(n)
      double precision amax
      double precision amin
      double precision b(n)
      double precision bmax
      double precision bmin
      integer i

      if ( bmax .eq. bmin ) then
        do i = 1, n
          b(i) = bmin
        end do
        return
      end if

      amin = a(1)
      do i = 2, n
        amin = min ( amin, a(i) )
      end do

      amax = a(1)
      do i = 2, n
        amax = max ( amax, a(i) )
      end do

      if ( amax .eq. amin ) then
        do i = 1, n
          b(i) = 0.5D+00 * ( bmax + bmin )
        end do
        return
      end if

      do i = 1, n
        b(i) = ( ( amax - a(i)        ) * bmin
     &       + (          a(i) - amin ) * bmax )
     &         / ( amax        - amin )
      end do

      return
      end
      function r8vec_all_nonpositive ( n, a )

c*********************************************************************72
c
cc R8VEC_ALL_NONPOSITIVE: ( all ( A <= 0 ) ) for R8VEC's.
c
c  Discussion:
c
c    An R8VEC is a vector of R8's.
c
c  Licensing:
c
c    This code is distributed under the GNU LGPL license.
c
c  Modified:
c
c    08 October 2011
c
c  Author:
c
c    John Burkardt
c
c  Parameters:
c
c    Input, integer N, the number of entries.
c
c    Input, double precision A(N), the vector.
c
c    Output, logical R8VEC_ALL_NONPOSITIVE is TRUE if all entries
c    of A are less than or equal to 0.
c
      implicit none

      integer n

      double precision a(n)
      integer i
      logical r8vec_all_nonpositive

      do i = 1, n
        if ( 0.0D+00 .lt. a(i) ) then
          r8vec_all_nonpositive = .false.
          return
        end if
      end do

      r8vec_all_nonpositive = .true.

      return
      end
      subroutine r8vec_amax ( n, a, amax )

c*********************************************************************72
c
cc R8VEC_AMAX returns the maximum absolute value in an R8VEC.
c
c  Discussion:
c
c    An R8VEC is a vector of R8's.
c
c  Licensing:
c
c    This code is distributed under the GNU LGPL license.
c
c  Modified:
c
c    02 June 2009
c
c  Author:
c
c    John Burkardt
c
c  Parameters:
c
c    Input, integer N, the number of entries in the array.
c
c    Input, double precision A(N), the array.
c
c    Output, double precision AMAX, the value of the entry
c    of largest magnitude.
c
      implicit none

      integer n

      double precision a(n)
      double precision amax
      integer i

      amax = abs ( a(1) )
      do i = 2, n
        amax = max ( amax, abs ( a(i) ) )
      end do

      return
      end
      subroutine r8vec_amax_index ( n, a, amax_index )

c*********************************************************************72
c
cc R8VEC_AMAX_INDEX returns the index of the maximum absolute value in an R8VEC.
c
c  Discussion:
c
c    An R8VEC is a vector of R8's.
c
c  Licensing:
c
c    This code is distributed under the GNU LGPL license.
c
c  Modified:
c
c    02 June 2009
c
c  Author:
c
c    John Burkardt
c
c  Parameters:
c
c    Input, integer N, the number of entries in the array.
c
c    Input, double precision A(N), the array.
c
c    Output, integer AMAX_INDEX, the index of the entry of largest magnitude.
c
      implicit none

      integer n

      double precision a(n)
      double precision amax
      integer amax_index
      integer i

      if ( n .le. 0 ) then

        amax_index = -1

      else

        amax_index = 1
        amax = abs ( a(1) )

        do i = 2, n
          if ( amax .lt. abs ( a(i) ) ) then
            amax_index = i
            amax = abs ( a(i) )
          end if
        end do

      end if

      return
      end
      subroutine r8vec_amin ( n, a, amin )

c*********************************************************************72
c
cc R8VEC_AMIN returns the minimum absolute value in an R8VEC.
c
c  Discussion:
c
c    An R8VEC is a vector of R8's.
c
c  Licensing:
c
c    This code is distributed under the GNU LGPL license.
c
c  Modified:
c
c    02 June 2009
c
c  Author:
c
c    John Burkardt
c
c  Parameters:
c
c    Input, integer N, the number of entries in the array.
c
c    Input, double precisionA(N), the array.
c
c    Output, double precision AMIN, the value of the entry
c    of smallest magnitude.
c
      implicit none

      integer n

      double precision a(n)
      double precision amin
      integer i

      amin = abs ( a(1) )
      do i = 2, n
        amin = min ( amin, abs ( a(i) ) )
      end do

      return
      end
      subroutine r8vec_amin_index ( n, a, amin_index )

c*********************************************************************72
c
cc R8VEC_AMIN_INDEX returns the index of the minimum absolute value in an R8VEC.
c
c  Discussion:
c
c    An R8VEC is a vector of R8's.
c
c  Licensing:
c
c    This code is distributed under the GNU LGPL license.
c
c  Modified:
c
c    02 June 2009
c
c  Author:
c
c    John Burkardt
c
c  Parameters:
c
c    Input, integer N, the number of entries in the array.
c
c    Input, double precision A(N), the array.
c
c    Output, integer AMIN_INDEX, the index of the entry of smallest magnitude.
c
      implicit none

      integer n

      double precision a(n)
      double precision amin
      integer amin_index
      integer i

      if ( n .le. 0 ) then

        amin_index = 0

      else

        amin_index = 1
        amin = abs ( a(1) )

        do i = 2, n
          if ( abs ( a(i) ) .lt. amin ) then
            amin_index = i
            amin = abs ( a(i) )
          end if
        end do

      end if

      return
      end
      function r8vec_any_negative ( n, a )

c*********************************************************************72
c
cc R8VEC_ANY_NEGATIVE: ( any ( A < 0 ) ) for R8VEC's.
c
c  Discussion:
c
c    An R8VEC is a vector of R8's.
c
c  Licensing:
c
c    This code is distributed under the GNU LGPL license.
c
c  Modified:
c
c    09 October 2011
c
c  Author:
c
c    John Burkardt
c
c  Parameters:
c
c    Input, integer N, the number of entries.
c
c    Input, double precision A(N), the vector.
c
c    Output, logical R8VEC_ANY_NEGATIVE is TRUE if any entry
c    of A is less than zero.
c
      implicit none

      integer n

      double precision a(n)
      integer i
      logical r8vec_any_negative

      do i = 1, n
        if ( a(i) .lt. 0.0D+00 ) then
          r8vec_any_negative = .true.
          return
        end if
      end do

      r8vec_any_negative = .false.

      return
      end
      function r8vec_any_nonzero ( n, a )

c*********************************************************************72
c
cc R8VEC_ANY_NONZERO: ( any A nonzero ) for R8VEC's.
c
c  Discussion:
c
c    An R8VEC is a vector of R8's.
c
c  Licensing:
c
c    This code is distributed under the GNU LGPL license.
c
c  Modified:
c
c    25 December 2011
c
c  Author:
c
c    John Burkardt
c
c  Parameters:
c
c    Input, integer N, the number of entries.
c
c    Input, double precision A(N), the vector.
c
c    Output, logical R8VEC_ANY_NONZERO is TRUE if any entry is nonzero.
c
      implicit none

      integer n

      double precision a(n)
      integer i
      logical r8vec_any_nonzero

      do i = 1, n
        if ( a(i) .ne. 0.0D+00 ) then
          r8vec_any_nonzero = .true.
          return
        end if
      end do

      r8vec_any_nonzero = .false.

      return
      end
      subroutine r8vec_any_normal ( dim_num, v1, v2 )

c*********************************************************************72
c
cc R8VEC_ANY_NORMAL returns some normal vector to V1.
c
c  Discussion:
c
c    If DIM_NUM < 2, then no normal vector can be returned.
c
c    If V1 is the zero vector, then any unit vector will do.
c
c    No doubt, there are better, more robust algorithms.  But I will take
c    just about ANY reasonable unit vector that is normal to V1.
c
c  Licensing:
c
c    This code is distributed under the GNU LGPL license.
c
c  Modified:
c
c    18 May 2010
c
c  Author:
c
c    John Burkardt
c
c  Parameters:
c
c    Input, integer DIM_NUM, the spatial dimension.
c
c    Input, double precision V1(DIM_NUM), the vector.
c
c    Output, double precision V2(DIM_NUM), a vector that is
c    normal to V2, and has unit Euclidean length.
c
      implicit none

      integer dim_num

      integer i
      integer j
      integer k
      double precision r8vec_norm
      double precision v1(dim_num)
      double precision v2(dim_num)
      double precision vj
      double precision vk

      if ( dim_num .lt. 2 ) then
        write ( *, '(a)' ) ' '
        write ( *, '(a)' ) 'R8VEC_ANY_NORMAL - Fatal error!'
        write ( *, '(a)' ) '  Called with DIM_NUM < 2.'
        stop
      end if

      if ( r8vec_norm ( dim_num, v1 ) .eq. 0.0D+00 ) then
        v2(1) = 1.0D+00
        do i = 2, dim_num
          v2(i) = 0.0D+00
        end do
        return
      end if
c
c  Seek the largest entry in V1, VJ = V1(J), and the
c  second largest, VK = V1(K).
c
c  Since V1 does not have zero norm, we are guaranteed that
c  VJ, at least, is not zero.
c
      j = - 1
      vj = 0.0D+00

      k = - 1
      vk = 0.0D+00

      do i = 1, dim_num

        if ( abs ( vk ) .lt. abs ( v1(i) ) .or. k .lt. 1 ) then

          if ( abs ( vj ) .lt. abs ( v1(i) ) .or. j .lt. 1 ) then
            k = j
            vk = vj
            j = i
            vj = v1(i)
          else
            k = i
            vk = v1(i)
          end if

        end if

      end do
c
c  Setting V2 to zero, except that V2(J) = -VK, and V2(K) = VJ,
c  will just about do the trick.
c
      do i = 1, dim_num
        v2(i) = 0.0D+00
      end do

      v2(j) = - vk / sqrt ( vk * vk + vj * vj )
      v2(k) =   vj / sqrt ( vk * vk + vj * vj )

      return
      end
      function r8vec_ascends ( n, x )

c*********************************************************************72
c
cc R8VEC_ASCENDS determines if an R8VEC is (weakly) ascending.
c
c  Discussion:
c
c    An R8VEC is a vector of R8 values.
c
c    For example, if:
c
c      X = ( -8.1, 1.3, 2.2, 3.4, 7.5, 7.5, 9.8 )
c
c    then
c
c      R8VEC_ASCENDS = TRUE
c
c    The sequence is not required to be strictly ascending.
c
c  Licensing:
c
c    This code is distributed under the GNU LGPL license.
c
c  Modified:
c
c    26 August 2008
c
c  Author:
c
c    John Burkardt
c
c  Parameters:
c
c    Input, integer N, the size of the array.
c
c    Input, double precision X(N), the array to be examined.
c
c    Output, logical R8VEC_ASCENDS, is TRUE if the
c    entries of X ascend.
c
      implicit none

      integer n

      integer i
      logical r8vec_ascends
      double precision x(n)

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

      r8vec_ascends = .true.

      return
      end
      function r8vec_ascends_strictly ( n, x )

c*********************************************************************72
c
cc R8VEC_ASCENDS_STRICTLY determines if an R8VEC is strictly ascending.
c
c  Discussion:
c
c    An R8VEC is a vector of R8's.
c
c    Notice the effect of entry number 6 in the following results:
c
c      X = ( -8.1, 1.3, 2.2, 3.4, 7.5, 7.4, 9.8 )
c      Y = ( -8.1, 1.3, 2.2, 3.4, 7.5, 7.5, 9.8 )
c      Z = ( -8.1, 1.3, 2.2, 3.4, 7.5, 7.6, 9.8 )
c
c      R8VEC_ASCENDS_STRICTLY ( X ) = FALSE
c      R8VEC_ASCENDS_STRICTLY ( Y ) = FALSE
c      R8VEC_ASCENDS_STRICTLY ( Z ) = TRUE
c
c  Licensing:
c
c    This code is distributed under the GNU LGPL license.
c
c  Modified:
c
c    16 May 2010
c
c  Author:
c
c    John Burkardt
c
c  Parameters:
c
c    Input, integer N, the size of the array.
c
c    Input, double precision X(N), the array to be examined.
c
c    Output, logical R8VEC_ASCENDS_STRICTLY, is TRUE if the
c    entries of X strictly ascend.
c
      implicit none

      integer n

      integer i
      logical r8vec_ascends_strictly
      double precision x(n)

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

      r8vec_ascends_strictly = .true.

      return
      end
      subroutine r8vec_bin ( n, x, bin_num, bin_min, bin_max, bin, 
     &  bin_limit )

c*********************************************************************72
c
cc R8VEC_BIN computes bins based on a given R8VEC.
c
c  Discussion:
c
c    The user specifies minimum and maximum bin values, BIN_MIN and
c    BIN_MAX, and the number of bins, BIN_NUM.  This determines a
c    "bin width":
c
c      H = ( BIN_MAX - BIN_MIN ) / BIN_NUM
c
c    so that bin I will count all entries X(J) such that
c
c      BIN_LIMIT(I-1) <= X(J) < BIN_LIMIT(I).
c
c    The array X does NOT have to be sorted.
c
c  Licensing:
c
c    This code is distributed under the GNU LGPL license. 
c
c  Modified:
c
c    29 July 1999
c
c  Author:
c
c    John Burkardt
c
c  Parameters:
c
c    Input, integer N, the number of entries of X.
c
c    Input, double precision X(N), an (unsorted) array to be binned.
c
c    Input, integer BIN_NUM, the number of bins.  Two extra bins, #0 and
c    #BIN_NUM+1, count extreme values.
c
c    Input, double precision BIN_MIN, BIN_MAX, define the range and size
c    of the bins.  BIN_MIN and BIN_MAX must be distinct.
c    Normally, BIN_MIN < BIN_MAX, and the documentation will assume
c    this, but proper results will be computed if BIN_MIN > BIN_MAX.
c
c    Output, integer BIN(0:BIN_NUM+1).
c    BIN(0) counts entries of X less than BIN_MIN.
c    BIN(BIN_NUM+1) counts entries greater than or equal to BIN_MAX.
c    For 1 <= I <= BIN_NUM, BIN(I) counts the entries X(J) such that
c      BIN_LIMIT(I-1) <= X(J) < BIN_LIMIT(I).
c    where H is the bin spacing.
c
c    Output, double precision BIN_LIMIT(0:BIN_NUM), the "limits" of the bins.
c    BIN(I) counts the number of entries X(J) such that
c      BIN_LIMIT(I-1) <= X(J) < BIN_LIMIT(I).
c
      implicit none

      integer n
      integer bin_num

      integer bin(0:bin_num+1)
      double precision bin_limit(0:bin_num)
      double precision bin_max
      double precision bin_min
      integer i
      integer j
      double precision t
      double precision x(n)

      if ( bin_max .eq. bin_min ) then
        write ( *, '(a)' ) ' '
        write ( *, '(a)' ) 'R8VEC_BIN - Fatal error!'
        write ( *, '(a)' ) '  BIN_MIN = BIN_MAX.'
        stop
      end if

      do i = 0, bin_num + 1
        bin(i) = 0
      end do

      do i = 1, n

        t = ( x(i) - bin_min ) / ( bin_max - bin_min )

        if ( t .lt. 0.0D+00 ) then
          j = 0
        else if ( 1.0D+00 .le. t ) then
          j = bin_num + 1
        else
          j = 1 + int ( dble ( bin_num ) * t )
        end if

        bin(j) = bin(j) + 1

      end do
c
c  Compute the bin limits.
c
      do i = 0, bin_num
        bin_limit(i) = (   dble ( bin_num - i ) * bin_min   
     &                   + dble (           i ) * bin_max ) 
     &                   / dble ( bin_num     )
      end do

      return
      end
      subroutine r8vec_blend ( n, t1, x1, t2, x2, x )

c*********************************************************************72
c
cc R8VEC_BLEND performs weighted interpolation of two R8VEC's.
c
c  Discussion:
c
c    An R8VEC is a vector of R8's.
c
c    The formula used is:
c
c      x(i) = t * x1(i) + (1-t) * x2(i)
c
c  Licensing:
c
c    This code is distributed under the GNU LGPL license.
c
c  Modified:
c
c    16 May 2010
c
c  Author:
c
c    John Burkardt
c
c  Parameters:
c
c    Input, integer N, the number of entries in each  vector.
c
c    Input, double precision T1, the weight factor for vector 1.
c
c    Input, double precision X1(N), the first vector.
c
c    Input, double precision T2, the weight factor for vector 2.
c
c    Input, double precision X2(N), the second vector.
c
c    Output, double precision X(N), the interpolated or extrapolated value.
c
      implicit none

      integer n

      integer i
      double precision t1
      double precision t2
      double precision x(n)
      double precision x1(n)
      double precision x2(n)

      do i = 1, n
        x(i) = t1 * x1(i) + t2 * x2(i)
      end do

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

c*********************************************************************72
c
cc R8VEC_BRACKET searches a sorted array for successive brackets of a value.
c
c  Discussion:
c
c    An R8VEC is a vector of R8's.
c
c    If the values in the vector are thought of as defining intervals
c    on the real line, then this routine searches for the interval
c    nearest to or containing the given value.
c
c  Modified:
c
c    24 July 2008
c
c  Author:
c
c    John Burkardt
c
c  Parameters:
c
c    Input, integer N, length of input array.
c
c    Input, double precision X(N), an array that has been sorted into
c    ascending order.
c
c    Input, double precision XVAL, a value to be bracketed.
c
c    Output, integer LEFT, RIGHT, the results of the search.
c    Either:
c      XVAL < X(1), when LEFT = 1, RIGHT = 2;
c      X(N) < XVAL, when LEFT = N-1, RIGHT = N;
c    or
c      X(LEFT) <= XVAL <= X(RIGHT).
c
      implicit none

      integer n

      integer i
      integer left
      integer right
      double precision x(n)
      double precision xval

      do i = 2, n - 1

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

       end do

      left = n - 1
      right = n

      return
      end
      subroutine r8vec_bracket2 ( n, x, xval, start, left, right )

c*********************************************************************72
c
cc R8VEC_BRACKET2 searches a sorted R8VEC for successive brackets of a value.
c
c  Discussion:
c
c    An R8VEC is a vector of R8's.
c
c    If the values in the vector are thought of as defining intervals
c    on the real line, then this routine searches for the interval
c    containing the given value.
c
c    R8VEC_BRACKET2 is a variation on R8VEC_BRACKET.  It seeks to reduce
c    the search time by allowing the user to suggest an interval that
c    probably contains the value.  The routine will look in that interval
c    and the intervals to the immediate left and right.  If this does
c    not locate the point, a binary search will be carried out on
c    appropriate subportion of the sorted array.
c
c    In the most common case, 1 .le. LEFT .lt. LEFT + 1 = RIGHT .le. N,
c    and X(LEFT) .le. XVAL .le. X(RIGHT).
c
c    Special cases:
c      Value is less than all data values:
c    LEFT = -1, RIGHT = 1, and XVAL .lt. X(RIGHT).
c      Value is greater than all data values:
c    LEFT = N, RIGHT = -1, and X(LEFT) .lt. XVAL.
c      Value is equal to a data value:
c    LEFT = RIGHT, and X(LEFT) = X(RIGHT) = XVAL.
c
c  Licensing:
c
c    This code is distributed under the GNU LGPL license.
c
c  Modified:
c
c    28 May 2009
c
c  Author:
c
c    John Burkardt
c
c  Parameters:
c
c    Input, integer N, length of the input array.
c
c    Input, double precision X(N), an array that has been sorted into
c    ascending order.
c
c    Input, double precision XVAL, a value to be bracketed by entries of X.
c
c    Input, integer START, between 1 and N, specifies that XVAL
c    is likely to be in the interval:
c
c      [ X(START), X(START+1) ]
c
c    or, if not in that interval, then either
c
c      [ X(START+1), X(START+2) ]
c    or
c      [ X(START-1), X(START) ].
c
c    Output, integer LEFT, RIGHT, the results of the search.
c
      implicit none

      integer n

      integer high
      integer left
      integer low
      integer right
      integer start
      double precision x(n)
      double precision xval
c
c  Check.
c
      if ( n .lt. 1 ) then
        write ( *, '(a)' ) ' '
        write ( *, '(a)' ) 'R8VEC_BRACKET2 - Fatal error!'
        write ( *, '(a)' ) '  N .lt. 1.'
        stop
      end if

      if ( start .lt. 1 .or. n .lt. start ) then
        start = ( n + 1 ) / 2
      end if
c
c  XVAL = X(START)?
c
      if ( x(start) .eq. xval ) then

        left = start
        right = start
        return
c
c  X(START) .lt. XVAL?
c
      else if ( x(start) .lt. xval ) then
c
c  X(START) = X(N) .lt. XVAL .lt. Infinity?
c
        if ( n .lt. start + 1 ) then

          left = start
          right = -1
          return
c
c  XVAL = X(START+1)?
c
        else if ( xval .eq. x(start+1) ) then

          left = start + 1
          right = start + 1
          return
c
c  X(START) .lt. XVAL .lt. X(START+1)?
c
        else if ( xval .lt. x(start+1) ) then

          left = start
          right = start + 1
          return
c
c  X(START+1) = X(N) .lt. XVAL .lt. Infinity?
c
        else if ( n .lt. start + 2 ) then

          left = start + 1
          right = -1
          return
c
c  XVAL = X(START+2)?
c
        else if ( xval .eq. x(start+2) ) then

          left = start + 2
          right = start + 2
          return
c
c  X(START+1) .lt. XVAL .lt. X(START+2)?
c
        else if ( xval .lt. x(start+2) ) then

          left = start + 1
          right = start + 2
          return
c
c  Binary search for XVAL in [ X(START+2), X(N) ],
c  where XVAL is guaranteed to be greater than X(START+2).
c
        else

          low = start + 2
          high = n
          call r8vec_bracket ( high + 1 - low, x(low), xval, left,
     &      right )
          left = left + low - 1
          right = right + low - 1

        end if
c
c  -Infinity .lt. XVAL .lt. X(START) = X(1).
c
      else if ( start .eq. 1 ) then

        left = -1
        right = start
        return
c
c  XVAL = X(START-1)?
c
      else if ( xval .eq. x(start-1) ) then

        left = start - 1
        right = start - 1
        return
c
c  X(START-1) .lt. XVAL .lt. X(START)?
c
      else if ( x(start-1) .le. xval ) then

        left = start - 1
        right = start
        return
c
c  Binary search for XVAL in [ X(1), X(START-1) ],
c  where XVAL is guaranteed to be less than X(START-1).
c
      else

        low = 1
        high = start - 1
        call r8vec_bracket ( high + 1 - low, x(1), xval, left, right )

      end if

      return
      end
      subroutine r8vec_bracket3 ( n, t, tval, left )

c*********************************************************************72
c
cc R8VEC_BRACKET3 finds the interval containing or nearest a given value.
c
c  Discussion:
c
c    An R8VEC is a vector of R8's.
c
c    The routine always returns the index LEFT of the sorted array
c    T with the property that either
c    *  T is contained in the interval [ T(LEFT), T(LEFT+1) ], or
c    *  T .lt. T(LEFT) = T(1), or
c    *  T > T(LEFT+1) = T(N).
c
c    The routine is useful for interpolation problems, where
c    the abscissa must be located within an interval of data
c    abscissas for interpolation, or the "nearest" interval
c    to the (extreme) abscissa must be found so that extrapolation
c    can be carried out.
c
c  Licensing:
c
c    This code is distributed under the GNU LGPL license.
c
c  Modified:
c
c    28 May 2009
c
c  Author:
c
c    John Burkardt
c
c  Parameters:
c
c    Input, integer N, length of the input array.
c
c    Input, double precision T(N), an array that has been sorted
c    into ascending order.
c
c    Input, double precision TVAL, a value to be bracketed by entries of T.
c
c    Input/output, integer LEFT.
c    On input, if 1 .le. LEFT .le. N-1, LEFT is taken as a suggestion for the
c    interval [ T(LEFT), T(LEFT+1) ] in which TVAL lies.  This interval
c    is searched first, followed by the appropriate interval to the left
c    or right.  After that, a binary search is used.
c    On output, LEFT is set so that the interval [ T(LEFT), T(LEFT+1) ]
c    is the closest to TVAL; it either contains TVAL, or else TVAL
c    lies outside the interval [ T(1), T(N) ].
c
      implicit none

      integer n

      integer high
      integer left
      integer low
      integer mid
      double precision t(n)
      double precision tval
c
c  Check the input data.
c
      if ( n .lt. 2 ) then
        write ( *, '(a)' ) ' '
        write ( *, '(a)' ) 'R8VEC_BRACKET3 - Fatal error!'
        write ( *, '(a)' ) '  N must be at least 2.'
        stop
      end if
c
c  If LEFT is not between 1 and N-1, set it to the middle value.
c
      if ( left .lt. 1 .or. n - 1 .lt. left ) then
        left = ( n + 1 ) / 2
      end if
c
c  CASE 1: TVAL .lt. T(LEFT):
c  Search for TVAL in [T(I), T(I+1)] for intervals I = 1 to LEFT-1.
c
      if ( tval .lt. t(left) ) then

        if ( left .eq. 1 ) then
          return
        else if ( left .eq. 2 ) then
          left = 1
          return
        else if ( t(left-1) .le. tval ) then
          left = left - 1
          return
        else if ( tval .le. t(2) ) then
          left = 1
          return
        end if
c
c  ...Binary search for TVAL in [T(I), T(I+1)] for intervals I = 2 to LEFT-2.
c
        low = 2
        high = left - 2

10      continue

          if ( low .eq. high ) then
            left = low
            return
          end if

          mid = ( low + high + 1 ) / 2

          if ( t(mid) .le. tval ) then
            low = mid
          else
            high = mid - 1
          end if

        go to 10
c
c  CASE2: T(LEFT+1) .lt. TVAL:
c  Search for TVAL in [T(I),T(I+1)] for intervals I = LEFT+1 to N-1.
c
      else if ( t(left+1) .lt. tval ) then

        if ( left .eq. n - 1 ) then
          return
        else if ( left .eq. n - 2 ) then
          left = left + 1
          return
        else if ( tval .le. t(left+2) ) then
          left = left + 1
          return
        else if ( t(n-1) .le. tval ) then
          left = n - 1
          return
        end if
c
c  ...Binary search for TVAL in [T(I), T(I+1)] for intervals I = LEFT+2 to N-2.
c
        low = left + 2
        high = n - 2

20      continue

          if ( low .eq. high ) then
            left = low
            return
          end if

          mid = ( low + high + 1 ) / 2

          if ( t(mid) .le. tval ) then
            low = mid
          else
            high = mid - 1
          end if

        go to 20
c
c  CASE3: T(LEFT) .le. TVAL .le. T(LEFT+1):
c  T is in [T(LEFT), T(LEFT+1)], as the user said it might be.
c
      else

      end if

      return
      end
      subroutine r8vec_bracket4 ( nt, t, ns, s, left )

c*********************************************************************72
c
cc R8VEC_BRACKET4 finds the nearest interval to each of a vector of values.
c
c  Discussion:
c
c    An R8VEC is a vector of R8's.
c
c    The routine always returns the index LEFT of the sorted array
c    T with the property that either
c    *  T is contained in the interval [ T(LEFT), T(LEFT+1) ], or
c    *  T .lt. T(LEFT) = T(1), or
c    *  T > T(LEFT+1) = T(NT).
c
c    The routine is useful for interpolation problems, where
c    the abscissa must be located within an interval of data
c    abscissas for interpolation, or the "nearest" interval
c    to the (extreme) abscissa must be found so that extrapolation
c    can be carried out.
c
c  Licensing:
c
c    This code is distributed under the GNU LGPL license.
c
c  Modified:
c
c    28 May 2009
c
c  Author:
c
c    John Burkardt
c
c  Parameters:
c
c    Input, integer NT, length of the input array.
c
c    Input, double precision T(NT), an array that has been sorted
c    into ascending order.
c
c    Input, integer NS, the number of points to be bracketed.
c
c    Input, double precision S(NS), values to be bracketed by entries of T.
c
c    Output, integer LEFT(NS).
c    LEFT(I) is set so that the interval [ T(LEFT(I)), T(LEFT(I)+1) ]
c    is the closest to S(I); it either contains S(I), or else S(I)
c    lies outside the interval [ T(1), T(NT) ].
c
      implicit none

      integer ns
      integer nt

      integer high
      integer i
      integer left(ns)
      integer low
      integer mid
      double precision s(ns)
      double precision t(nt)
c
c  Check the input data.
c
      if ( nt .lt. 2 ) then
        write ( *, '(a)' ) ' '
        write ( *, '(a)' ) 'R8VEC_BRACKET4 - Fatal error!'
        write ( *, '(a)' ) '  NT must be at least 2.'
        stop
      end if

      do i = 1, ns

        left(i) = ( nt + 1 ) / 2
c
c  CASE 1: S .lt. T(LEFT):
c  Search for S in [T(I), T(I+1)] for intervals I = 1 to LEFT-1.
c
        if ( s(i) .lt. t(left(i)) ) then

          if ( left(i) .eq. 1 ) then
            go to 100
          else if ( left(i) .eq. 2 ) then
            left(i) = 1
            go to 100
          else if ( t(left(i)-1) .le. s(i) ) then
            left(i) = left(i) - 1
            go to 100
          else if ( s(i) .le. t(2) ) then
            left(i) = 1
            go to 100
          end if
c
c  ...Binary search for S in [T(I), T(I+1)] for intervals I = 2 to LEFT-2.
c
          low = 2
          high = left(i) - 2

10        continue

            if ( low .eq. high ) then
              left(i) = low
              go to 20
            end if

            mid = ( low + high + 1 ) / 2

            if ( t(mid) .le. s(i) ) then
              low = mid
            else
              high = mid - 1
            end if

          go to 10

20        continue
c
c  CASE2: T(LEFT+1) .lt. S:
c  Search for S in [T(I),T(I+1)] for intervals I = LEFT+1 to N-1.
c
        else if ( t(left(i)+1) .lt. s(i) ) then

          if ( left(i) .eq. nt - 1 ) then
            go to 100
          else if ( left(i) .eq. nt - 2 ) then
            left(i) = left(i) + 1
            go to 100
          else if ( s(i) .le. t(left(i)+2) ) then
            left(i) = left(i) + 1
            go to 100
          else if ( t(nt-1) .le. s(i) ) then
            left(i) = nt - 1
            go to 100
          end if
c
c  ...Binary search for S in [T(I), T(I+1)] for intervals I = LEFT+2 to NT-2.
c
          low = left(i) + 2
          high = nt - 2

30        continue

            if ( low .eq. high ) then
              left(i) = low
              go to 40
            end if

            mid = ( low + high + 1 ) / 2

            if ( t(mid) .le. s(i) ) then
              low = mid
            else
              high = mid - 1
            end if

          go to 30

40        continue
c
c  CASE3: T(LEFT) .le. S .le. T(LEFT+1):
c  S is in [T(LEFT), T(LEFT+1)].
c
        else

        end if

100     continue

      end do

      return
      end
      function r8vec_bracket5 ( nd, xd, xi )

c*********************************************************************72
c
cc R8VEC_BRACKET5 brackets data between successive entries of a sorted R8VEC.
c
c  Discussion:
c
c    We assume XD is sorted.
c
c    If XI is contained in the interval [XD(1),XD(N)], then the returned 
c    value B indicates that XI is contained in [ XD(B), XD(B+1) ].
c
c    If XI is not contained in the interval [XD(1),XD(N)], then B = -1.
c
c    This code implements a version of binary search which is perhaps more
c    understandable than the usual ones.
c
c  Licensing:
c
c    This code is distributed under the GNU LGPL license.
c
c  Modified:
c
c    14 October 2012
c
c  Author:
c
c    John Burkardt
c
c  Parameters:
c
c    Input, integer ND, the number of data values.
c
c    Input, double precision XD(N), the sorted data.
c
c    Input, double precision XD, the query value.
c
c    Output, integer R8VEC_BRACKET5, the bracket information.
c
      implicit none

      integer nd

      integer b
      integer l
      integer m
      integer r
      integer r8vec_bracket5
      double precision xd(nd)
      double precision xi

      if ( xi .lt. xd(1) .or. xd(nd) .lt. xi ) then

        b = -1

      else

        l = 1
        r = nd

10      continue

        if ( l + 1 .lt. r ) then
          m = ( l + r ) / 2
          if ( xi .lt. xd(m) ) then
            r = m
          else
            l = m
          end if
          go to 10
        end if

        b = l

      end if

      r8vec_bracket5 = b

      return
      end
      subroutine r8vec_bracket6 ( nd, xd, ni, xi, b )

c*********************************************************************72
c
cc R8VEC_BRACKET6 brackets data between successive entries of a sorted R8VEC.
c
c  Discussion:
c
c    We assume XD is sorted.
c
c    If XI(I) is contained in the interval [XD(1),XD(N)], then the value of
c    B(I) indicates that XI(I) is contained in [ XD(B(I)), XD(B(I)+1) ].
c
c    If XI(I) is not contained in the interval [XD(1),XD(N)], then B(I) = -1.
c
c    This code implements a version of binary search which is perhaps more
c    understandable than the usual ones.
c
c  Licensing:
c
c    This code is distributed under the GNU LGPL license.
c
c  Modified:
c
c    14 October 2012
c
c  Author:
c
c    John Burkardt
c
c  Parameters:
c
c    Input, integer ND, the number of data values.
c
c    Input, double precision XD(N), the sorted data.
c
c    Input, integer NI, the number of inquiry values.
c
c    Input, double precision XD(NI), the query values.
c
c    Output, integer B(NI), the bracket information.
c
      implicit none

      integer nd
      integer ni

      integer b(ni)
      integer i
      integer l
      integer m
      integer r
      double precision xd(nd)
      double precision xi(ni)

      do i = 1, ni

        if ( xi(i) .lt. xd(1) .or. xd(nd) .lt. xi(i) ) then

          b(i) = -1

        else

          l = 1
          r = nd

10        continue

          if ( l + 1 < r ) then
            m = ( l + r ) / 2
            if ( xi(i) < xd(m) ) then
              r = m
            else
              l = m
            end if
            go to 10
          end if

          b(i) = l

        end if

      end do

      return
      end
      subroutine r8vec_ceiling ( n, r8vec, ceilingvec )

c*********************************************************************72
c
cc R8VEC_CEILING rounds "up" (towards +infinity) entries of an R8VEC.
c
c  Discussion:
c
c    An R8VEC is a vector of R8's.
c
c  Example:
c
c    R8    Value
c
c   -1.1  -1.0
c   -1.0  -1.0
c   -0.9   0.0
c    0.0   0.0
c    5.0   5.0
c    5.1   6.0
c    5.9   6.0
c    6.0   6.0
c
c  Licensing:
c
c    This code is distributed under the GNU LGPL license.
c
c  Modified:
c
c    28 May 2009
c
c  Author:
c
c    John Burkardt
c
c  Parameters:
c
c    Input, integer N, the number of entries.
c
c    Input, double precision R8VEC(N), the vector.
c
c    Output, double precision CEILINGVEC(N), the rounded values.
c
      implicit none

      integer n

      double precision ceilingvec(n)
      integer i
      double precision r8vec(n)
      double precision value

      do i = 1, n

        value = dble ( int ( r8vec(i) ) )

        if ( value .lt. r8vec(i) ) then
          value = value + 1.0D+00
        end if

        ceilingvec(i) = value

      end do

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

c*********************************************************************72
c
cc R8VEC_CHEBYSPACE creates a vector of Chebyshev spaced values in [A,B].
c
c  Discussion:
c
c    An R8VEC is a vector of R8's.
c
c  Licensing:
c
c    This code is distributed under the GNU LGPL license.
c
c  Modified:
c
c    08 June 2011
c
c  Author:
c
c    John Burkardt
c
c  Parameters:
c
c    Input, integer N, the number of entries in the vector.
c
c    Input, double precision A, B, the interval.
c
c    Output, double precision X(N), a vector of Chebyshev spaced data.
c
      implicit none

      integer n

      double precision a
      double precision b
      double precision c
      integer i
      double precision pi
      parameter ( pi = 3.141592653589793D+00 )
      double precision theta
      double precision x(n)

      if ( n .eq. 1 ) then

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

      else

        do i = 1, n

          theta = dble ( n - i ) * pi / dble ( n - 1 )

          c = cos ( theta )

          if ( mod ( n, 2 ) .eq. 1 ) then
            if ( 2 * i - 1 .eq. n ) then
              c = 0.0D+00
            end if
          end if

          x(i) = ( ( 1.0D+00 - c ) * a
     &           + ( 1.0D+00 + c ) * b ) 
     &           /   2.0D+00

        end do

      end if

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

c*********************************************************************72
c
cc R8VEC_CHEBY1SPACE creates Type 1 Chebyshev spaced values in [A,B].
c
c  Discussion:
c
c    An R8VEC is a vector of R8's.
c
c  Licensing:
c
c    This code is distributed under the GNU LGPL license.
c
c  Modified:
c
c    17 September 2012
c
c  Author:
c
c    John Burkardt
c
c  Parameters:
c
c    Input, integer N, the number of entries in the vector.
c
c    Input, double precision A, B, the first and last entries.
c
c    Output, double precision X(N), a vector of Chebyshev spaced data.
c
      implicit none
 
      integer n

      double precision a
      double precision b
      double precision c
      integer i
      double precision pi
      parameter ( pi = 3.141592653589793D+00 )
      double precision theta
      double precision x(n)

      if ( n .eq. 1 ) then

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

      else

        do i = 1, n

          theta = dble ( 2 * ( n - i ) + 1 ) * pi / dble ( 2 * n )

          c = cos ( theta )

          if ( mod ( n, 2 ) .eq. 1 ) then
            if ( 2 * i - 1 .eq. n ) then
              c = 0.0D+00
            end if
          end if

          x(i) = ( ( 1.0D+00 - c ) * a   
     &           + ( 1.0D+00 + c ) * b ) 
     &           /   2.0D+00

        end do

      end if

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

c*********************************************************************72
c
cc R8VEC_CHEBY2SPACE creates Type 2 Chebyshev spaced values in [A,B].
c
c  Discussion:
c
c    An R8VEC is a vector of R8's.
c
c  Licensing:
c
c    This code is distributed under the GNU LGPL license.
c
c  Modified:
c
c    17 September 2012
c
c  Author:
c
c    John Burkardt
c
c  Parameters:
c
c    Input, integer N, the number of entries in the vector.
c
c    Input, double precision A, B, the first and last entries.
c
c    Output, double precision X(N), a vector of Chebyshev spaced data.
c
      implicit none

      integer n

      double precision a
      double precision b
      double precision c
      integer i
      double precision pi
      parameter ( pi = 3.141592653589793D+00 )
      double precision theta
      double precision x(n)

      if ( n .eq. 1 ) then

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

      else

        do i = 1, n

          theta = dble ( n - i ) * pi / dble ( n - 1 )

          c = cos ( theta )

          if ( mod ( n, 2 ) .eq. 1 ) then
            if ( 2 * i - 1 .eq. n ) then
              c = 0.0D+00
            end if
          end if

          x(i) = ( ( 1.0D+00 - c ) * a   
     &           + ( 1.0D+00 + c ) * b ) 
     &           /   2.0D+00

        end do

      end if

      return
      end
      subroutine r8vec_circular_variance ( n, x, circular_variance )

c*********************************************************************72
c
cc R8VEC_CIRCULAR_VARIANCE returns the circular variance of an R8VEC.
c
c  Discussion:
c
c    An R8VEC is a vector of R8's.
c
c  Licensing:
c
c    This code is distributed under the GNU LGPL license.
c
c  Modified:
c
c    29 May 2009
c
c  Author:
c
c    John Burkardt
c
c  Parameters:
c
c    Input, integer N, the number of entries in the vector.
c
c    Input, double precision X(N), the vector whose variance is desired.
c
c    Output, double precision CIRCULAR VARIANCE, the circular variance
c    of the vector entries.
c
      implicit none

      integer n

      double precision circular_variance
      double precision csum
      integer i
      double precision mean
      double precision ssum
      double precision x(n)

      call r8vec_mean ( n, x, mean )

      csum = 0.0D+00
      do i = 1, n
        csum = csum + cos ( x(i) - mean )
      end do

      ssum = 0.0D+00
      do i = 1, n
        ssum = ssum + sin ( x(i) - mean )
      end do

      circular_variance = csum * csum + ssum * ssum

      circular_variance = sqrt ( circular_variance ) / dble ( n )

      circular_variance = 1.0D+00 - circular_variance

      return
      end
      subroutine r8vec_compare ( n, a1, a2, isgn )

c*********************************************************************72
c
cc R8VEC_COMPARE compares two R8VEC's.
c
c  Discussion:
c
c    An R8VEC is a vector of R8 values.
c
c    The lexicographic ordering is used.
c
c  Example:
c
c    Input:
c
c      A1 = ( 2.0, 6.0, 2.0 )
c      A2 = ( 2.0, 8.0, 12.0 )
c
c    Output:
c
c      ISGN = -1
c
c  Licensing:
c
c    This code is distributed under the GNU LGPL license.
c
c  Modified:
c
c    23 February 1999
c
c  Author:
c
c    John Burkardt
c
c  Parameters:
c
c    Input, integer N, the number of entries in the vectors.
c
c    Input, double precision A1(N), A2(N), the vectors to be compared.
c
c    Output, integer ISGN, the results of the comparison:
c    -1, A1 < A2,
c     0, A1 = A2,
c    +1, A1 > A2.
c
      implicit none

      integer n

      double precision a1(n)
      double precision a2(n)
      integer isgn
      integer k

      isgn = 0

      k = 1

10    continue

      if ( k .le. n ) then

        if ( a1(k) .lt. a2(k) ) then
          isgn = -1
          return
        else if ( a2(k) .lt. a1(k) ) then
          isgn = + 1
          return
        end if

        k = k + 1

        go to 10

      end if

      return
      end
      subroutine r8vec_convolution ( m, x, n, y, z )

c*********************************************************************72
c
cc R8VEC_CONVOLUTION returns the convolution of two R8VEC's.
c
c  Discussion:
c
c    An R8VEC is a vector of R8's.
c
c    The I-th entry of the convolution can be formed by summing the products 
c    that lie along the I-th diagonal of the following table:
c
c    Y3 | 3   4   5   6   7
c    Y2 | 2   3   4   5   6
c    Y1 | 1   2   3   4   5
c       +------------------
c        X1  X2  X3  X4  X5
c
c    which will result in:
c
c    Z = ( X1 * Y1,
c          X1 * Y2 + X2 * Y1,
c          X1 * Y3 + X2 * Y2 + X3 * Y1,
c                    X2 * Y3 + X3 * Y2 + X4 * Y1,
c                              X3 * Y3 + X4 * Y2 + X5 * Y1,
c                                        X4 * Y3 + X5 * Y2,
c                                                  X5 * Y3 )
c            
c  Example:
c
c    Input:
c
c      X = (/ 1, 2, 3, 4 /)
c      Y = (/ -1, 5, 3 /)
c
c    Output:
c
c      Z = (/ -1, 3, 10, 17, 29, 12 /)
c
c  Licensing:
c
c    This code is distributed under the GNU LGPL license.
c
c  Modified:
c
c    05 May 2012
c
c  Author:
c
c    John Burkardt
c
c  Parameters:
c
c    Input, integer M, the dimension of X.
c
c    Input, double precision X(M), the first vector to be convolved.
c
c    Input, integer N, the dimension of Y.
c
c    Input, double precision Y(N), the second vector to be convolved.
c
c    Output, double precision Z(M+N-1), the convolution of X and Y.
c
      implicit none

      integer m
      integer n

      integer i
      integer j
      double precision x(m)
      double precision y(n)
      double precision z(m+n-1)

      do i = 1, m + n - 1
        z(i) = 0.0D+00
      end do

      do j = 1, n
        do i = 0, m - 1
          z(j+i) = z(j+i) + x(i+1) * y(j)
        end do
      end do

      return
      end
      subroutine r8vec_convolution_circ ( n, x, y, z )

c*********************************************************************72
c
cc R8VEC_CONVOLUTION_CIRC returns the discrete circular convolution of two R8VEC's.
c
c  Discussion:
c
c    An R8VEC is a vector of R8's.
c
c    The formula used is:
c
c      z(1+m) = xCCy(m) = sum ( 0 <= k <= n-1 ) x(1+k) * y(1+m-k)
c
c    Here, if the index of Y becomes nonpositive, it is "wrapped around"
c    by having N added to it.
c
c    The circular convolution is equivalent to multiplication of Y by a
c    circulant matrix formed from the vector X.
c
c  Example:
c
c    Input:
c
c      X = (/ 1, 2, 3, 4 /)
c      Y = (/ 1, 2, 4, 8 /)
c
c    Output:
c
c      Circulant form:
c
c      Z = ( 1 4 3 2 )   ( 1 )
c          ( 2 1 4 3 )   ( 2 )
c          ( 3 2 1 4 ) * ( 4 )
c          ( 4 3 2 1 )   ( 8 )
c
c      The formula:
c
c      Z = (/ 1*1 + 2*8 + 3*4 + 4*2,
c             1*2 + 2*1 + 3*8 + 4*4,
c             1*4 + 2*2 + 3*1 + 4*8,
c             1*8 + 2*4 + 3*2 + 4*1 /)
c
c      Result:
c
c      Z = (/ 37, 44, 43, 26 /)
c
c  Licensing:
c
c    This code is distributed under the GNU LGPL license.
c
c  Modified:
c
c    29 May 2009
c
c  Author:
c
c    John Burkardt
c
c  Parameters:
c
c    Input, integer N, the dimension of the vectors.
c
c    Input, double precision X(N), Y(N), the vectors to be convolved.
c
c    Output, double precision Z(N), the circular convolution of X and Y.
c
      implicit none

      integer n

      integer i
      integer m
      double precision x(n)
      double precision y(n)
      double precision z(n)

      do m = 1, n
        z(m) = 0.0D+00
        do i = 1, m
          z(m) = z(m) + x(i) * y(m+1-i)
        end do
        do i = m + 1, n
          z(m) = z(m) + x(i) * y(n+m+1-i)
        end do
      end do

      return
      end
      subroutine r8vec_copy ( n, a1, a2 )

c*********************************************************************72
c
cc R8VEC_COPY copies an R8VEC.
c
c  Discussion:
c
c    An R8VEC is a vector of R8 values.
c
c  Licensing:
c
c    This code is distributed under the GNU LGPL license.
c
c  Modified:
c
c    13 August 2008
c
c  Author:
c
c    John Burkardt
c
c  Parameters:
c
c    Input, integer N, the length of the vectors.
c
c    Input, double precision A1(N), the vector to be copied.
c
c    Output, double precision A2(N), a copy of A1.
c
      implicit none

      integer n

      double precision a1(n)
      double precision a2(n)
      integer i

      do i = 1, n
        a2(i) = a1(i)
      end do

      return
      end
      subroutine r8vec_correlation ( n, x, y, correlation )

c**********************************************************************72
c
cc R8VEC_CORRELATION returns the correlation of two R8VEC's.
c
c  Discussion:
c
c    An R8VEC is a vector of R8's.
c
c    If X and Y are two nonzero vectors of length N, then
c
c      correlation = (x/||x||)' (y/||y||)
c
c    It is the cosine of the angle between the two vectors.
c
c  Licensing:
c
c    This code is distributed under the GNU LGPL license.
c
c  Modified:
c
c    21 August 2010
c
c  Author:
c
c    John Burkardt
c
c  Parameters:
c
c    Input, integer N, the dimension of the vectors.
c
c    Input, double precision X(N), Y(N), the vectors to be convolved.
c
c    Output, double precision CORRELATION, the correlation of X and Y.
c
      implicit none

      integer n

      double precision correlation
      double precision r8vec_dot_product
      double precision r8vec_norm
      double precision x(n)
      double precision x_norm
      double precision xy_dot
      double precision y(n)
      double precision y_norm

      x_norm = r8vec_norm ( n, x )
      y_norm = r8vec_norm ( n, y )
      xy_dot = r8vec_dot_product ( n, x, y )

      if ( x_norm .eq. 0.0D+00 .or. y_norm .eq. 0.0D+00 ) then
        correlation = 0.0D+00
      else
        correlation = xy_dot / x_norm / y_norm
      end if

      return
      end
      function r8vec_cross_product_2d ( v1, v2 )

c*********************************************************************72
c
cc R8VEC_CROSS_PRODUCT_2D finds the cross product of a pair of vectors in 2D.
c
c  Discussion:
c
c    Strictly speaking, the vectors V1 and V2 should be considered
c    to lie in a 3D space, both having Z coordinate zero.  The cross
c    product value V3 then represents the standard cross product vector
c    (0,0,V3).
c
c  Licensing:
c
c    This code is distributed under the GNU LGPL license.
c
c  Modified:
c
c    27 October 2010
c
c  Author:
c
c    John Burkardt
c
c  Parameters:
c
c    Input, double precision V1(2), V2(2), the vectors.
c
c    Output, double precision R8VEC_CROSS_PRODUCT_2D, the cross product.
c
      implicit none

      double precision r8vec_cross_product_2d
      double precision v1(2)
      double precision v2(2)

      r8vec_cross_product_2d = v1(1) * v2(2) - v1(2) * v2(1)

      return
      end
      function r8vec_cross_product_affine_2d ( v0, v1, v2 )

c*********************************************************************72
c
cc R8VEC_CROSS_PRODUCT_AFFINE_2D finds the affine cross product in 2D.
c
c  Discussion:
c
c    Strictly speaking, the vectors V1 and V2 should be considered
c    to lie in a 3D space, both having Z coordinate zero.  The cross
c    product value V3 then represents the standard cross product vector
c    (0,0,V3).
c
c  Licensing:
c
c    This code is distributed under the GNU LGPL license.
c
c  Modified:
c
c    27 October 2010
c
c  Author:
c
c    John Burkardt
c
c  Parameters:
c
c    Input, double precision V0(2), the base vector.
c
c    Input, double precision V1(2), V2(2), the vectors.
c
c    Output, double precision R8VEC_CROSS_PRODUCT_AFFINE_2D,
c    the cross product (V1-V0) x (V2-V0).
c
      implicit none

      double precision r8vec_cross_product_affine_2d
      double precision v0(2)
      double precision v1(2)
      double precision v2(2)

      r8vec_cross_product_affine_2d =
     &    ( v1(1) - v0(1) ) * ( v2(2) - v0(2) )
     &  - ( v2(1) - v0(1) ) * ( v1(2) - v0(2) )

      return
      end
      subroutine r8vec_cross_product_3d ( v1, v2, v3 )

c*********************************************************************72
c
cc R8VEC_CROSS_PRODUCT_3D computes the cross product of two R8VEC's in 3D.
c
c  Discussion:
c
c    An R8VEC is a vector of R8 values.
c
c    The cross product in 3D can be regarded as the determinant of the
c    symbolic matrix:
c
c          |  i  j  k |
c      det | x1 y1 z1 |
c          | x2 y2 z2 |
c
c      = ( y1 * z2 - z1 * y2 ) * i
c      + ( z1 * x2 - x1 * z2 ) * j
c      + ( x1 * y2 - y1 * x2 ) * k
c
c  Licensing:
c
c    This code is distributed under the GNU LGPL license.
c
c  Modified:
c
c    30 August 2008
c
c  Author:
c
c    John Burkardt
c
c  Parameters:
c
c    Input, double precision V1(3), V2(3), the two vectors.
c
c    Output, double precision V3(3), the cross product vector.
c
      implicit none

      integer dim_num
      parameter ( dim_num = 3 )

      double precision v1(dim_num)
      double precision v2(dim_num)
      double precision v3(dim_num)

      v3(1) = v1(2) * v2(3) - v1(3) * v2(2)
      v3(2) = v1(3) * v2(1) - v1(1) * v2(3)
      v3(3) = v1(1) * v2(2) - v1(2) * v2(1)

      return
      end
      subroutine r8vec_cross_product_affine_3d ( v0, v1, v2, v3 )

c*********************************************************************72
c
cc R8VEC_CROSS_PRODUCT_AFFINE_3D computes the affine cross product in 3D.
c
c  Discussion:
c
c    The cross product in 3D can be regarded as the determinant of the
c    symbolic matrix:
c
c          |  i  j  k |
c      det | x1 y1 z1 |
c          | x2 y2 z2 |
c
c      = ( y1 * z2 - z1 * y2 ) * i
c      + ( z1 * x2 - x1 * z2 ) * j
c      + ( x1 * y2 - y1 * x2 ) * k
c
c    Here, we use V0 as the base of an affine system so we compute
c    the cross product of (V1-V0) and (V2-V0).
c
c  Licensing:
c
c    This code is distributed under the GNU LGPL license.
c
c  Modified:
c
c    27 October 2010
c
c  Author:
c
c    John Burkardt
c
c  Parameters:
c
c    Input, double precision V0(3), the base vector.
c
c    Input, double precision V1(3), V2(3), the two vectors.
c
c    Output, double precision V3(3), the cross product vector
c    ( V1-V0) x (V2-V0).
c
      implicit none

      double precision v0(3)
      double precision v1(3)
      double precision v2(3)
      double precision v3(3)

      v3(1) = ( v1(2) - v0(2) ) * ( v2(3) - v0(3) )
     &      - ( v2(2) - v0(2) ) * ( v1(3) - v0(3) )

      v3(2) = ( v1(3) - v0(3) ) * ( v2(1) - v0(1) )
     &      - ( v2(3) - v0(3) ) * ( v1(1) - v0(1) )

      v3(3) = ( v1(1) - v0(1) ) * ( v2(2) - v0(2) )
     &      - ( v2(1) - v0(1) ) * ( v1(2) - v0(2) )

      return
      end
      subroutine r8vec_cum ( n, a, a_cum )

c*********************************************************************72
c
cc R8VEC_CUM computes the cumulutive sums of an R8VEC.
c
c  Discussion:
c
c    An R8VEC is a vector of R8 values.
c
c    Input:
c
c      A = (/ 1.0, 2.0, 3.0, 4.0 /)
c
c    Output:
c
c      A_CUM = (/ 1.0, 3.0, 6.0, 10.0 /)
c
c  Licensing:
c
c    This code is distributed under the GNU LGPL license.
c
c  Modified:
c
c    07 May 2012
c
c  Author:
c
c    John Burkardt
c
c  Parameters:
c
c    Input, integer N, the number of entries in the vector.
c
c    Input, double precision A(N), the vector to be summed.
c
c    Output, double precision A_CUM(N), the cumulative sums.
c
      implicit none

      integer n

      double precision a(n)
      double precision a_cum(n)
      integer i

      a_cum(1) = a(1)

      do i = 2, n
        a_cum(i) = a_cum(i-1) + a(i)
      end do

      return
      end
      subroutine r8vec_cum0 ( n, a, a_cum )

c*********************************************************************72
c
cc R8VEC_CUM0 computes the cumulutive sums of an R8VEC.
c
c  Discussion:
c
c    An R8VEC is a vector of R8 values.
c
c    Input:
c
c      A = (/ 1.0, 2.0, 3.0, 4.0 /)
c
c    Output:
c
c      A_CUM = (/ 0.0, 1.0, 3.0, 6.0, 10.0 /)
c
c  Licensing:
c
c    This code is distributed under the GNU LGPL license.
c
c  Modified:
c
c    07 May 2012
c
c  Author:
c
c    John Burkardt
c
c  Parameters:
c
c    Input, integer N, the number of entries in the vector.
c
c    Input, double precision A(N), the vector to be summed.
c
c    Output, double precision A_CUM(0:N), the cumulative sums.
c
      implicit none

      integer n

      double precision a(n)
      double precision a_cum(0:n)
      integer i

      a_cum(0) = 0.0D+00

      do i = 1, n
        a_cum(i) = a_cum(i-1) + a(i)
      end do

      return
      end
      subroutine r8vec_dif ( n, h, cof )

c*********************************************************************72
c
cc R8VEC_DIF computes coefficients for estimating the N-th derivative.
c
c  Discussion:
c
c    An R8VEC is a vector of R8's.
c
c    The routine computes the N+1 coefficients for a centered finite difference
c    estimate of the N-th derivative of a function.
c
c    The estimate has the form
c
c      FDIF(N,X) = Sum (I = 0 to N) COF(I) * F ( X(I) )
c
c    To understand the computation of the coefficients, it is enough
c    to realize that the first difference approximation is
c
c      FDIF(1,X) = F(X+DX) - F(X-DX) ) / (2*DX)
c
c    and that the second difference approximation can be regarded as
c    the first difference approximation repeated:
c
c      FDIF(2,X) = FDIF(1,X+DX) - FDIF(1,X-DX) / (2*DX)
c         = F(X+2*DX) - 2 F(X) + F(X-2*DX) / (4*DX)
c
c    and so on for higher order differences.
c
c    Thus, the next thing to consider is the integer coefficients of
c    the sampled values of F, which are clearly the Pascal coefficients,
c    but with an alternating negative sign.  In particular, if we
c    consider row I of Pascal's triangle to have entries j = 0 through I,
c    then P(I,J) = P(I-1,J-1) - P(I-1,J), where P(*,-1) is taken to be 0,
c    and P(0,0) = 1.
c
c       1
c      -1  1
c       1 -2   1
c      -1  3  -3   1
c       1 -4   6  -4   1
c      -1  5 -10  10  -5  1
c       1 -6  15 -20  15 -6 1
c
c    Next, note that the denominator of the approximation for the
c    N-th derivative will be (2*DX)**N.
c
c    And finally, consider the location of the N+1 sampling
c    points for F:
c
c      X-N*DX, X-(N-2)*DX, X-(N-4)*DX, ..., X+(N-4)*DX, X+(N-2*DX), X+N*DX.
c
c    Thus, a formula for evaluating FDIF(N,X) is
c
c      fdif = 0.0
c      do i = 0, n
c        xi = x + (2*i-n) * h
c        fdif = fdif + cof(i) * f(xi)
c      end do
c
c  Licensing:
c
c    This code is distributed under the GNU LGPL license.
c
c  Modified:
c
c    29 May 2009
c
c  Author:
c
c    John Burkardt
c
c  Parameters:
c
c    Input, integer N, the order of the derivative to be approximated.
c    N must be 0 or greater.
c
c    Input, double precision H, the half spacing between points.
c    H must be positive.
c
c    Output, double precision COF(0:N), the coefficients needed to approximate
c    the N-th derivative of a function F.
c
      implicit none

      integer n

      double precision cof(0:n)
      double precision h
      integer i
      integer j

      if ( n .lt. 0 ) then
        write ( *, '(a)' ) ' '
        write ( *, '(a)' ) 'R8VEC_DIF - Fatal error!'
        write ( *, '(a,i8)' ) '  Derivative order N = ', n
        write ( *, '(a)' ) '  but N must be at least 0.'
        stop
      end if

      if ( h .le. 0.0D+00 ) then
        write ( *, '(a)' ) ' '
        write ( *, '(a)' ) 'R8VEC_DIF - Fatal error!'
        write ( *, '(a,g14.6)' )
     &    '  The half sampling spacing is H = ', h
        write ( *, '(a)' ) '  but H must be positive.'
        stop
      end if

      do i = 0, n

        cof(i) = 1.0D+00

        do j = i - 1, 1, -1
          cof(j) = -cof(j) + cof(j-1)
        end do

        if ( 0 .lt. i ) then
          cof(0) = -cof(0)
        end if

      end do

      do i = 0, n
        cof(i) = cof(i) / ( 2.0D+00 * h )**n
      end do

      return
      end
      function r8vec_diff_dot_product ( n, u1, v1, u2, v2 )

c*********************************************************************72
c
cc R8VEC_DIFF_DOT_PRODUCT: dot product of a pair of R8VEC differences.
c
c  Discussion:
c
c    An R8VEC is a vector of R8 values.
c
c  Licensing:
c
c    This code is distributed under the GNU LGPL license.
c
c  Modified:
c
c    31 March 2011
c
c  Author:
c
c    John Burkardt
c
c  Parameters:
c
c    Input, integer N, the dimension of the vectors.
c
c    Input, double precision U1(N), V1(N), defines the vector U1-V1.
c
c    Input, double precision U2(N), V2(N), defines the vector U2-V2.
c
c    Output, double precision R8VEC_DIFF_DOT_PRODUCT, the dot product 
c    of (U1-V1)*(U2-V2).
c
      implicit none

      integer n

      integer i
      double precision r8vec_diff_dot_product
      double precision u1(n)
      double precision u2(n)
      double precision v1(n)
      double precision v2(n)
      double precision value

      value = 0.0D+00
      do i = 1, n
        value = value + ( u1(i) - v1(i) ) * ( u2(i) - v2(i) )
      end do

      r8vec_diff_dot_product = value

      return
      end
      function r8vec_diff_norm ( n, a, b )

c*********************************************************************72
c
cc R8VEC_DIFF_NORM returns the L2 norm of the difference of R8VEC's.
c
c  Discussion:
c
c    An R8VEC is a vector of R8 values.
c
c    The vector L2 norm is defined as:
c
c      R8VEC_NORM_L2 = sqrt ( sum ( 1 <= I <= N ) A(I)^2 ).
c
c  Licensing:
c
c    This code is distributed under the GNU LGPL license.
c
c  Modified:
c
c    24 June 2010
c
c  Author:
c
c    John Burkardt
c
c  Parameters:
c
c    Input, integer N, the number of entries in A.
c
c    Input, double precision A(N), B(N), the vectors.
c
c    Output, double precision R8VEC_DIFF_NORM, the L2 norm of A - B.
c
      implicit none

      integer n

      double precision a(n)
      double precision b(n)
      integer i
      double precision r8vec_diff_norm
      double precision value

      value = 0.0D+00
      do i = 1, n
        value = value + ( a(i) - b(i) )**2
      end do
      value = sqrt ( value )

      r8vec_diff_norm = value

      return
      end
      function r8vec_diff_norm_l1 ( n, a, b )

c*********************************************************************72
c
cc R8VEC_DIFF_NORM_L1 returns the L1 norm of the difference of R8VEC's.
c
c  Discussion:
c
c    An R8VEC is a vector of R8's.
c
c    The vector L1 norm is defined as:
c
c      R8VEC_NORM_L1 = sum ( 1 <= I <= N ) abs ( A(I) ).
c
c  Licensing:
c
c    This code is distributed under the GNU LGPL license.
c
c  Modified:
c
c    02 April 2010
c
c  Author:
c
c    John Burkardt
c
c  Parameters:
c
c    Input, integer N, the number of entries in A
c
c    Input, double precision A(N), B(N), the vectors.
c
c    Output, double precision R8VEC_DIFF_NORM_L1, the L1 norm of A - B.
c
      implicit none

      integer n

      double precision a(n)
      double precision b(n)
      integer i
      double precision r8vec_diff_norm_l1

      r8vec_diff_norm_l1 = 0.0D+00
      do i = 1, n
        r8vec_diff_norm_l1 = r8vec_diff_norm_l1 + abs ( a(i) - b(i) )
      end do

      return
      end
      function r8vec_diff_norm_l2 ( n, a, b )

c*********************************************************************72
c
cc R8VEC_DIFF_NORM_L2 returns the L2 norm of the difference of R8VEC's.
c
c  Discussion:
c
c    An R8VEC is a vector of R8 values.
c
c    The vector L2 norm is defined as:
c
c      R8VEC_NORM_L2 = sqrt ( sum ( 1 <= I <= N ) A(I)^2 ).
c
c  Licensing:
c
c    This code is distributed under the GNU LGPL license.
c
c  Modified:
c
c    24 June 2010
c
c  Author:
c
c    John Burkardt
c
c  Parameters:
c
c    Input, integer N, the number of entries in A.
c
c    Input, double precision A(N), B(N), the vectors.
c
c    Output, double precision R8VEC_DIFF_NORM_L2, the L2 norm of A - B.
c
      implicit none

      integer n

      double precision a(n)
      double precision b(n)
      integer i
      double precision r8vec_diff_norm_l2
      double precision value

      value = 0.0D+00
      do i = 1, n
        value = value + ( a(i) - b(i) )**2
      end do
      value = sqrt ( value )

      r8vec_diff_norm_l2 = value

      return
      end
      function r8vec_diff_norm_li ( n, a, b )

c*********************************************************************72
c
cc R8VEC_DIFF_NORM_LI returns the L-infinity norm of the difference of R8VEC's.
c
c  Discussion:
c
c    An R8VEC is a vector of R8's.
c
c    The vector L-infinity norm is defined as:
c
c      R8VEC_NORM_LI = max ( 1 <= I <= N ) abs ( A(I) ).
c
c  Licensing:
c
c    This code is distributed under the GNU LGPL license.
c
c  Modified:
c
c    02 April 2010
c
c  Author:
c
c    John Burkardt
c
c  Parameters:
c
c    Input, integer N, the number of entries in A.
c
c    Input, double precision A(N), B(N), the vectors.
c
c    Output, double precision R8VEC_DIFF_NORM_LI, the L-infinity norm of A - B.
c
      implicit none

      integer n

      double precision a(n)
      double precision b(n)
      integer i
      double precision r8vec_diff_norm_li

      r8vec_diff_norm_li = 0.0D+00
      do i = 1, n
        r8vec_diff_norm_li =
     &    max ( r8vec_diff_norm_li, abs ( a(i) - b(i) ) )
      end do

      return
      end
      function r8vec_diff_norm_squared ( n, a, b )

c*********************************************************************72
c
cc R8VEC_DIFF_NORM_SQUARED: square of the L2 norm of the difference of R8VEC's.
c
c  Discussion:
c
c    An R8VEC is a vector of R8 values.
c
c    R8VEC_DIFF_NORM_SQUARED = sum ( 1 <= I <= N ) ( A(I) - B(I) )^2
c
c  Licensing:
c
c    This code is distributed under the GNU LGPL license.
c
c  Modified:
c
c    24 June 2011
c
c  Author:
c
c    John Burkardt
c
c  Parameters:
c
c    Input, integer N, the number of entries in A.
c
c    Input, double precision A(N), B(N), the vectors.
c
c    Output, double precision R8VEC_DIFF_NORM_SQUARED, the square
c    of the L2 norm of A - B.
c
      implicit none

      integer n

      double precision a(n)
      double precision b(n)
      integer i
      double precision r8vec_diff_norm_squared
      double precision value

      value = 0.0D+00
      do i = 1, n
        value = value + ( a(i) - b(i) )**2
      end do

      r8vec_diff_norm_squared = value

      return
      end
      subroutine r8vec_direct_product ( factor_index, factor_order,
     &  factor_value, factor_num, point_num, x )

c*********************************************************************72
c
cc R8VEC_DIRECT_PRODUCT creates a direct product of R8VEC's.
c
c  Discussion:
c
c    An R8VEC is a vector of R8's.
c
c    To explain what is going on here, suppose we had to construct
c    a multidimensional quadrature rule as the product of K rules
c    for 1D quadrature.
c
c    The product rule will be represented as a list of points and weights.
c
c    The J-th item in the product rule will be associated with
c      item J1 of 1D rule 1,
c      item J2 of 1D rule 2,
c      ...,
c      item JK of 1D rule K.
c
c    In particular,
c      X(J) = ( X(1,J1), X(2,J2), ..., X(K,JK))
c    and
c      W(J) = W(1,J1) * W(2,J2) * ... * W(K,JK)
c
c    So we can construct the quadrature rule if we can properly
c    distribute the information in the 1D quadrature rules.
c
c    This routine carries out that task for the abscissas X.
c
c    Another way to do this would be to compute, one by one, the
c    set of all possible indices (J1,J2,...,JK), and then index
c    the appropriate information.  An advantage of the method shown
c    here is that you can process the K-th set of information and
c    then discard it.
c
c  Example:
c
c    Rule 1:
c      Order = 4
c      X(1:4) = ( 1, 2, 3, 4 )
c
c    Rule 2:
c      Order = 3
c      X(1:3) = ( 10, 20, 30 )
c
c    Rule 3:
c      Order = 2
c      X(1:2) = ( 100, 200 )
c
c    Product Rule:
c      Order = 24
c      X(1:24) =
c        ( 1, 10, 100 )
c        ( 2, 10, 100 )
c        ( 3, 10, 100 )
c        ( 4, 10, 100 )
c        ( 1, 20, 100 )
c        ( 2, 20, 100 )
c        ( 3, 20, 100 )
c        ( 4, 20, 100 )
c        ( 1, 30, 100 )
c        ( 2, 30, 100 )
c        ( 3, 30, 100 )
c        ( 4, 30, 100 )
c        ( 1, 10, 200 )
c        ( 2, 10, 200 )
c        ( 3, 10, 200 )
c        ( 4, 10, 200 )
c        ( 1, 20, 200 )
c        ( 2, 20, 200 )
c        ( 3, 20, 200 )
c        ( 4, 20, 200 )
c        ( 1, 30, 200 )
c        ( 2, 30, 200 )
c        ( 3, 30, 200 )
c        ( 4, 30, 200 )
c
c  Licensing:
c
c    This code is distributed under the GNU LGPL license.
c
c  Modified:
c
c    27 August 2008
c
c  Author:
c
c    John Burkardt
c
c  Parameters:
c
c    Input, integer FACTOR_INDEX, the index of the factor being processed.
c    The first factor processed must be factor 1!
c
c    Input, integer FACTOR_ORDER, the order of the factor.
c
c    Input, double precision FACTOR_VALUE(FACTOR_ORDER), the factor values
c    for factor FACTOR_INDEX.
c
c    Input, integer FACTOR_NUM, the number of factors.
c
c    Input, integer POINT_NUM, the number of elements in the direct product.
c
c    Input/output, double precision X(FACTOR_NUM,POINT_NUM), the elements of the
c    direct product, which are built up gradually.  Before the first call,
c    X might be set to 0.  After each factor has been input, X should
c    have the correct value.
c
c  Local Parameters:
c
c    Local, integer START, the first location of a block of values to set.
c
c    Local, integer CONTIG, the number of consecutive values to set.
c
c    Local, integer SKIP, the distance from the current value of START
c    to the next location of a block of values to set.
c
c    Local, integer REP, the number of blocks of values to set.
c
      implicit none

      integer factor_num
      integer factor_order
      integer point_num

      integer contig
      integer factor_index
      double precision factor_value(factor_order)
      integer i
      integer j
      integer k
      integer rep
      integer skip
      integer start
      double precision x(factor_num,point_num)

      save contig
      save rep
      save skip

      data contig / 0 /
      data rep / 0 /
      data skip / 0 /

      if ( factor_index .eq. 1 ) then
        contig = 1
        skip = 1
        rep = point_num
      end if

      rep = rep / factor_order
      skip = skip * factor_order

      do j = 1, factor_order

        start = 1 + ( j - 1 ) * contig

        do k = 1, rep
          do i = start, start+contig-1
            x(factor_index,i) = factor_value(j)
          end do
          start = start + skip
        end do

      end do

      contig = contig * factor_order

      return
      end
      subroutine r8vec_direct_product2 ( factor_index, factor_order,
     &  factor_value, factor_num, point_num, w )

c*********************************************************************72
c
cc R8VEC_DIRECT_PRODUCT2 creates a direct product of R8VEC's.
c
c  Discussion:
c
c    An R8VEC is a vector of R8's.
c
c    To explain what is going on here, suppose we had to construct
c    a multidimensional quadrature rule as the product of K rules
c    for 1D quadrature.
c
c    The product rule will be represented as a list of points and weights.
c
c    The J-th item in the product rule will be associated with
c      item J1 of 1D rule 1,
c      item J2 of 1D rule 2,
c      ...,
c      item JK of 1D rule K.
c
c    In particular,
c      X(J) = ( X(1,J1), X(2,J2), ..., X(K,JK))
c    and
c      W(J) = W(1,J1) * W(2,J2) * ... * W(K,JK)
c
c    So we can construct the quadrature rule if we can properly
c    distribute the information in the 1D quadrature rules.
c
c    This routine carries out the task involving the weights W.
c
c    Another way to do this would be to compute, one by one, the
c    set of all possible indices (J1,J2,...,JK), and then index
c    the appropriate information.  An advantage of the method shown
c    here is that you can process the K-th set of information and
c    then discard it.
c
c  Example:
c
c    Rule 1:
c      Order = 4
c      W(1:4) = ( 2, 3, 5, 7 )
c
c    Rule 2:
c      Order = 3
c      W(1:3) = ( 11, 13, 17 )
c
c    Rule 3:
c      Order = 2
c      W(1:2) = ( 19, 23 )
c
c    Product Rule:
c      Order = 24
c      W(1:24) =
c        ( 2 * 11 * 19 )
c        ( 3 * 11 * 19 )
c        ( 4 * 11 * 19 )
c        ( 7 * 11 * 19 )
c        ( 2 * 13 * 19 )
c        ( 3 * 13 * 19 )
c        ( 5 * 13 * 19 )
c        ( 7 * 13 * 19 )
c        ( 2 * 17 * 19 )
c        ( 3 * 17 * 19 )
c        ( 5 * 17 * 19 )
c        ( 7 * 17 * 19 )
c        ( 2 * 11 * 23 )
c        ( 3 * 11 * 23 )
c        ( 5 * 11 * 23 )
c        ( 7 * 11 * 23 )
c        ( 2 * 13 * 23 )
c        ( 3 * 13 * 23 )
c        ( 5 * 13 * 23 )
c        ( 7 * 13 * 23 )
c        ( 2 * 17 * 23 )
c        ( 3 * 17 * 23 )
c        ( 5 * 17 * 23 )
c        ( 7 * 17 * 23 )
c
c  Licensing:
c
c    This code is distributed under the GNU LGPL license.
c
c  Modified:
c
c    27 August 2008
c
c  Author:
c
c    John Burkardt
c
c  Parameters:
c
c    Input, integer FACTOR_INDEX, the index of the factor being processed.
c    The first factor processed must be factor 1!
c
c    Input, integer FACTOR_ORDER, the order of the factor.
c
c    Input, double precision FACTOR_VALUE(FACTOR_ORDER), the factor values
c    for factor FACTOR_INDEX.
c
c    Input, integer FACTOR_NUM, the number of factors.
c
c    Input, integer POINT_NUM, the number of elements in the direct product.
c
c    Input/output, double precision W(POINT_NUM), the elements of the
c    direct product, which are built up gradually.  Before the first call,
c    W should be set to 1.
c
c  Local Parameters:
c
c    Local, integer START, the first location of a block of values to set.
c
c    Local, integer CONTIG, the number of consecutive values to set.
c
c    Local, integer SKIP, the distance from the current value of START
c    to the next location of a block of values to set.
c
c    Local, integer REP, the number of blocks of values to set.
c
      implicit none

      integer factor_num
      integer factor_order
      integer point_num

      integer contig
      integer factor_index
      double precision factor_value(factor_order)
      integer i
      integer j
      integer k
      integer rep
      integer skip
      integer start
      double precision w(point_num)

      save contig
      save rep
      save skip

      data contig / 0 /
      data rep / 0 /
      data skip / 0 /

      if ( factor_index .eq. 1 ) then
        contig = 1
        skip = 1
        rep = point_num
      end if

      rep = rep / factor_order
      skip = skip * factor_order

      do j = 1, factor_order

        start = 1 + ( j - 1 ) * contig

        do k = 1, rep
          do i = start, start+contig-1
            w(i) = w(i) * factor_value(j)
          end do
          start = start + skip
        end do

      end do

      contig = contig * factor_order

      return
      end
      function r8vec_distance ( dim_num, v1, v2 )

c*********************************************************************72
c
cc R8VEC_DISTANCE returns the Euclidean distance between two R8VEC's.
c
c  Discussion:
c
c    An R8VEC is a vector of R8's.
c
c  Licensing:
c
c    This code is distributed under the GNU LGPL license.
c
c  Modified:
c
c    29 May 2009
c
c  Author:
c
c    John Burkardt
c
c  Parameters:
c
c    Input, integer DIM_NUM, the spatial dimension.
c
c    Input, double precision V1(DIM_NUM), V2(DIM_NUM), the vectors.
c
c    Output, double precision R8VEC_DISTANCE, the Euclidean distance
c    between the vectors.
c
      implicit none

      integer dim_num

      integer i
      double precision r8vec_distance
      double precision v1(dim_num)
      double precision v2(dim_num)

      r8vec_distance = 0.0D+00

      do i = 1, dim_num
        r8vec_distance = r8vec_distance + ( v1(i) - v2(i) )**2
      end do

      r8vec_distance = sqrt ( r8vec_distance )

      return
      end
      function r8vec_distinct ( n, a )

c*********************************************************************72
c
cc R8VEC_DISTINCT is true if the entries in an R8VEC are distinct.
c
c  Discussion:
c
c    An R8VEC is a vector of R8's.
c
c  Licensing:
c
c    This code is distributed under the GNU LGPL license.
c
c  Modified:
c
c    29 May 2009
c
c  Author:
c
c    John Burkardt
c
c  Parameters:
c
c    Input, integer N, the number of entries in the vector.
c
c    Input, double precision A(N), the vector to be checked.
c
c    Output, logical R8VEC_DISTINCT is TRUE if the elements of A are distinct.
c
      implicit none

      integer n

      double precision a(n)
      integer i
      integer j
      logical r8vec_distinct

      r8vec_distinct = .false.

      do i = 2, n
        do j = 1, i - 1
          if ( a(i) .eq. a(j) ) then
            return
          end if
        end do
      end do

      r8vec_distinct = .true.

      return
      end
      function r8vec_dot_product ( n, v1, v2 )

c*********************************************************************72
c
cc R8VEC_DOT_PRODUCT finds the dot product of a pair of R8VEC's.
c
c  Discussion:
c
c    An R8VEC is a vector of R8 values.
c
c    In FORTRAN90, the system routine DOT_PRODUCT should be called
c    directly.
c
c  Licensing:
c
c    This code is distributed under the GNU LGPL license.
c
c  Modified:
c
c    27 May 2008
c
c  Author:
c
c    John Burkardt
c
c  Parameters:
c
c    Input, integer N, the dimension of the vectors.
c
c    Input, double precision V1(N), V2(N), the vectors.
c
c    Output, double precision R8VEC_DOT_PRODUCT, the dot product.
c
      implicit none

      integer n

      integer i
      double precision r8vec_dot_product
      double precision v1(n)
      double precision v2(n)
      double precision value

      value = 0.0D+00
      do i = 1, n
        value = value + v1(i) * v2(i)
      end do

      r8vec_dot_product = value

      return
      end
      function r8vec_dot_product_affine ( n, v0, v1, v2 )

c*********************************************************************72
c
cc R8VEC_DOT_PRODUCT_AFFINE computes the affine dot product V1-V0 * V2-V0.
c
c  Licensing:
c
c    This code is distributed under the GNU LGPL license.
c
c  Modified:
c
c    27 October 2010
c
c  Author:
c
c    John Burkardt
c
c  Parameters:
c
c    Input, integer N, the spatial dimension.
c
c    Input, double precision V0(N), the base vector.
c
c    Input, double precision V1(N), V2(N), the vectors.
c
c    Output, double precision R8VEC_DOT_PRODUCT_AFFINE, the dot product.
c
      implicit none

      integer n

      integer i
      double precision r8vec_dot_product_affine
      double precision v0(n)
      double precision v1(n)
      double precision v2(n)

      r8vec_dot_product_affine = 0.0D+00

      do i = 1, n
        r8vec_dot_product_affine = r8vec_dot_product_affine
     &    + ( v1(i) - v0(i) ) * ( v2(i) - v0(i) )
      end do

      return
      end
      function r8vec_eq ( n, a1, a2 )

c*********************************************************************72
c
cc R8VEC_EQ is true if every pair of entries in two vectors is equal.
c
c  Discussion:
c
c    An R8VEC is a vector of R8's.
c
c  Licensing:
c
c    This code is distributed under the GNU LGPL license.
c
c  Modified:
c
c    22 July 2008
c
c  Author:
c
c    John Burkardt
c
c  Parameters:
c
c    Input, integer N, the number of entries in the vectors.
c
c    Input, double precision A1(N), A2(N), two vectors to compare.
c
c    Output, logical R8VEC_EQ.
c    R8VEC_EQ is .TRUE. if every pair of elements A1(I) and A2(I) are equal,
c    and .FALSE. otherwise.
c
      implicit none

      integer n

      double precision a1(n)
      double precision a2(n)
      integer i
      logical r8vec_eq

      r8vec_eq = .false.

      do i = 1, n
        if ( a1(i) .ne. a2(i) ) then
          return
        end if
      end do

      r8vec_eq = .true.

      return
      end
      subroutine r8vec_even ( n, alo, ahi, a )

c*********************************************************************72
c
cc R8VEC_EVEN returns an R8VEC of evenly spaced values.
c
c  Discussion:
c
c    An R8VEC is a vector of R8 values.
c
c    If N is 1, then the midpoint is returned.
c
c    Otherwise, the two endpoints are returned, and N-2 evenly
c    spaced points between them.
c
c  Licensing:
c
c    This code is distributed under the GNU LGPL license.
c
c  Modified:
c
c    09 December 2004
c
c  Author:
c
c    John Burkardt
c
c  Parameters:
c
c    Input, integer N, the number of values.
c
c    Input, double precision ALO, AHI, the low and high values.
c
c    Output, double precision A(N), N evenly spaced values.
c    Normally, A(1) = ALO and A(N) = AHI.
c    However, if N = 1, then A(1) = 0.5*(ALO+AHI).
c
      implicit none

      integer n

      double precision a(n)
      double precision ahi
      double precision alo
      integer i

      if ( n .eq. 1 ) then

        a(1) = 0.5D+00 * ( alo + ahi )

      else

        do i = 1, n
          a(i) = ( dble ( n - i     ) * alo
     &           + dble (     i - 1 ) * ahi )
     &           / dble ( n     - 1 )
        end do

      end if

      return
      end
      subroutine r8vec_even_select ( n, xlo, xhi, ival, xval )

c*********************************************************************72
c
cc R8VEC_EVEN_SELECT returns the I-th of N evenly spaced values in [ XLO, XHI ].
c
c  Discussion:
c
c    An R8VEC is a vector of R8's.
c
c    XVAL = ( (N-IVAL) * XLO + (IVAL-1) * XHI ) / real ( N - 1 )
c
c    Unless N = 1, X(1) = XLO and X(N) = XHI.
c
c    If N = 1, then X(1) = 0.5*(XLO+XHI).
c
c  Licensing:
c
c    This code is distributed under the GNU LGPL license.
c
c  Modified:
c
c    29 May 2009
c
c  Author:
c
c    John Burkardt
c
c  Parameters:
c
c    Input, integer N, the number of values.
c
c    Input, double precision XLO, XHI, the low and high values.
c
c    Input, integer IVAL, the index of the desired point.
c    IVAL is normally between 1 and N, but may be any integer value.
c
c    Output, double precision XVAL, the IVAL-th of N evenly spaced values
c    between XLO and XHI.
c
      implicit none

      integer n

      integer ival
      double precision xhi
      double precision xlo
      double precision xval

      if ( n .eq. 1 ) then

        xval = 0.5D+00 * ( xlo + xhi )

      else

        xval = ( dble ( n - ival     ) * xlo
     &         + dble (     ival - 1 ) * xhi )
     &         / dble ( n        - 1 )

      end if

      return
      end
      subroutine r8vec_even2 ( maxval, nfill, nold, xold, nval, xval )

c*********************************************************************72
c
cc R8VEC_EVEN2 linearly interpolates new numbers into an R8VEC.
c
c  Discussion:
c
c    An R8VEC is a vector of R8's.
c
c    The number of values created between two old values can vary from
c    one pair of values to the next.
c
c    The interpolated values are evenly spaced.
c
c    This routine is a generalization of R8VEC_EVEN.
c
c  Licensing:
c
c    This code is distributed under the GNU LGPL license.
c
c  Modified:
c
c    30 May 2009
c
c  Author:
c
c    John Burkardt
c
c  Parameters:
c
c    Input, integer MAXVAL, the size of the XVAL array, as declared
c    by the user.  MAXVAL must be large enough to hold the NVAL values computed
c    by this routine.  In other words, MAXVAL must be at least equal to
c    NOLD + SUM (1 <= I <= NOLD-1) NFILL(I).
c
c    Input, integer NFILL(NOLD-1), the number of values
c    to be interpolated between XOLD(I) and XOLD(I+1).
c    NFILL(I) does not count the endpoints.  Thus, if
c    NFILL(I) is 1, there will be one new point generated
c    between XOLD(I) and XOLD(I+1).
c    NFILL(I) must be nonnegative.
c
c    Input, integer NOLD, the number of values XOLD,
c    between which extra values are to be interpolated.
c
c    Input, double precision XOLD(NOLD), the original vector of numbers
c    between which new values are to be interpolated.
c
c    Output, integer NVAL, the number of values computed
c    in the XVAL array.
c    NVAL = NOLD + SUM ( 1 <= I <= NOLD-1 ) NFILL(I)
c
c    Output, doble precision XVAL(MAXVAL).  On output, XVAL contains the
c    NOLD values of XOLD, as well as the interpolated
c    values, making a total of NVAL values.
c
      implicit none

      integer maxval
      integer nold

      integer i
      integer j
      integer nadd
      integer nfill(nold-1)
      integer nval
      double precision xold(nold)
      double precision xval(maxval)

      nval = 1

      do i = 1, nold - 1

        if ( nfill(i) .lt. 0 ) then
          write ( *, '(a)' ) ' '
          write ( *, '(a)' ) 'R8VEC_EVEN2 - Fatal error!'
          write ( *, '(a,i8)' ) '  NFILL(I) is negative for I = ', i
          write ( *, '(a,i8)' ) '  NFILL(I) = ', nfill(i)
          stop
        end if

        if ( maxval .lt. nval + nfill(i) + 1 ) then
          write ( *, '(a)' ) ' '
          write ( *, '(a)' ) 'R8VEC_EVEN2 - Fatal error!'
          write ( *, '(a)' ) '  MAXVAL is not large enough.  '
          write ( *, '(a,i8)' ) '  MAXVAL = ', maxval
          write ( *, '(a)' )
     &      '  which is exceeded by storage requirements'
          write ( *, '(a,i8)' ) '  for interpolating in interval ', i
          stop
        end if

        nadd = nfill(i) + 2

        do j = 1, nadd
          xval(nval+j-1) = ( dble ( nadd - j     ) * xold(i)
     &                     + dble (        j - 1 ) * xold(i+1) )
     &                     / dble ( nadd     - 1 )
        end do

        nval = nval + nfill(i) + 1

      end do

      return
      end
      subroutine r8vec_even2_select ( n, xlo, xhi, ival, xval )

c*********************************************************************72
c
cc R8VEC_EVEN2_SELECT returns the I-th of N evenly spaced midpoint values.
c
c  Discussion:
c
c    An R8VEC is a vector of R8's.
c
c    This function returns the I-th of N evenly spaced midpoints of N
c    equal subintervals of [XLO,XHI].
c
c    XVAL = ( ( 2 * N - 2 * IVAL + 1 ) * XLO 
c           + (         2 * IVAL - 1 ) * XHI ) 
c           / ( 2 * N                )
c
c  Licensing:
c
c    This code is distributed under the GNU LGPL license.
c
c  Modified:
c
c    25 July 2012
c
c  Author:
c
c    John Burkardt
c
c  Parameters:
c
c    Input, integer N, the number of values.
c
c    Input, double precision XLO, XHI, the low and high values.
c
c    Input, integer IVAL, the index of the desired point.
c    IVAL is normally between 1 and N, but may be any integer value.
c
c    Output, double precision XVAL, the IVAL-th of N evenly spaced midpoints
c    between XLO and XHI.
c
      implicit none

      integer n

      integer ival
      double precision xhi
      double precision xlo
      double precision xval

      xval = ( dble ( 2 * n - 2 * ival + 1 ) * xlo   
     &       + dble (         2 * ival - 1 ) * xhi ) 
     &       / dble ( 2 * n )

      return
      end
      subroutine r8vec_even3 ( nold, nval, xold, xval )

c*********************************************************************72
c
cc R8VEC_EVEN3 evenly interpolates new data into an R8VEC.
c
c  Discussion:
c
c    An R8VEC is a vector of R8's.
c
c    This routine accepts a short vector of numbers, and returns a longer
c    vector of numbers, created by interpolating new values between
c    the given values.
c
c    Between any two original values, new values are evenly interpolated.
c
c    Over the whole vector, the new numbers are interpolated in
c    such a way as to try to minimize the largest distance interval size.
c
c    The algorithm employed is not "perfect".
c
c  Licensing:
c
c    This code is distributed under the GNU LGPL license.
c
c  Modified:
c
c    03 June 2009
c
c  Author:
c
c    John Burkardt
c
c  Parameters:
c
c    Input, integer NOLD, the number of values XOLD, between
c    which extra values are to be interpolated.
c
c    Input, integer NVAL, the number of values to be computed
c    in the XVAL array.  NVAL should be at least NOLD.
c
c    Input, double precision XOLD(NOLD), the original vector of numbers
c    between which new values are to be interpolated.
c
c    Output, double precision XVAL(NVAL).  On output, XVAL contains the
c    NOLD values of XOLD, as well as interpolated
c    values, making a total of NVAL values.
c
      implicit none

      integer nval
      integer nold

      double precision density
      integer i
      integer ival
      integer j
      integer nmaybe
      integer npts
      integer ntemp
      integer ntot
      double precision xlen
      double precision xleni
      double precision xlentot
      double precision xold(nold)
      double precision xval(nval)

      xlen = 0.0D+00
      do i = 1, nold - 1
        xlen = xlen + abs ( xold(i+1) - xold(i) )
      end do

      ntemp = nval - nold

      density = dble ( ntemp ) / xlen

      ival = 1
      ntot = 0
      xlentot = 0.0D+00

      do i = 1, nold - 1

        xleni = abs ( xold(i+1) - xold(i) )
        npts = int ( density * xleni )
        ntot = ntot + npts
c
c  Determine if we have enough left-over density that it should
c  be changed into a point.  A better algorithm would agonize
c  more over where that point should go.
c
        xlentot = xlentot + xleni
        nmaybe = nint ( xlentot * density )

        if ( ntot .lt. nmaybe ) then
          npts = npts + nmaybe - ntot
          ntot = nmaybe
        end if

        do j = 1, npts + 2
          xval(ival+j-1) = ( dble ( npts+2 - j     ) * xold(i)
     &                     + dble (          j - 1 ) * xold(i+1) )
     &                     / dble ( npts+2     - 1 )
        end do

        ival = ival + npts + 1

      end do

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

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

      integer fat
      integer n

      integer i
      integer j
      integer k
      double precision x(n)
      double precision 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) = ( dble ( fat - j + 1 ) * x(i)
     &              + dble (       j     ) * x(i+1) )
     &              / dble ( fat     + 1 )
        end do

      end do

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

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

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

      integer after
      integer before
      integer fat
      integer n

      integer i
      integer j
      integer k
      double precision x(n)
      double precision xfat(before+(n-1)*(fat+1)+1+after)

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

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

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

      end do

      k = k + 1
      xfat(k) = x(n)
c
c  Points AFTER.
c
      do j = 1, after
        k = k + 1
        xfat(k) =
     &    ( dble ( fat - j + 1 ) * x(n)
     &    + dble (       j     ) * ( x(n) + ( x(n) - x(n-1) ) ) )
     &    / dble ( fat     + 1 )
      end do

      return
      end
      subroutine r8vec_first_index ( n, a, tol, first_index )

c*********************************************************************72
c
cc R8VEC_FIRST_INDEX indexes the first occurrence of values in an R8VEC.
c
c  Discussion:
c
c    An R8VEC is a vector of R8's.
c
c    For element A(I) of the vector, FIRST(I) is the index in A of
c    the first occurrence of the value A(I).
c
c  Licensing:
c
c    This code is distributed under the GNU LGPL license.
c
c  Modified:
c
c    24 August 2008
c
c  Author:
c
c    John Burkardt
c
c  Parameters:
c
c    Input, integer N, the number of elements of A.
c
c    Input, double precision A(N), the unsorted array to examine.
c
c    Input, double precision TOL, a tolerance for equality.
c
c    Output, integer FIRST_INDEX(N), the first occurrence index.
c
      implicit none

      integer n

      double precision a(n)
      integer first_index(n)
      integer i
      integer j
      double precision tol

      do i = 1, n
        first_index(i) = -1
      end do

      do i = 1, n

        if ( first_index(i) .eq. -1 ) then

          first_index(i) = i

          do j = i + 1, n
            if ( abs ( a(i) - a(j) ) .le. tol ) then
              first_index(j) = i
            end if
          end do

        end if

      end do

      return
      end
      subroutine r8vec_floor ( n, r8vec, floorvec )

c*********************************************************************72
c
cc R8VEC_FLOOR rounds "down" (towards -infinity) entries of an R8VEC.
c
c  Discussion:
c
c    An R8VEC is a vector of R8's.
c
c  Example:
c
c    R8    Value
c
c   -1.1  -2
c   -1.0  -1
c   -0.9  -1
c    0.0   0
c    5.0   5
c    5.1   5
c    5.9   5
c    6.0   6
c
c  Licensing:
c
c    This code is distributed under the GNU LGPL license.
c
c  Modified:
c
c    30 May 2009
c
c  Author:
c
c    John Burkardt
c
c  Parameters:
c
c    Input, integer N, the number of entries.
c
c    Input, double precision R8VEC(N), the values to be rounded down.
c
c    Output, integer FLOORVEC(N), the rounded value.
c
      implicit none

      integer n

      integer floorvec(n)
      integer i
      double precision r8vec(n)
      integer value

      do i = 1, n

        value = int ( r8vec(i) )

        if ( r8vec(i) .lt. dble ( value ) ) then
          value = value - 1
        end if

        floorvec(i) = value

      end do

      return
      end
      subroutine r8vec_frac ( n, a, k, frac )

c*********************************************************************72
c
cc R8VEC_FRAC searches for the K-th smallest entry in an R8VEC.
c
c  Discussion:
c
c    An R8VEC is a vector of R8 values.
c
c    Hoare's algorithm is used.
c
c  Licensing:
c
c    This code is distributed under the GNU LGPL license.
c
c  Modified:
c
c    17 July 2000
c
c  Author:
c
c    John Burkardt
c
c  Parameters:
c
c    Input, integer N, the number of elements of A.
c
c    Input/output, double precision A(N).
c    On input, A is the array to search.
c    On output, the elements of A have been somewhat rearranged.
c
c    Input, integer K, the fractile to be sought.  If K = 1, the minimum
c    entry is sought.  If K = N, the maximum is sought.  Other values
c    of K search for the entry which is K-th in size.  K must be at
c    least 1, and no greater than N.
c
c    Output, double precision FRAC, the value of the K-th fractile of A.
c
      implicit none

      integer n

      double precision a(n)
      double precision frac
      integer i
      integer iryt
      integer j
      integer k
      integer left
      double precision temp
      double precision x

      if ( n .le. 0 ) then
        write ( *, '(a)' ) ' '
        write ( *, '(a)' ) 'R8VEC_FRAC - Fatal error!'
        write ( *, '(a,i8)' ) '  Illegal nonpositive value of N = ', n
        stop
      end if

      if ( k .le. 0 ) then
        write ( *, '(a)' ) ' '
        write ( *, '(a)' ) 'R8VEC_FRAC - Fatal error!'
        write ( *, '(a,i8)' ) '  Illegal nonpositive value of K = ', k
        stop
      end if

      if ( n .lt. k ) then
        write ( *, '(a)' ) ' '
        write ( *, '(a)' ) 'R8VEC_FRAC - Fatal error!'
        write ( *, '(a,i8)' ) '  Illegal N < K, K = ', k
        stop
      end if

      left = 1
      iryt = n

10    continue

        if ( iryt .le. left ) then
          frac = a(k)
          go to 60
        end if

        x = a(k)
        i = left
        j = iryt

20      continue

          if ( j .lt. i ) then
            if ( j .lt. k ) then
              left = i
            end if
            if ( k .lt. i ) then
              iryt = j
            end if
            go to 50
          end if
c
c  Find I so that X <= A(I).
c
30        continue

          if ( a(i) .lt. x ) then
            i = i + 1
            go to 30
          end if
c
c  Find J so that A(J) <= X.
c
40        continue

          if ( x .lt. a(j) ) then
            j = j - 1
            go to 40
          end if

          if ( i .le. j ) then

            temp = a(i)
            a(i) = a(j)
            a(j) = temp

            i = i + 1
            j = j - 1

          end if

        go to 20

50      continue

      go to 10

60    continue

      return
      end
      subroutine r8vec_fraction ( n, x, fraction )

c*********************************************************************72
c
cc R8VEC_FRACTION returns the fraction parts of an R8VEC.
c
c  Discussion:
c
c    An R8VEC is a vector of R8's.
c
c    If we regard a real number as
c
c      R8 = SIGN * ( WHOLE + FRACTION )
c
c    where
c
c      SIGN is +1 or -1,
c      WHOLE is a nonnegative integer
c      FRACTION is a nonnegative real number strictly less than 1,
c
c    then this routine returns the value of FRACTION.
c
c  Example:
c
c     R8    R8_FRACTION
c
c    0.00      0.00
c    1.01      0.01
c    2.02      0.02
c   19.73      0.73
c   -4.34      0.34
c
c  Licensing:
c
c    This code is distributed under the GNU LGPL license.
c
c  Modified:
c
c    16 May 2010
c
c  Author:
c
c    John Burkardt
c
c  Parameters:
c
c    Input, integer N, the number of arguments.
c
c    Input, double precision X(N), the arguments.
c
c    Output, double precision FRACTION(N), the fraction parts.
c
      implicit none

      integer n

      double precision fraction(n)
      integer i
      double precision x(n)

      do i = 1, n
        fraction(i) = abs ( x(i) ) - dble ( int ( abs ( x(i) ) ) )
      end do

      return
      end
      function r8vec_gt ( n, a1, a2 )

c*********************************************************************72
c
cc R8VEC_GT .eq. ( A1 greater than A2 ) for double precision vectors.
c
c  Discussion:
c
c    An R8VEC is a vector of R8's.
c
c    The comparison is lexicographic.
c
c    A1 > A2  <=>                              A1(1) > A2(1) or
c                 ( A1(1)     .eq. A2(1)     and A1(2) > A2(2) ) or
c                 ...
c                 ( A1(1:N-1) .eq. A2(1:N-1) and A1(N) > A2(N)
c
c  Licensing:
c
c    This code is distributed under the GNU LGPL license.
c
c  Modified:
c
c    22 July 2008
c
c  Author:
c
c    John Burkardt
c
c  Parameters:
c
c    Input, integer N, the dimension of the vectors.
c
c    Input, double precision A1(N), A2(N), the vectors to be compared.
c
c    Output, logical R8VEC_GT, is TRUE if and only if A1 > A2.
c
      implicit none

      integer n

      double precision a1(n)
      double precision a2(n)
      integer i
      logical r8vec_gt

      r8vec_gt = .false.

      do i = 1, n

        if ( a2(i) .lt. a1(i) ) then
          r8vec_gt = .true.
          return
        else if ( a1(i) .lt. a2(i) ) then
          return
        end if

      end do

      return
      end
      subroutine r8vec_heap_a ( n, a )

c*********************************************************************72
c
cc R8VEC_HEAP_A reorders an R8VEC into an ascending heap.
c
c  Discussion:
c
c    An R8VEC is a vector of R8's.
c
c    An ascending heap is an array A with the property that, for every index J,
c    A(J) <= A(2*J) and A(J) <= A(2*J+1), (as long as the indices
c    2*J and 2*J+1 are legal).
c
c                  A(1)
c                /      \
c            A(2)         A(3)
c          /     \        /  \
c      A(4)       A(5)  A(6) A(7)
c      /  \       /   \
c    A(8) A(9) A(10) A(11)
c
c  Licensing:
c
c    This code is distributed under the GNU LGPL license.
c
c  Modified:
c
c    03 June 2009
c
c  Author:
c
c    John Burkardt
c
c  Reference:
c
c    Albert Nijenhuis, Herbert Wilf,
c    Combinatorial Algorithms for Computers and Calculators,
c    Academic Press, 1978,
c    ISBN: 0-12-519260-6,
c    LC: QA164.N54.
c
c  Parameters:
c
c    Input, integer N, the size of the input array.
c
c    Input/output, double precision A(N).
c    On input, an unsorted array.
c    On output, the array has been reordered into a heap.
c
      implicit none

      integer n

      double precision a(n)
      integer i
      integer ifree
      double precision key
      integer m
c
c  Only nodes N/2 down to 1 can be "parent" nodes.
c
      do i = n / 2, 1, -1
c
c  Copy the value out of the parent node.
c  Position IFREE is now "open".
c
        key = a(i)
        ifree = i

10      continue
c
c  Positions 2*IFREE and 2*IFREE + 1 are the descendants of position
c  IFREE.  (One or both may not exist because they exceed N.)
c
          m = 2 * ifree
c
c  Does the first position exist?
c
          if ( n .lt. m ) then
            go to 20
          end if
c
c  Does the second position exist?
c
          if ( m + 1 .le. n ) then
c
c  If both positions exist, take the smaller of the two values,
c  and update M if necessary.
c
            if ( a(m+1) .lt. a(m) ) then
              m = m + 1
            end if

          end if
c
c  If the small descendant is smaller than KEY, move it up,
c  and update IFREE, the location of the free position, and
c  consider the descendants of THIS position.
c
          if ( key .le. a(m) ) then
            go to 20
          end if

          a(ifree) = a(m)
          ifree = m

        go to 10
c
c  Once there is no more shifting to do, KEY moves into the free spot.
c
20      continue

        a(ifree) = key

      end do

      return
      end
      subroutine r8vec_heap_d ( n, a )

c*********************************************************************72
c
cc R8VEC_HEAP_D reorders an R8VEC into an descending heap.
c
c  Discussion:
c
c    An R8VEC is a vector of R8's.
c
c    A descending heap is an array A with the property that, for every index J,
c    A(J) >= A(2*J) and A(J) >= A(2*J+1), (as long as the indices
c    2*J and 2*J+1 are legal).
c
c                  A(1)
c                /      \
c            A(2)         A(3)
c          /     \        /  \
c      A(4)       A(5)  A(6) A(7)
c      /  \       /   \
c    A(8) A(9) A(10) A(11)
c
c  Licensing:
c
c    This code is distributed under the GNU LGPL license.
c
c  Modified:
c
c    03 June 2010
c
c  Author:
c
c    John Burkardt
c
c  Reference:
c
c    Albert Nijenhuis, Herbert Wilf,
c    Combinatorial Algorithms for Computers and Calculators,
c    Academic Press, 1978,
c    ISBN: 0-12-519260-6,
c    LC: QA164.N54.
c
c  Parameters:
c
c    Input, integer N, the size of the input array.
c
c    Input/output, double precision A(N).
c    On input, an unsorted array.
c    On output, the array has been reordered into a heap.
c
      implicit none

      integer n

      double precision a(n)
      integer i
      integer ifree
      double precision key
      integer m
c
c  Only nodes N/2 down to 1 can be "parent" nodes.
c
      do i = n / 2, 1, -1
c
c  Copy the value out of the parent node.
c  Position IFREE is now "open".
c
        key = a(i)
        ifree = i

10      continue
c
c  Positions 2*IFREE and 2*IFREE + 1 are the descendants of position
c  IFREE.  (One or both may not exist because they exceed N.)
c
          m = 2 * ifree
c
c  Does the first position exist?
c
          if ( n .lt. m ) then
            go to 20
          end if
c
c  Does the second position exist?
c
          if ( m + 1 .le. n ) then
c
c  If both positions exist, take the larger of the two values,
c  and update M if necessary.
c
            if ( a(m) .lt. a(m+1) ) then
              m = m + 1
            end if

          end if
c
c  If the large descendant is larger than KEY, move it up,
c  and update IFREE, the location of the free position, and
c  consider the descendants of THIS position.
c
          if ( a(m) .le. key ) then
            go to 20
          end if

          a(ifree) = a(m)
          ifree = m

        go to 10

20      continue
c
c  Once there is no more shifting to do, KEY moves into the free spot IFREE.
c
        a(ifree) = key

      end do

      return
      end
      subroutine r8vec_heap_d_extract ( n, a, value )

c*********************************************************************72
c
cc R8VEC_HEAP_D_EXTRACT: extract maximum from a heap descending sorted R8VEC.
c
c  Discussion:
c
c    An R8VEC is a vector of R8's.
c
c    In other words, the routine finds the maximum value in the
c    heap, returns that value to the user, deletes that value from
c    the heap, and restores the heap to its proper form.
c
c    This is one of three functions needed to model a priority queue.
c
c  Licensing:
c
c    This code is distributed under the GNU LGPL license.
c
c  Modified:
c
c    18 August 2010
c
c  Author:
c
c    John Burkardt
c
c  Reference:
c
c    Thomas Cormen, Charles Leiserson, Ronald Rivest,
c    Introduction to Algorithms,
c    MIT Press, 2001,
c    ISBN: 0262032937,
c    LC: QA76.C662.
c
c  Parameters:
c
c    Input/output, integer N, the number of items in the heap.
c
c    Input/output, double precision A(N), the heap.
c
c    Output, double precision VALUE, the item of maximum value, which has
c    been removed from the heap.
c
      implicit none

      double precision a(*)
      integer n
      double precision value

      if ( n .lt. 1 ) then
        write ( *, '(a)' ) ' '
        write ( *, '(a)' ) 'R8VEC_HEAP_D_EXTRACT - Fatal error!'
        write ( *, '(a)' ) '  The heap is empty.'
        stop
      end if
c
c  Get the maximum value.
c
      value = a(1)

      if ( n .eq. 1 ) then
        n = 0
        return
      end if
c
c  Shift the last value down.
c
      a(1) = a(n)
c
c  Restore the heap structure.
c
      n = n - 1
      call r8vec_sort_heap_d ( n, a )

      return
      end
      subroutine r8vec_heap_d_insert ( n, a, value )

c*********************************************************************72
c
cc R8VEC_HEAP_D_INSERT inserts a value into a heap descending sorted R8VEC.
c
c  Discussion:
c
c    An R8VEC is a vector of R8's.
c
c    This is one of three functions needed to model a priority queue.
c
c  Licensing:
c
c    This code is distributed under the GNU LGPL license.
c
c  Modified:
c
c    18 August 2010
c
c  Author:
c
c    John Burkardt
c
c  Reference:
c
c    Thomas Cormen, Charles Leiserson, Ronald Rivest,
c    Introduction to Algorithms,
c    MIT Press, 2001,
c    ISBN: 0262032937,
c    LC: QA76.C662.
c
c  Parameters:
c
c    Input/output, integer N, the number of items in the heap.
c
c    Input/output, double precision A(N), the heap.
c
c    Input, double precision VALUE, the value to be inserted.
c
      implicit none

      double precision a(*)
      integer i
      integer n
      integer parent
      double precision value

      n = n + 1
      i = n

10    continue

      if ( 1 .lt. i ) then

        parent = i / 2

        if ( value .le. a(parent) ) then
          go to 20
        end if

        a(i) = a(parent)
        i = parent

        go to 10

      end if

20    continue

      a(i) = value

      return
      end
      subroutine r8vec_heap_d_max ( n, a, value )

c*********************************************************************72
c
cc R8VEC_HEAP_D_MAX returns the maximum value in a heap descending sorted R8VEC.
c
c  Discussion:
c
c    An R8VEC is a vector of R8's.
c
c    This is one of three functions needed to model a priority queue.
c
c  Licensing:
c
c    This code is distributed under the GNU LGPL license.
c
c  Modified:
c
c    18 August 2010
c
c  Author:
c
c    John Burkardt
c
c  Reference:
c
c    Thomas Cormen, Charles Leiserson, Ronald Rivest,
c    Introduction to Algorithms,
c    MIT Press, 2001,
c    ISBN: 0262032937,
c    LC: QA76.C662.
c
c  Parameters:
c
c    Input, integer N, the number of items in the heap.
c
c    Input, double precision A(N), the heap.
c
c    Output, double precision VALUE, the maximum value in the heap.
c
      implicit none

      integer n

      double precision a(n)
      double precision value

      value = a(1)

      return
      end
      subroutine r8vec_histogram ( n, a, a_lo, a_hi, histo_num,
     &  histo_gram )

c*********************************************************************72
c
cc R8VEC_HISTOGRAM histograms an R8VEC.
c
c  Discussion:
c
c    An R8VEC is a vector of R8's.
c
c    Values between A_LO and A_HI will be histogrammed into the bins
c    1 through HISTO_NUM.  Values below A_LO are counted in bin 0,
c    and values greater than A_HI are counted in bin HISTO_NUM+1.
c
c  Licensing:
c
c    This code is distributed under the GNU LGPL license.
c
c  Modified:
c
c    04 June 2010
c
c  Author:
c
c    John Burkardt
c
c  Parameters:
c
c    Input, integer N, the number of elements of A.
c
c    Input, double precision A(N), the array to examine.
c
c    Input, double precision A_LO, A_HI, the lowest and highest
c    values to be histogrammed.  These values will also define the bins.
c
c    Input, integer HISTO_NUM, the number of bins to use.
c
c    Output, integer HISTO_GRAM(0:HISTO_NUM+1), contains the
c    number of entries of A in each bin.
c
      implicit none

      integer histo_num
      integer n

      double precision a(n)
      double precision a_hi
      double precision a_lo
      double precision delta
      integer histo_gram(0:histo_num+1)
      integer i
      integer j

      do i = 0, histo_num + 1
        histo_gram(i) = 0
      end do

      delta = ( a_hi - a_lo ) / dble ( 2 * histo_num )

      do i = 1, n

        if ( a(i) .lt. a_lo ) then

          histo_gram(0) = histo_gram(0) + 1

        else if ( a(i) .le. a_hi ) then

          j = nint (
     &      ( ( a_hi -           delta - a(i)        )
     &      * dble ( 1 )
     &      + (      -           delta + a(i) - a_lo )
     &      * dble ( histo_num ) )
     &      / ( a_hi - 2.0D+00 * delta        - a_lo ) )

          histo_gram(j) = histo_gram(j) + 1

        else if ( a_hi .lt. a(i) ) then

          histo_gram(histo_num+1) = histo_gram(histo_num+1) + 1

        end if

      end do

      return
      end
      subroutine r8vec_house_column ( n, a, k, v )

c*********************************************************************72
c
cc R8VEC_HOUSE_COLUMN defines a Householder premultiplier that "packs" a column.
c
c  Discussion:
c
c    An R8VEC is a vector of R8's.
c
c    The routine returns a vector V that defines a Householder
c    premultiplier matrix H(V) that zeros out the subdiagonal entries of
c    column K of the matrix A.
c
c       H(V) = I - 2 * v * v'
c
c  Licensing:
c
c    This code is distributed under the GNU LGPL license.
c
c  Modified:
c
c    05 February 2008
c
c  Author:
c
c    John Burkardt
c
c  Parameters:
c
c    Input, integer N, the order of the matrix A.
c
c    Input, double precision A(N), column K of the matrix A.
c
c    Input, integer K, the column of the matrix to be modified.
c
c    Output, double precision V(N), a vector of unit L2 norm which defines an
c    orthogonal Householder premultiplier matrix H with the property
c    that the K-th column of H*A is zero below the diagonal.
c
      implicit none

      integer n

      double precision a(n)
      integer i
      integer k
      double precision s
      double precision v(n)
      double precision vnorm

      do i = 1, n
        v(i) = 0.0D+00
      end do

      if ( k .lt. 1 .or. n .le. k ) then
        return
      end if

      s = 0.0D+00
      do i = k, n
        s = s + a(i)**2
      end do
      s = sqrt ( s )

      if ( s .eq. 0.0D+00 ) then
        return
      end if

      v(k) = a(k) + sign ( s, a(k) )
      do i = k + 1, n
        v(i) = a(i)
      end do

      vnorm = 0.0D+00
      do i = k, n
        vnorm = vnorm + v(i) * v(i)
      end do
      vnorm = sqrt ( vnorm )

      do i = k, n
        v(i) = v(i) / vnorm
      end do

      return
      end
      function r8vec_i4vec_dot_product ( n, r8vec, i4vec )

c*********************************************************************72
c
cc R8VEC_I4VEC_DOT_PRODUCT finds the dot product of an R8VEC and an I4VEC.
c
c  Discussion:
c
c    An R8VEC is a vector of R8's.
c
c    An I4VEC is a vector of I4's.
c
c  Licensing:
c
c    This code is distributed under the GNU LGPL license.
c
c  Modified:
c
c    30 June 2009
c
c  Author:
c
c    John Burkardt
c
c  Parameters:
c
c    Input, integer N, the dimension of the vectors.
c
c    Input, double precision R8VEC(N), the first vector.
c
c    Input, integer I4VEC(N), the second vector.
c
c    Output, double precision R8VEC_I4VEC_DOT_PRODUCT, the dot product.
c
      implicit none

      integer n

      integer i
      integer i4vec(n)
      double precision r8vec(n)
      double precision r8vec_i4vec_dot_product
      double precision value

      value = 0.0D+00
      do i = 1, n
        value = value + r8vec(i) * dble ( i4vec(i) )
      end do

      r8vec_i4vec_dot_product = value

      return
      end
      function r8vec_in_01 ( n, a )

c*********************************************************************72
c
cc R8VEC_IN_01 is TRUE if the entries of an R8VEC are in the range [0,1].
c
c  Discussion:
c
c    An R8VEC is a vector of R8's.
c
c  Licensing:
c
c    This code is distributed under the GNU LGPL license.
c
c  Modified:
c
c    16 May 2010
c
c  Author:
c
c    John Burkardt
c
c  Parameters:
c
c    Input, integer N, the number of entries.
c
c    Input, double precision A(N), the vector.
c
c    Output, logical R8VEC_IN_01, is TRUE if every entry is
c    between 0 and 1.
c
      implicit none

      integer n

      double precision a(n)
      integer i
      logical r8vec_in_01

      do i = 1, n
        if ( a(i) .lt. 0.0D+00 .or. 1.0D+00 .lt. a(i) ) then
          r8vec_in_01 = .false.
          return
        end if
      end do

      r8vec_in_01 = .true.

      return
      end
      function r8vec_in_ab ( n, x, a, b )

c*********************************************************************72
c
cc R8VEC_IN_AB is TRUE if the entries of an R8VEC are in the range [A,B].
c
c  Discussion:
c
c    An R8VEC is a vector of R8's.
c
c  Licensing:
c
c    This code is distributed under the GNU LGPL license.
c
c  Modified:
c
c    15 April 2012
c
c  Author:
c
c    John Burkardt
c
c  Parameters:
c
c    Input, integer N, the number of entries.
c
c    Input, double precision X(N), the vector.
c
c    Input, double precision A, B, the limits of the range.
c
c    Output, logical R8VEC_IN_01, is TRUE if every entry is
c    between A and B.
c
      implicit none

      integer n

      double precision a
      double precision b
      integer i
      logical r8vec_in_ab
      double precision x(n)

      do i = 1, n
        if ( x(i) .lt.a .or. b .lt. x(i) ) then
          r8vec_in_ab = .false.
          return
        end if
      end do

      r8vec_in_ab = .true.

      return
      end
      subroutine r8vec_index_insert ( n, x, indx, xval )

c*********************************************************************72
c
cc R8VEC_INDEX_INSERT inserts a value in an indexed sorted R8VEC.
c
c  Discussion:
c
c    An R8VEC is a vector of R8's.
c
c  Licensing:
c
c    This code is distributed under the GNU LGPL license.
c
c  Modified:
c
c    21 August 2010
c
c  Author:
c
c    John Burkardt
c
c  Parameters:
c
c    Input/output, integer N, the size of the current list.
c
c    Input/output, double precision X(N), the list.
c
c    Input/output, integer INDX(N), the sort index of the list.
c
c    Input, double precision XVAL, the value to be sought.
c
      implicit none

      integer n

      integer equal
      integer i
      integer indx(*)
      integer less
      integer more
      double precision x(*)
      double precision xval

      if ( n .le. 0 ) then
        n = 1
        x(1) = xval
        indx(1) = 1
        return
      end if

      call r8vec_index_search ( n, x, indx, xval, less, equal, more )

      x(n+1) = xval
      do i = n, more, -1
        indx(i+1) = indx(i)
      end do
      indx(more) = n + 1
      n = n + 1

      return
      end
      subroutine r8vec_index_insert_unique ( n, x, indx, xval )

c*********************************************************************72
c
cc R8VEC_INDEX_INSERT_UNIQUE inserts a unique value in an indexed sorted R8VEC.
c
c  Discussion:
c
c    An R8VEC is a vector of R8's.
c
c    If the value does not occur in the list, it is included in the list,
c    and N, X and INDX are updated.
c
c  Licensing:
c
c    This code is distributed under the GNU LGPL license.
c
c  Modified:
c
c    19 August 2010
c
c  Author:
c
c    John Burkardt
c
c  Parameters:
c
c    Input/output, integer N, the size of the current list.
c
c    Input/output, double precision X(N), the list.
c
c    Input/output, integer INDX(N), the sort index of the list.
c
c    Input, double precision XVAL, the value to be sought.
c
      implicit none

      integer n

      integer equal
      integer i
      integer indx(*)
      integer less
      integer more
      double precision x(*)
      double precision xval

      if ( n .le. 0 ) then
        n = 1
        x(1) = xval
        indx(1) = 1
        return
      end if
c
c  Does XVAL already occur in X?
c
      call r8vec_index_search ( n, x, indx, xval, less, equal, more )

      if ( equal .eq. 0 ) then
        x(n+1) = xval
        do i = n, more, - 1
          indx(i+1) = indx(i)
        end do
        indx(more) = n + 1
        n = n + 1
      end if

      return
      end
      subroutine r8vec_index_order ( n, x, indx )

c*********************************************************************72
c
cc R8VEC_INDEX_ORDER sorts an R8VEC using an index vector.
c
c  Discussion:
c
c    An R8VEC is a vector of R8's.
c
c    The index vector itself is not modified.  Therefore, the pair
c    (X,INDX) no longer represents an index sorted vector.  If this
c    relationship is to be preserved, then simply set INDX(1:N)=(1:N).
c
c  Licensing:
c
c    This code is distributed under the GNU LGPL license.
c
c  Modified:
c
c    16 May 2010
c
c  Author:
c
c    John Burkardt
c
c  Parameters:
c
c    Input, integer N, the size of the current list.
c
c    Input/output, double precision X(N), the list.  On output, the list
c    has been sorted.
c
c    Input, integer INDX(N), the sort index of the list.
c
      implicit none

      integer n

      integer i
      integer indx(n)
      double precision x(n)
      double precision y(n)

      do i = 1, n
        y(i) = x(indx(i))
      end do

      do i = 1, n
        x(i) = y(i)
      end do

      return
      end
      subroutine r8vec_index_search ( n, x, indx, xval, less, equal,
     &  more )

c*********************************************************************72
c
cc R8VEC_INDEX_SEARCH searches for a value in an indexed sorted R8VEC.
c
c  Discussion:
c
c    An R8VEC is a vector of R8's.
c
c  Licensing:
c
c    This code is distributed under the GNU LGPL license.
c
c  Modified:
c
c    04 June 2010
c
c  Author:
c
c    John Burkardt
c
c  Parameters:
c
c    Input, integer N, the size of the current list.
c
c    Input, double precision X(N), the list.
c
c    Input, integer INDX(N), the sort index of the list.
c
c    Input, double precision XVAL, the value to be sought.
c
c    Output, integer LESS, EQUAL, MORE, the indexes in INDX of the
c    entries of X that are just less than, equal to, and just greater
c    than XVAL.  If XVAL does not occur in X, then EQUAL is zero.
c    If XVAL is the minimum entry of X, then LESS is 0.  If XVAL
c    is the greatest entry of X, then MORE is N+1.
c
      implicit none

      integer n

      integer equal
      integer hi
      integer indx(n)
      integer less
      integer lo
      integer mid
      integer more
      double precision x(n)
      double precision xhi
      double precision xlo
      double precision xmid
      double precision xval

      if ( n .le. 0 ) then
        less = 0
        equal = 0
        more = 0
        return
      end if

      lo = 1
      hi = n
      xlo = x(indx(lo))
      xhi = x(indx(hi))

      if ( xval .lt. xlo ) then
        less = 0
        equal = 0
        more = 1
        return
      else if ( xval .eq. xlo ) then
        less = 0
        equal = 1
        more = 2
        return
      end if

      if ( xhi .lt. xval ) then
        less = n
        equal = 0
        more = n + 1
        return
      else if ( xval .eq. xhi ) then
        less = n - 1
        equal = n
        more = n + 1
        return
      end if

10    continue

        if ( lo + 1 .eq. hi ) then
          less = lo
          equal = 0
          more = hi
          go to 20
        end if

        mid = ( lo + hi ) / 2
        xmid = x(indx(mid))

        if ( xval .eq. xmid ) then
          equal = mid
          less = equal - 1
          more = equal + 1
          go to 20
        else if ( xval .lt. xmid ) then
          hi = mid
        else if ( xmid .lt. xval ) then
          lo = mid
        end if

      go to 10

20    continue

      return
      end
      subroutine r8vec_index_sorted_range ( n, r, indx, r_lo, r_hi,
     &  i_lo, i_hi )

c*********************************************************************72
c
cc R8VEC_INDEX_SORTED_RANGE: search index sorted vector for elements in a range.
c
c  Licensing:
c
c    This code is distributed under the GNU LGPL license.
c
c  Modified:
c
c    27 September 2010
c
c  Author:
c
c    John Burkardt
c
c  Parameters:
c
c    Input, integer N, the number of items in the vector.
c
c    Input, double precision R(N), the index sorted vector.
c
c    Input, integer INDX(N), the vector used to sort R.
c    The vector R(INDX(*)) is sorted.
c
c    Input, double precision R_LO, R_HI, the limits of the range.
c
c    Output, integer I_LO, I_HI, the range of indices
c    so that I_LO <= I <= I_HI => R_LO <= R(INDX(I)) <= R_HI.  If no
c    values in R lie in the range, then I_HI .lt. I_LO will be returned.
c
      implicit none

      integer n

      integer i_hi
      integer i_lo
      integer i1
      integer i2
      integer indx(n)
      integer j1
      integer j2
      double precision r(n)
      double precision r_hi
      double precision r_lo
c
c  Cases we can handle immediately.
c
      if ( r(indx(n)) .lt. r_lo ) then
        i_lo = n + 1
        i_hi = n
        return
      end if

      if ( r_hi .lt. r(indx(1)) ) then
        i_lo = 1
        i_hi = 0
        return
      end if
c
c  Are there are least two intervals?
c
      if ( n .eq. 1 ) then
        if ( r_lo .le. r(indx(1)) .and. r(indx(1)) .le. r_hi ) then
          i_lo = 1
          i_hi = 1
        else
          i_lo = 0
          i_hi = -1
        end if
        return
      end if
c
c  Bracket R_LO.
c
      if ( r_lo .le. r(indx(1)) ) then

        i_lo = 1

      else
c
c  R_LO is in one of the intervals spanned by R(INDX(J1)) to R(INDX(J2)).
c  Examine the intermediate interval [R(INDX(I1)), R(INDX(I1+1))].
c  Does R_LO lie here, or below or above?
c
        j1 = 1
        j2 = n
        i1 = ( j1 + j2 - 1 ) / 2
        i2 = i1 + 1

10      continue

          if ( r_lo .lt. r(indx(i1)) ) then
            j2 = i1
            i1 = ( j1 + j2 - 1 ) / 2
            i2 = i1 + 1
          else if ( r(indx(i2)) .lt. r_lo ) then
            j1 = i2
            i1 = ( j1 + j2 - 1 ) / 2
            i2 = i1 + 1
          else
            i_lo = i1
            go to 20
          end if

        go to 10

20      continue

      end if
c
c  Bracket R_HI.
c
      if ( r(indx(n)) .le. r_hi ) then

        i_hi = n

      else

        j1 = i_lo
        j2 = n
        i1 = ( j1 + j2 - 1 ) / 2
        i2 = i1 + 1

30      continue

          if ( r_hi .lt. r(indx(i1)) ) then
            j2 = i1
            i1 = ( j1 + j2 - 1 ) / 2
            i2 = i1 + 1
          else if ( r(indx(i2)) .lt. r_hi ) then
            j1 = i2
            i1 = ( j1 + j2 - 1 ) / 2
            i2 = i1 + 1
          else
            i_hi = i2
            go to 40
          end if

        go to 30

40      continue

      end if
c
c  We expect to have computed the largest I_LO and smallest I_HI such that
c    R(INDX(I_LO)) <= R_LO <= R_HI <= R(INDX(I_HI))
c  but what we want is actually
c    R_LO <= R(INDX(I_LO)) <= R(INDX(I_HI)) <= R_HI
c  which we can usually get simply by incrementing I_LO and decrementing I_HI.
c
      if ( r(indx(i_lo)) .lt. r_lo ) then
        i_lo = i_lo + 1
        if ( n .lt. i_lo ) then
          i_hi = i_lo - 1
        end if
      end if

      if ( r_hi .lt. r(indx(i_hi)) ) then
        i_hi = i_hi - 1
        if ( i_hi .lt. 1 ) then
          i_lo = i_hi + 1
        end if
      end if

      return
      end
      subroutine r8vec_indexed_heap_d ( n, a, indx )

c*********************************************************************72
c
cc R8VEC_INDEXED_HEAP_D creates a descending heap from an indexed R8VEC.
c
c  Discussion:
c
c    An R8VEC is a vector of R8's.
c
c    An indexed R8VEC is an R8VEC of data values, and an R8VEC of N indices,
c    each referencing an entry of the data vector.
c
c    The function adjusts the index vector INDX so that, for 1 .le. J .le. N/2,
c    we have:
c      A(INDX(2*J))   .le. A(INDX(J))
c    and
c      A(INDX(2*J+1)) .le. A(INDX(J))
c
c  Licensing:
c
c    This code is distributed under the GNU LGPL license.
c
c  Modified:
c
c    16 August 2010
c
c  Author:
c
c    John Burkardt
c
c  Reference:
c
c    Albert Nijenhuis, Herbert Wilf,
c    Combinatorial Algorithms for Computers and Calculators,
c    Academic Press, 1978,
c    ISBN: 0-12-519260-6,
c    LC: QA164.N54.
c
c  Parameters:
c
c    Input, integer N, the size of the index array.
c
c    Input, double precision A(*), the data vector.
c
c    Input/output, integer INDX(N), the index array.
c    Each entry of INDX must be a valid index for the array A.
c    On output, the indices have been reordered into a descending heap.
c
      implicit none

      integer n

      double precision a(*)
      integer i
      integer ifree
      integer indx(n)
      integer key
      integer m
c
c  Only nodes N/2 down to 1 can be "parent" nodes.
c
      do i = n / 2, 1, -1
c
c  Copy the value out of the parent node.
c  Position IFREE is now "open".
c
        key = indx(i)
        ifree = i

10      continue
c
c  Positions 2*IFREE and 2*IFREE + 1 are the descendants of position
c  IFREE.  (One or both may not exist because they exceed N.)
c
          m = 2 * ifree
c
c  Does the first position exist?
c
          if ( n .lt. m ) then
            go to 20
          end if
c
c  Does the second position exist?
c
          if ( m + 1 .le. n ) then
c
c  If both positions exist, take the larger of the two values,
c  and update M if necessary.
c
            if ( a(indx(m)) .lt. a(indx(m+1)) ) then
              m = m + 1
            end if

          end if
c
c  If the large descendant is larger than KEY, move it up,
c  and update IFREE, the location of the free position, and
c  consider the descendants of THIS position.
c
          if ( a(indx(m)) .le. a(key) ) then
            go to 20
          end if

          indx(ifree) = indx(m)
          ifree = m

        go to 10
c
c  Once there is no more shifting to do, KEY moves into the free spot IFREE.
c
20      continue

        indx(ifree) = key

      end do

      return
      end
      subroutine r8vec_indexed_heap_d_extract ( n, a, indx,
     &  indx_extract )

c*********************************************************************72
c
cc R8VEC_INDEXED_HEAP_D_EXTRACT: extract from heap descending indexed R8VEC.
c
c  Discussion:
c
c    An R8VEC is a vector of R8's.
c
c    An indexed R8VEC is an R8VEC of data values, and an R8VEC of N indices,
c    each referencing an entry of the data vector.
c
c    The routine finds the maximum value in the heap, returns that value to the
c    user, deletes that value from the heap, and restores the heap to its
c    proper form.
c
c    Note that the argument N must be a variable, which will be decremented
c    before return, and that INDX will hold one less value on output than it
c    held on input.
c
c    This is one of three functions needed to model a priority queue.
c
c  Licensing:
c
c    This code is distributed under the GNU LGPL license.
c
c  Modified:
c
c    16 August 2010
c
c  Author:
c
c    John Burkardt
c
c  Reference:
c
c    Thomas Cormen, Charles Leiserson, Ronald Rivest,
c    Introduction to Algorithms,
c    MIT Press, 2001,
c    ISBN: 0262032937,
c    LC: QA76.C662.
c
c  Parameters:
c
c    Input/output, integer N, the number of items in the
c    index vector.
c
c    Input, double precision A(*), the data vector.
c
c    Input/output, integer INDX(N), the index vector.
c
c    Output, integer INDX_EXTRACT, the index in A of the item of
c    maximum value, which has now been removed from the heap.
c
      implicit none

      double precision a(*)
      integer indx(*)
      integer indx_extract
      integer n

      if ( n .lt. 1 ) then
        write ( *, '(a)' ) ' '
        write ( *, '(a)' ) 'R8VEC_INDEXED_HEAP_D_EXTRACT - Fatal error!'
        write ( *, '(a)' ) '  The heap is empty.'
        stop
      end if
c
c  Get the index of the maximum value.
c
      indx_extract = indx(1)

      if ( n .eq. 1 ) then
        n = 0
        return
      end if
c
c  Shift the last index down.
c
      indx(1) = indx(n)
c
c  Restore the heap structure.
c
      n = n - 1
      call r8vec_indexed_heap_d ( n, a, indx )

      return
      end
      subroutine r8vec_indexed_heap_d_insert ( n, a, indx, indx_insert )

c*********************************************************************72
c
cc R8VEC_INDEXED_HEAP_D_INSERT: insert value into heap descending indexed R8VEC.
c
c  Discussion:
c
c    An R8VEC is a vector of R8's.
c
c    An indexed R8VEC is an R8VEC of data values, and an R8VEC of N indices,
c    each referencing an entry of the data vector.
c
c    Note that the argument N must be a variable, and will be incremented before
c    return, and that INDX must be able to hold one more entry on output than
c    it held on input.
c
c    This is one of three functions needed to model a priority queue.
c
c  Licensing:
c
c    This code is distributed under the GNU LGPL license.
c
c  Modified:
c
c    17 August 2010
c
c  Author:
c
c    John Burkardt
c
c  Reference:
c
c    Thomas Cormen, Charles Leiserson, Ronald Rivest,
c    Introduction to Algorithms,
c    MIT Press, 2001,
c    ISBN: 0262032937,
c    LC: QA76.C662.
c
c  Parameters:
c
c    Input/output, integer N, the number of items in the
c    index vector.
c
c    Input, double precision A(*), the data vector.
c
c    Input/output, integer INDX(N), the index vector.
c
c    Input, integer INDX_INSERT, the index in A of the value
c    to be inserted into the heap.
c
      implicit none

      double precision a(*)
      integer i
      integer indx(*)
      integer indx_insert
      integer n
      integer parent

      n = n + 1
      i = n

10    continue

      if ( 1 .lt. i ) then

        parent = i / 2

        if ( a(indx_insert) .le. a(indx(parent)) ) then
          go to 20
        end if

        indx(i) = indx(parent)
        i = parent

        go to 10

      end if

20    continue

      indx(i) = indx_insert

      return
      end
      subroutine r8vec_indexed_heap_d_max ( n, a, indx, indx_max )

c*********************************************************************72
c
cc R8VEC_INDEXED_HEAP_D_MAX: maximum value in heap descending indexed R8VEC.
c
c  Discussion:
c
c    An R8VEC is a vector of R8's.
c
c    An indexed R8VEC is an R8VEC of data values, and an R8VEC of N indices,
c    each referencing an entry of the data vector.
c
c    This is one of three functions needed to model a priority queue.
c
c  Licensing:
c
c    This code is distributed under the GNU LGPL license.
c
c  Modified:
c
c    16 August 2010
c
c  Author:
c
c    John Burkardt
c
c  Reference:
c
c    Thomas Cormen, Charles Leiserson, Ronald Rivest,
c    Introduction to Algorithms,
c    MIT Press, 2001,
c    ISBN: 0262032937,
c    LC: QA76.C662.
c
c  Parameters:
c
c    Input, integer N, the number of items in the index vector.
c
c    Input, double precision A(*), the data vector.
c
c    Input, integer INDX(N), the index vector.
c
c    Output, integer INDX_MAX, the index in A of the maximum value
c    in the heap.
c
      implicit none

      integer n

      double precision a(*)
      integer indx(n)
      integer indx_max

      indx_max = indx(1)

      return
      end
      subroutine r8vec_indicator ( n, a )

c*********************************************************************72
c
cc R8VEC_INDICATOR sets an R8VEC to the indicator vector.
c
c  Discussion:
c
c    An R8VEC is a vector of R8's.
c
c  Licensing:
c
c    This code is distributed under the GNU LGPL license.
c
c  Modified:
c
c    22 January 2007
c
c  Author:
c
c    John Burkardt
c
c  Parameters:
c
c    Input, integer N, the number of elements of A.
c
c    Output, double precision A(N), the array to be initialized.
c
      implicit none

      integer n

      double precision a(n)
      integer i

      do i = 1, n
        a(i) = dble ( i )
      end do

      return
      end
      subroutine r8vec_insert ( n, a, pos, value )

c*********************************************************************72
c
cc R8VEC_INSERT inserts a value into an R8VEC.
c
c  Discussion:
c
c    An R8VEC is a vector of R8's.
c
c  Licensing:
c
c    This code is distributed under the GNU LGPL license.
c
c  Modified:
c
c    30 May 2009
c
c  Author:
c
c    John Burkardt
c
c  Parameters:
c
c    Input, integer N, the dimension of the array on input.
c
c    Input/output, double precision A(N+1), the array.  On input, A is
c    assumed to contain only N entries, while on output, A actually
c    contains N+1 entries.
c
c    Input, integer POS, the position to be assigned the new entry.
c    1 <= POS <= N+1.
c
c    Input, double precision VALUE, the value to be inserted.
c
      implicit none

      integer n

      double precision a(n+1)
      integer i
      integer pos
      double precision value

      if ( pos .lt. 1 .or. n + 1 .lt. pos ) then

        write ( *, '(a)' ) ' '
        write ( *, '(a)' ) 'R8VEC_INSERT - Fatal error!'
        write ( *, '(a,i8)' ) '  Illegal insertion position = ', pos
        stop

      else

        do i = n + 1, pos + 1, -1
          a(i) = a(i-1)
        end do

        a(pos) = value

      end if

      return
      end
      function r8vec_insignificant ( n, r, s )

c*********************************************************************72
c
cc R8VEC_INSIGNIFICANT determines if an R8VEC is insignificant.
c
c  Licensing:
c
c    This code is distributed under the GNU LGPL license.
c
c  Modified:
c
c    26 November 2011
c
c  Author:
c
c    John Burkardt
c
c  Parameters:
c
c    Input, integer N, the dimension of the vectors.
c
c    Input, double precision R(N), the vector to be compared against.
c
c    Input, double precision S(N), the vector to be compared.
c
c    Output, logical R8VEC_INSIGNIFICANT, is TRUE if S is insignificant
c    compared to R.
c
      implicit none

      integer n

      integer i
      double precision r(n)
      double precision r8_epsilon
      logical r8vec_insignificant
      double precision s(n)
      double precision t
      double precision tol
      logical value

      value = .true.

      do i = 1, n

        t = r(i) + s(i)
        tol = r8_epsilon ( ) * abs ( r(i) )

        if ( tol .lt. abs ( r(i) - t ) ) then 
          value = .false.
          go to 10
        end if

      end do
  
10    continue

      r8vec_insignificant = value

      return
      end
      function r8vec_is_int ( n, a )

c*********************************************************************72
c
cc R8VEC_IS_INT is TRUE if the entries of an R8VEC are integers.
c
c  Discussion:
c
c    An R8VEC is a vector of R8's.
c
c  Licensing:
c
c    This code is distributed under the GNU LGPL license.
c
c  Modified:
c
c    04 June 2010
c
c  Author:
c
c    John Burkardt
c
c  Parameters:
c
c    Input, integer N, the number of entries in A.
c
c    Input, double precision A(N), the vector.
c
c    Output, logical R8VEC_IS_INT, is TRUE if every entry of A is
c    integral.
c
      implicit none

      integer n

      double precision a(n)
      integer i
      logical r8vec_is_int

      do i = 1, n
        if ( a(i) .ne. aint ( a(i) ) ) then
          r8vec_is_int = .false.
          return
        end if
      end do

      r8vec_is_int = .true.

      return
      end
      function r8vec_is_nonnegative ( n, a )

c*****************************************************************************80
c
cc R8VEC_IS_NONNEGATIVE is TRUE if all the entries of an R8VEC are nonnegative.
c
c  Discussion:
c
c    An R8VEC is a vector of R8's.
c
c  Licensing:
c
c    This code is distributed under the GNU LGPL license.
c
c  Modified:
c
c    17 June 2011
c
c  Author:
c
c    John Burkardt
c
c  Parameters:
c
c    Input, integer N, the number of entries in A.
c
c    Input, double precision A(N), the vector.
c
c    Output, logical R8VEC_IS_NONNEGATIVE, the value of the condition.
c
      implicit none

      integer n

      double precision a(n)
      integer i
      logical r8vec_is_nonnegative

      do i = 1, n
        if ( a(i) < 0.0D+00 ) then
          r8vec_is_nonnegative = .false.
          return
        end if
      end do

      r8vec_is_nonnegative = .true.

      return
      end
      function r8vec_is_zero ( n, a )

c*****************************************************************************80
c
cc R8VEC_IS_ZERO is TRUE if all the entries of an R8VEC are zero.
c
c  Discussion:
c
c    An R8VEC is a vector of R8's.
c
c  Licensing:
c
c    This code is distributed under the GNU LGPL license.
c
c  Modified:
c
c    17 June 2011
c
c  Author:
c
c    John Burkardt
c
c  Parameters:
c
c    Input, integer N, the number of entries in A.
c
c    Input, double precision A(N), the vector.
c
c    Output, logical R8VEC_IS_ZERO, the value of the condition.
c
      implicit none

      integer n

      double precision a(n)
      integer i
      logical r8vec_is_zero

      do i = 1, n
        if ( a(i) /= 0.0D+00 ) then
          r8vec_is_zero = .false.
          return
        end if
      end do

      r8vec_is_zero = .true.

      return
      end
      subroutine r8vec_legendre ( n, x_first, x_last, x )

c*****************************************************************************80
c
cc R8VEC_LEGENDRE creates a vector of Legendre-spaced values.
c
c  Discussion:
c
c    An R8VEC is a vector of R8's.
c
c  Licensing:
c
c    This code is distributed under the GNU LGPL license.
c
c  Modified:
c
c    17 June 2011
c
c  Author:
c
c    John Burkardt
c
c  Parameters:
c
c    Input, integer N, the number of entries in the vector.
c
c    Input, double precision X_FIRST, X_LAST, the first and last entries.
c
c    Output, double precision X(N), a vector of Legendre-spaced data.
c
      implicit none

      integer n

      integer i
      double precision x(n)
      double precision x_first
      double precision x_last

      call legendre_zeros ( n, x )

      do i = 1, n
        x(i) = ( ( 1.0D+00 - x(i) ) * x_first  
     &         + ( 1.0D+00 + x(i) ) * x_last ) 
     &         /   2.0D+00
      end do

      return
      end
      subroutine r8vec_linspace ( n, a_first, a_last, a )

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

      integer n

      double precision a(n)
      double precision a_first
      double precision a_last
      integer i

      if ( n .eq. 1 ) then

        a(1) = ( a_first + a_last ) / 2.0D+00

      else

        do i = 1, n
          a(i) = ( dble ( n - i     ) * a_first 
     &           + dble (     i - 1 ) * a_last )
     &           / dble ( n     - 1 )
        end do

      end if

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

c*********************************************************************72
c
cc R8VEC_LINSPACE2 creates a vector of linearly spaced values.
c
c  Discussion:
c
c    An R8VEC is a vector of R8's.
c
c    4 points evenly spaced between 0 and 12 will yield 2, 4, 6, 8, 10.
c
c    In other words, the interval is divided into N+1 even subintervals,
c    and the endpoints of internal intervals are used as the points.
c
c  Licensing:
c
c    This code is distributed under the GNU LGPL license.
c
c  Modified:
c
c    18 September 2012
c
c  Author:
c
c    John Burkardt
c
c  Parameters:
c
c    Input, integer N, the number of entries in the vector.
c
c    Input, double precision A, B, the first and last entries.
c
c    Output, double precision X(N), a vector of linearly spaced data.
c
      implicit none

      integer n

      double precision a
      double precision b
      integer i
      double precision x(n)

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

      return
      end
      function r8vec_lt ( n, a1, a2 )

c*********************************************************************72
c
cc R8VEC_LT .eq. ( A1 < A2 ) for double precision vectors.
c
c  Discussion:
c
c    An R8VEC is a vector of R8's.
c
c    The comparison is lexicographic.
c
c    A1 < A2  <=>                              A1(1) < A2(1) or
c                 ( A1(1)     .eq. A2(1)     and A1(2) < A2(2) ) or
c                 ...
c                 ( A1(1:N-1) .eq. A2(1:N-1) and A1(N) < A2(N)
c
c  Licensing:
c
c    This code is distributed under the GNU LGPL license.
c
c  Modified:
c
c    22 July 2008
c
c  Author:
c
c    John Burkardt
c
c  Parameters:
c
c    Input, integer N, the dimension of the vectors.
c
c    Input, double precision A1(N), A2(N), the vectors to be compared.
c
c    Output, logical R8VEC_LT, is TRUE if and only if A1 < A2.
c
      implicit none

      integer n

      double precision a1(n)
      double precision a2(n)
      integer i
      logical r8vec_lt

      r8vec_lt = .false.

      do i = 1, n

        if ( a1(i) .lt. a2(i) ) then
          r8vec_lt = .true.
          return
        else if ( a2(i) .lt. a1(i) ) then
          return
        end if

      end do

      return
      end
      subroutine r8vec_mask_print ( n, a, mask_num, mask, title )

c*********************************************************************72
c
cc R8VEC_MASK_PRINT prints a masked R8VEC.
c
c  Discussion:
c
c    An R8VEC is a vector of R8's.
c
c  Licensing:
c
c    This code is distributed under the GNU LGPL license.
c
c  Modified:
c
c    06 July 2009
c
c  Author:
c
c    John Burkardt
c
c  Parameters:
c
c    Input, integer N, the number of components of the vector.
c
c    Input, double precision A(N), the vector to be printed.
c
c    Input, integer MASK_NUM, the number of masked elements.
c
c    Input, integer MASK(MASK_NUM), the indices of the vector
c    to be printed.
c
c    Input, character * ( * ) TITLE, a title.
c
      implicit none

      integer mask_num
      integer n

      double precision a(n)
      integer i
      integer mask(mask_num)
      character * ( * ) title

      write ( *, '(a)' ) ' '
      write ( *, '(a)' ) '  Masked vector printout:'
      write ( *, '(a)' ) ' '
      write ( *, '(a)' ) trim ( title )

      write ( *, '(a)' ) ' '
      do i = 1, mask_num
        write ( *, '(2x,i8,a,1x,i8,2x,g14.6)' )
     &    i, ':', mask(i), a(mask(i))
      end do

      return
      end
      subroutine r8vec_max ( n, a, amax )

c*********************************************************************72
c
cc R8VEC_MAX returns the maximum value in an R8VEC.
c
c  Discussion:
c
c    An R8VEC is a vector of R8's.
c
c  Licensing:
c
c    This code is distributed under the GNU LGPL license.
c
c  Modified:
c
c    31 May 2009
c
c  Author:
c
c    John Burkardt
c
c  Parameters:
c
c    Input, integer N, the number of entries in the array.
c
c    Input, double precision A(N), the array.
c
c    Output, double precision AMAX, the value of the largest entry.
c
      implicit none

      integer n

      double precision a(n)
      double precision amax
      integer i

      amax = a(1)
      do i = 2, n
        amax = max ( amax, a(i) )
      end do

      return
      end
      subroutine r8vec_max_abs_index ( n, a, max_index )

c*********************************************************************72
c
cc R8VEC_MAX_ABS_INDEX: index of the maximum absolute value in an R8VEC.
c
c  Discussion:
c
c    An R8VEC is a vector of R8's.
c
c  Licensing:
c
c    This code is distributed under the GNU LGPL license.
c
c  Modified:
c
c    08 April 2012
c
c  Author:
c
c    John Burkardt
c
c  Parameters:
c
c    Input, integer N, the number of entries in the array.
c
c    Input, double precision A(N), the array.
c
c    Output, integer MAX_INDEX, the index of the largest entry.
c
      implicit none

      integer n

      double precision a(n)
      integer i
      integer max_index

      if ( n .le. 0 ) then

        max_index = -1

      else

        max_index = 1

        do i = 2, n
          if ( abs ( a(max_index) ) .lt. abs ( a(i) ) ) then
            max_index = i
          end if
        end do

      end if

      return
      end
      subroutine r8vec_max_index ( n, a, max_index )

c*********************************************************************72
c
cc R8VEC_MAX_INDEX returns the index of the maximum value in an R8VEC.
c
c  Discussion:
c
c    An R8VEC is a vector of R8's.
c
c  Licensing:
c
c    This code is distributed under the GNU LGPL license.
c
c  Modified:
c
c    06 July 2009
c
c  Author:
c
c    John Burkardt
c
c  Parameters:
c
c    Input, integer N, the number of entries in the array.
c
c    Input, double precision A(N), the array.
c
c    Output, integer MAX_INDEX, the index of the largest entry.
c
      implicit none

      integer n

      double precision a(n)
      integer i
      integer max_index

      if ( n .le. 0 ) then

        max_index = -1

      else

        max_index = 1

        do i = 2, n
          if ( a(max_index) .lt. a(i) ) then
            max_index = i
          end if
        end do

      end if

      return
      end
      subroutine r8vec_mean ( n, a, mean )

c*********************************************************************72
c
cc R8VEC_MEAN returns the mean of an R8VEC.
c
c  Discussion:
c
c    An R8VEC is a vector of R8's.
c
c  Licensing:
c
c    This code is distributed under the GNU LGPL license.
c
c  Modified:
c
c    29 May 2009
c
c  Author:
c
c    John Burkardt
c
c  Parameters:
c
c    Input, integer N, the number of entries in the vector.
c
c    Input, double precision A(N), the vector whose mean is desired.
c
c    Output, double precision MEAN, the mean of the vector entries.
c
      implicit none

      integer n

      double precision a(n)
      integer i
      double precision mean

      mean = 0.0D+00
      do i = 1, n
        mean = mean + a(i)
      end do
      mean = mean / dble ( n )

      return
      end
      subroutine r8vec_median ( n, a, median )

c*********************************************************************72
c
cc R8VEC_MEDIAN returns the median of an unsorted R8VEC.
c
c  Discussion:
c
c    An R8VEC is a vector of R8's.
c
c    Hoare's algorithm is used.  The values of the vector are
c    rearranged by this routine.
c
c  Licensing:
c
c    This code is distributed under the GNU LGPL license.
c
c  Modified:
c
c    02 June 2009
c
c  Parameters:
c
c    Input, integer N, the number of elements of A.
c
c    Input/output, double precision A(N), the array to search.  On output,
c    the order of the elements of A has been somewhat changed.
c
c    Output, double precision MEDIAN, the value of the median of A.
c
      implicit none

      integer n

      double precision a(n)
      integer k
      double precision median

      k = ( n + 1 ) / 2

      call r8vec_frac ( n, a, k, median )

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

c*********************************************************************72
c
cc R8VEC_MIDSPACE creates a vector of linearly spaced values.
c
c  Discussion:
c
c    An R8VEC is a vector of R8's.
c
c    This function divides the interval [a,b] into n subintervals, and then
c    returns the midpoints of those subintervals.
c
c  Example:
c
c    N = 5, A = 10, B = 20
c    X = [ 11, 13, 15, 17, 19 ]
c
c  Licensing:
c
c    This code is distributed under the GNU LGPL license.
c
c  Modified:
c
c    03 June 2012
c
c  Author:
c
c    John Burkardt
c
c  Parameters:
c
c    Input, integer N, the number of entries in the vector.
c
c    Input, double precision A, B, the endpoints of the interval.
c
c    Output, double precision X(N), a vector of linearly spaced data.
c
      implicit none

      integer n

      double precision a
      double precision b
      integer i
      double precision x(n)

      do i = 1, n
        x(i) = ( dble ( 2 * n - 2 * i + 1 ) * a 
     &         + dble (         2 * i - 1 ) * b ) 
     &         / dble ( 2 * n )
      end do

      return
      end
      subroutine r8vec_min ( n, a, amin )

c*********************************************************************72
c
cc R8VEC_MIN returns the minimum value in an R8VEC.
c
c  Discussion:
c
c    An R8VEC is a vector of R8's.
c
c  Licensing:
c
c    This code is distributed under the GNU LGPL license.
c
c  Modified:
c
c    31 May 2009
c
c  Author:
c
c    John Burkardt
c
c  Parameters:
c
c    Input, integer N, the number of entries in the array.
c
c    Input, double precision A(N), the array.
c
c    Output, double precision AMIN, the value of the smallest entry.
c
      implicit none

      integer n

      double precision a(n)
      double precision amin
      integer i

      amin = a(1)
      do i = 2, n
        amin = min ( amin, a(i) )
      end do

      return
      end
      subroutine r8vec_min_index ( n, a, min_index )

c*********************************************************************72
c
cc R8VEC_MIN_INDEX returns the index of the minimum value in an R8VEC.
c
c  Discussion:
c
c    An R8VEC is a vector of R8's.
c
c  Licensing:
c
c    This code is distributed under the GNU LGPL license.
c
c  Modified:
c
c    07 July 2009
c
c  Author:
c
c    John Burkardt
c
c  Parameters:
c
c    Input, integer N, the number of entries in the array.
c
c    Input, double precision A(N), the array.
c
c    Output, integer MIN_INDEX, the index of the smallest entry.
c
      implicit none

      integer n

      double precision a(n)
      integer i
      integer min_index

      if ( n .le. 0 ) then

        min_index = -1

      else

        min_index = 1

        do i = 2, n
          if ( a(i) .lt. a(min_index) ) then
            min_index = i
          end if
        end do

      end if

      return
      end
      function r8vec_min_pos ( n, a )

c*********************************************************************72
c
cc R8VEC_MIN_POS returns the minimum positive value of an R8VEC.
c
c  Discussion:
c
c    An R8VEC is a vector of R8's.
c
c  Licensing:
c
c    This code is distributed under the GNU LGPL license.
c
c  Modified:
c
c    08 November 2009
c
c  Author:
c
c    John Burkardt
c
c  Parameters:
c
c    Input, integer N, the number of entries.
c
c    Input, double precision A(N), the array.
c
c    Output, double precision R8VEC_MIN_POS, the smallest positive entry,
c    or R8_HUGE if no entry is positive.
c
      implicit none

      integer n

      double precision a(n)
      integer i
      double precision r8_huge
      parameter ( r8_huge = 1.0D+30 )
      double precision r8vec_min_pos
      double precision value

      value = r8_huge

      do i = 1, n
        if ( 0.0D+00 .lt. a(i) ) then
          value = min ( value, a(i) )
        end if
      end do

      r8vec_min_pos = value

      return
      end
      subroutine r8vec_mirror_next ( n, a, done )

c*********************************************************************72
c
cc R8VEC_MIRROR_NEXT steps through all sign variations of an R8VEC.
c
c  Discussion:
c
c    An R8VEC is a vector of R8's.
c
c    In normal use, the user would set every element of A to be positive.
c    The routine will take the input value of A, and output a copy in
c    which the signs of one or more entries have been changed.  Repeatedly
c    calling the routine with the output from the previous call will generate
c    every distinct "variation" of A; that is, all possible sign variations.
c
c    When the output variable DONE is TRUE (or equal to 1), then the
c    output value of A_NEW is the last in the series.
c
c    Note that A may have some zero values.  The routine will essentially
c    ignore such entries; more exactly, it will not stupidly assume that -0
c    is a proper "variation" of 0c
c
c    Also, it is possible to call this routine with the signs of A set
c    in any way you like.  The routine will operate properly, but it
c    will nonethess terminate when it reaches the value of A in which
c    every nonzero entry has negative sign.
c
c    More efficient algorithms using the Gray code seem to require internal
c    memory in the routine, which is not one of MATLAB's strong points,
c    or the passing back and forth of a "memory array", or the use of
c    global variables, or unnatural demands on the user.  This form of
c    the routine is about as clean as I can make it.
c
c  Example:
c
c      Input         Output
c    ---------    --------------
c    A            A_NEW     DONE
c    ---------    --------  ----
c     1  2  3     -1  2  3  false
c    -1  2  3      1 -2  3  false
c     1 -2  3     -1 -2  3  false
c    -1 -2  3      1  2 -3  false
c     1  2 -3     -1  2 -3  false
c    -1  2 -3      1 -2 -3  false
c     1 -2 -3     -1 -2 -3  false
c    -1 -2 -3      1  2  3  true
c
c     1  0  3     -1  0  3  false
c    -1  0  3      1  0 -3  false
c     1  0 -3     -1  0 -3  false
c    -1  0 -3      1  0  3  true
c
c  Licensing:
c
c    This code is distributed under the GNU LGPL license.
c
c  Modified:
c
c    07 July 2009
c
c  Author:
c
c    John Burkardt
c
c  Reference:
c
c    Albert Nijenhuis, Herbert Wilf,
c    Combinatorial Algorithms for Computers and Calculators,
c    Academic Press, 1978,
c    ISBN: 0-12-519260-6,
c    LC: QA164.N54.
c
c  Parameters:
c
c    Input, integer N, the number of entries in the vector.
c
c    Input/output, double precision A(N), a vector of real numbers.
c    On output, the signs of some entries have been changed.
c
c    Output, logical DONE, is TRUE if the input vector A was the last element
c    in the series (every entry was nonpositive); the output vector is reset
c    so that all entries are nonnegative, but presumably the ride is overc
c
      implicit none

      integer n

      double precision a(n)
      logical done
      integer i
      integer positive
c
c  Seek the first strictly positive entry of A.
c
      positive = 0
      do i = 1, n
        if ( 0.0D+00 .lt. a(i) ) then
          positive = i
          go to 10
        end if
      end do

10    continue
c
c  If there is no strictly positive entry of A, there is no successor.
c
      if ( positive .eq. 0 ) then
        do i = 1, n
          a(i) = - a(i)
        end do
        done = .true.
        return
      end if
c
c  Otherwise, negate A up to the positive entry.
c
      do i = 1, positive
        a(i) = - a(i)
      end do

      done = .false.

      return
      end
      function r8vec_negative_strict ( n, a )

c*********************************************************************72
c
cc R8VEC_NEGATIVE_STRICT: every element of an R8VEC is strictly negative.
c
c  Discussion:
c
c    An R8VEC is a vector of R8's.
c
c  Licensing:
c
c    This code is distributed under the GNU LGPL license.
c
c  Modified:
c
c    24 June 2010
c
c  Author:
c
c    John Burkardt
c
c  Parameters:
c
c    Input, integer N, the number of entries in the vector.
c
c    Input, double precision A(N).
c
c    Output, logical R8VEC_NEGATIVE_STRICT, is TRUE every entry of the
c    vector is strictly negative.
c
      implicit none

      integer n

      double precision a(n)
      integer i
      logical r8vec_negative_strict

      r8vec_negative_strict = .true.

      do i = 1, n
        if ( 0.0D+00 .le. a(i) ) then
          r8vec_negative_strict = .false.
          return
        end if
      end do

      return
      end
      subroutine r8vec_nint ( n, a )

c*********************************************************************72
c
cc R8VEC_NINT rounds entries of an R8VEC.
c
c  Discussion:
c
c    An R8VEC is a vector of R8's.
c
c  Licensing:
c
c    This code is distributed under the GNU LGPL license.
c
c  Modified:
c
c    07 July 2009
c
c  Author:
c
c    John Burkardt
c
c  Parameters:
c
c    Input, integer N, the number of entries in the vector.
c
c    Input/output, double precision A(N), the vector to be NINT'ed.
c
      implicit none

      integer n

      double precision a(n)
      integer i

      do i = 1, n
        a(i) = nint ( dble ( a(i) ) )
      end do

      return
      end
      function r8vec_norm ( n, a )

c*********************************************************************72
c
cc R8VEC_NORM returns the L2 norm of an R8VEC.
c
c  Discussion:
c
c    An R8VEC is a vector of R8 values.
c
c    The vector L2 norm is defined as:
c
c      R8VEC_NORM = sqrt ( sum ( 1 <= I <= N ) A(I)^2 ).
c
c  Licensing:
c
c    This code is distributed under the GNU LGPL license.
c
c  Modified:
c
c    27 May 2008
c
c  Author:
c
c    John Burkardt
c
c  Parameters:
c
c    Input, integer N, the number of entries in A.
c
c    Input, double precision A(N), the vector whose L2 norm is desired.
c
c    Output, double precision R8VEC_NORM, the L2 norm of A.
c
      implicit none

      integer n

      double precision a(n)
      integer i
      double precision r8vec_norm
      double precision value

      value = 0.0D+00
      do i = 1, n
        value = value + a(i) * a(i)
      end do
      value = sqrt ( value )

      r8vec_norm = value

      return
      end
      function r8vec_norm_affine ( n, v0, v1 )

c*********************************************************************72
c
cc R8VEC_NORM_AFFINE returns the affine norm of an R8VEC.
c
c  Discussion:
c
c    An R8VEC is a vector of R8's.
c
c    The affine vector L2 norm is defined as:
c
c      R8VEC_NORM_AFFINE(V0,V1)
c        = sqrt ( sum ( 1 <= I <= N ) ( V1(I) - V0(I) )^2 )
c
c  Licensing:
c
c    This code is distributed under the GNU LGPL license.
c
c  Modified:
c
c    27 October 2010
c
c  Author:
c
c    John Burkardt
c
c  Parameters:
c
c    Input, integer N, the order of the vectors.
c
c    Input, double precision V0(N), the base vector.
c
c    Input, double precision V1(N), the vector whose affine norm is desired.
c
c    Output, double precision R8VEC_NORM_AFFINE, the L2 norm of V1-V0.
c
      implicit none

      integer n

      integer i
      double precision r8vec_norm_affine
      double precision v0(n)
      double precision v1(n)

      r8vec_norm_affine = 0.0D+00
      do i = 1, n
        r8vec_norm_affine = r8vec_norm_affine
     &    + ( v0(i) - v1(i) )**2
      end do
      r8vec_norm_affine = sqrt ( r8vec_norm_affine )

      return
      end
      function r8vec_norm_l0 ( n, a )

c*********************************************************************72
c
cc R8VEC_NORM_L0 returns the l0 "norm" of an R8VEC.
c
c  Discussion:
c
c    An R8VEC is a vector of R8's.
c
c    The l0 "norm" simply counts the number of nonzero entries in the vector.
c    It is not a true norm, but has some similarities to one.  It is useful
c    in the study of compressive sensing.
c
c  Licensing:
c
c    This code is distributed under the GNU LGPL license.
c
c  Modified:
c
c    01 June 2012
c
c  Author:
c
c    John Burkardt
c
c  Parameters:
c
c    Input, integer N, the number of entries in the vector.
c
c    Input, double precision A(N), the vector.
c
c    Output, integer R8VEC_NORM_L0, the value of the norm.
c
      implicit none

      integer n

      double precision a(n)
      integer i
      integer r8vec_norm_l0
      integer value

      value = 0
      do i = 1, n
        if ( a(i) .ne. 0.0 ) then
          value = value + 1
        end if
      end do

      r8vec_norm_l0 = value

      return
      end
      function r8vec_norm_l1 ( n, a )

c*********************************************************************72
c
cc R8VEC_NORM_L1 returns the L1 norm of an R8VEC.
c
c  Discussion:
c
c    An R8VEC is a vector of R8's.
c
c    The vector L1 norm is defined as:
c
c      R8VEC_NORM_L1 = sum ( 1 <= I <= N ) abs ( A(I) ).
c
c  Licensing:
c
c    This code is distributed under the GNU LGPL license.
c
c  Modified:
c
c    07 July 2009
c
c  Author:
c
c    John Burkardt
c
c  Parameters:
c
c    Input, integer N, the number of entries in A.
c
c    Input, double precision A(N), the vector whose L1 norm is desired.
c
c    Output, double precision R8VEC_NORM_L1, the L1 norm of A.
c
      implicit none

      integer n

      double precision a(n)
      integer i
      double precision r8vec_norm_l1

      r8vec_norm_l1 = 0.0D+00
      do i = 1, n
        r8vec_norm_l1 = r8vec_norm_l1 + abs ( a(i) )
      end do

      return
      end
      function r8vec_norm_l2 ( n, a )

c*********************************************************************72
c
cc R8VEC_NORM_L2 returns the L2 norm of an R8VEC.
c
c  Discussion:
c
c    An R8VEC is a vector of R8 values.
c
c    The vector L2 norm is defined as:
c
c      R8VEC_NORM_L2 = sqrt ( sum ( 1 <= I <= N ) A(I)^2 ).
c
c  Licensing:
c
c    This code is distributed under the GNU LGPL license.
c
c  Modified:
c
c    27 May 2008
c
c  Author:
c
c    John Burkardt
c
c  Parameters:
c
c    Input, integer N, the number of entries in A.
c
c    Input, double precision A(N), the vector whose L2 norm is desired.
c
c    Output, double precision R8VEC_NORM_L2, the L2 norm of A.
c
      implicit none

      integer n

      double precision a(n)
      integer i
      double precision r8vec_norm_l2
      double precision value

      value = 0.0D+00
      do i = 1, n
        value = value + a(i) * a(i)
      end do
      value = sqrt ( value )

      r8vec_norm_l2 = value

      return
      end
      function r8vec_norm_li ( n, a )

c*********************************************************************72
c
cc R8VEC_NORM_LI returns the L-infinity norm of an R8VEC.
c
c  Discussion:
c
c    An R8VEC is a vector of R8's.
c
c    The vector L-infinity norm is defined as:
c
c      R8VEC_NORM_LI = max ( 1 <= I <= N ) abs ( A(I) ).
c
c  Licensing:
c
c    This code is distributed under the GNU LGPL license.
c
c  Modified:
c
c    07 July 2009
c
c  Author:
c
c    John Burkardt
c
c  Parameters:
c
c    Input, integer N, the number of entries in A.
c
c    Input, double precision A(N), the vector whose L-infinity norm is desired.
c
c    Output, double precision R8VEC_NORM_LI, the L-infinity norm of A.
c
      implicit none

      integer n

      double precision a(n)
      integer i
      double precision r8vec_norm_li

      r8vec_norm_li = 0.0D+00
      do i = 1, n
        r8vec_norm_li = max ( r8vec_norm_li, abs ( a(i) ) )
      end do

      return
      end
      function r8vec_norm_lp ( n, a, p )

c*********************************************************************72
c
cc R8VEC_NORM_LP returns the LP norm of an R8VEC.
c
c  Discussion:
c
c    An R8VEC is a vector of R8's.
c
c    The vector LP norm is defined as:
c
c      R8VEC_NORM_LP = ( sum ( 1 <= I <= N ) ( abs ( A(I) ) )^P )^(1/P).
c
c    Usually, the LP norms with
c      1 <= P <= oo
c    are of interest.  This routine allows
c      0 < P <= Huge ( P ).
c    If P = Huge ( P ), then the L-oo norm is returned, which is
c    simply the maximum of the absolute values of the vector components.
c
c  Licensing:
c
c    This code is distributed under the GNU LGPL license.
c
c  Modified:
c
c    04 June 2010
c
c  Author:
c
c    John Burkardt
c
c  Parameters:
c
c    Input, integer N, the number of entries in A.
c
c    Input, double precision A(N), the vector whose LP norm is desired.
c
c    Input, double precision P, the index of the norm.
c
c    Output, double precision R8VEC_NORM_LP, the LP norm of A.
c
      implicit none

      integer n

      double precision a(n)
      integer i
      double precision p
      double precision r8_huge
      double precision r8vec_norm_lp

      if ( p .le. 0.0D+00 ) then
        r8vec_norm_lp = -1.0D+00
      else if ( p .eq. r8_huge ( ) ) then
        r8vec_norm_lp = 0.0D+00
        do i = 1, n
          r8vec_norm_lp = max ( r8vec_norm_lp, abs ( a(i) ) )
        end do
      else if ( p .eq. 1.0D+00 ) then
        r8vec_norm_lp = 0.0D+00
        do i = 1, n
          r8vec_norm_lp = r8vec_norm_lp + abs ( a(i) )
        end do
      else if ( p .eq. 2.0D+00 ) then
        r8vec_norm_lp = 0.0D+00
        do i = 1, n
          r8vec_norm_lp = r8vec_norm_lp + a(i) * a(i)
        end do
        r8vec_norm_lp = sqrt ( r8vec_norm_lp )
      else
        r8vec_norm_lp = 0.0D+00
        do i = 1, n
          r8vec_norm_lp = r8vec_norm_lp + ( abs ( a(i) ) ) ** p
        end do
        r8vec_norm_lp = ( r8vec_norm_lp ) ** ( 1.0D+00 / p )
      end if

      return
      end
      function r8vec_norm_squared ( n, a )

c*********************************************************************72
c
cc R8VEC_NORM_SQUARED returns the square of the L2 norm of an R8VEC.
c
c  Discussion:
c
c    An R8VEC is a vector of R8 values.
c
c    R8VEC_NORM_SQUARED = sum ( 1 <= I <= N ) A(I)^2
c
c  Licensing:
c
c    This code is distributed under the GNU LGPL license.
c
c  Modified:
c
c    30 March 2011
c
c  Author:
c
c    John Burkardt
c
c  Parameters:
c
c    Input, integer N, the number of entries in A.
c
c    Input, double precision A(N), the vector.
c
c    Output, double precision R8VEC_NORM_SQUARED, the square of the L2 norm.
c
      implicit none

      integer n

      double precision a(n)
      integer i
      double precision r8vec_norm_squared
      double precision value

      value = 0.0D+00
      do i = 1, n
        value = value + a(i) * a(i)
      end do

      r8vec_norm_squared = value

      return
      end
      subroutine r8vec_normal_01 ( n, seed, x )

c*********************************************************************72
c
cc R8VEC_NORMAL_01 returns a unit pseudonormal R8VEC.
c
c  Discussion:
c
c    An R8VEC is a vector of R8's.
c
c    The standard normal probability distribution function (PDF) has
c    mean 0 and standard deviation 1.
c
c    This routine can generate a vector of values on one call.  It
c    has the feature that it should provide the same results
c    in the same order no matter how we break up the task.
c
c    The Box-Muller method is used, which is efficient, but
c    generates an even number of values each time.  On any call
c    to this routine, an even number of new values are generated.
c    Depending on the situation, one value may be left over.
c    In that case, it is saved for the next call.
c
c  Licensing:
c
c    This code is distributed under the GNU LGPL license.
c
c  Modified:
c
c    17 July 2006
c
c  Author:
c
c    John Burkardt
c
c  Parameters:
c
c    Input, integer N, the number of values desired.  If N is negative,
c    then the code will flush its internal memory; in particular,
c    if there is a saved value to be used on the next call, it is
c    instead discarded.  This is useful if the user has reset the
c    random number seed, for instance.
c
c    Input/output, integer SEED, a seed for the random number generator.
c
c    Output, double precision X(N), a sample of the standard normal PDF.
c
c  Local parameters:
c
c    Local, integer MADE, records the number of values that have
c    been computed.  On input with negative N, this value overwrites
c    the return value of N, so the user can get an accounting of
c    how much work has been done.
c
c    Local, integer SAVED, is 0 or 1 depending on whether there is a
c    single saved value left over from the previous call.
c
c    Local, integer X_LO_INDEX, X_HI_INDEX, records the range of entries of
c    X that we need to compute.  This starts off as 1:N, but is adjusted
c    if we have a saved value that can be immediately stored in X(1),
c    and so on.
c
c    Local, double precision Y, the value saved from the previous call, if
c    SAVED is 1.
c
      implicit none

      integer n

      integer i
      integer m
      integer made
      double precision pi
      parameter ( pi = 3.141592653589793D+00 )
      double precision r(2)
      double precision r8_uniform_01
      integer saved
      integer seed
      double precision x(n)
      integer x_hi_index
      integer x_lo_index
      double precision y

      save made
      save saved
      save y

      data made / 0 /
      data saved / 0 /
      data y / 0.0D+00 /
c
c  I'd like to allow the user to reset the internal data.
c  But this won't work properly if we have a saved value Y.
c  I'm making a crock option that allows the user to signal
c  explicitly that any internal memory should be flushed,
c  by passing in a negative value for N.
c
      if ( n .lt. 0 ) then
        n = made
        made = 0
        saved = 0
        y = 0.0D+00
        return
      else if ( n .eq. 0 ) then
        return
      end if
c
c  Record the range of X we need to fill in.
c
      x_lo_index = 1
      x_hi_index = n
c
c  Use up the old value, if we have it.
c
      if ( saved .eq. 1 ) then
        x(1) = y
        saved = 0
        x_lo_index = 2
      end if
c
c  Maybe we don't need any more values.
c
      if ( x_hi_index - x_lo_index + 1 .eq. 0 ) then
c
c  If we need just one new value, do that here to avoid null arrays.
c
      else if ( x_hi_index - x_lo_index + 1 .eq. 1 ) then

        r(1) = r8_uniform_01 ( seed )

        if ( r(1) .eq. 0.0D+00 ) then
          write ( *, '(a)' ) ' '
          write ( *, '(a)' ) 'R8VEC_NORMAL_01 - Fatal errorc'
          write ( *, '(a)' ) '  R8_UNIFORM_01 returned a value of 0.'
          stop
        end if

        r(2) = r8_uniform_01 ( seed )

        x(x_hi_index) =
     &           sqrt ( -2.0D+00 * log ( r(1) ) )
     &           * cos ( 2.0D+00 * pi * r(2) )
        y =      sqrt ( -2.0D+00 * log ( r(1) ) )
     &           * sin ( 2.0D+00 * pi * r(2) )

        saved = 1

        made = made + 2
c
c  If we require an even number of values, that's easy.
c
      else if ( mod ( x_hi_index - x_lo_index + 1, 2 ) .eq. 0 ) then

        do i = x_lo_index, x_hi_index, 2

          call r8vec_uniform_01 ( 2, seed, r )

          x(i) =
     &      sqrt ( -2.0D+00 * log ( r(1) ) )
     &      * cos ( 2.0D+00 * pi * r(2) )

          x(i+1) =
     &      sqrt ( -2.0D+00 * log ( r(1) ) )
     &      * sin ( 2.0D+00 * pi * r(2) )

        end do

        made = made + x_hi_index - x_lo_index + 1
c
c  If we require an odd number of values, we generate an even number,
c  and handle the last pair specially, storing one in X(N), and
c  saving the other for later.
c
      else

        do i = x_lo_index, x_hi_index - 1, 2

          call r8vec_uniform_01 ( 2, seed, r )

          x(i) =
     &      sqrt ( -2.0D+00 * log ( r(1) ) )
     &      * cos ( 2.0D+00 * pi * r(2) )

          x(i+1) =
     &      sqrt ( -2.0D+00 * log ( r(1) ) )
     &      * sin ( 2.0D+00 * pi * r(2) )

        end do

        call r8vec_uniform_01 ( 2, seed, r )

        x(n) = sqrt ( -2.0D+00 * log ( r(1) ) )
     &    * cos ( 2.0D+00 * pi * r(1) )

        y = sqrt ( -2.0D+00 * log ( r(2) ) )
     &    * sin ( 2.0D+00 * pi * r(2) )

        saved = 1

        made = made + x_hi_index - x_lo_index + 2

      end if

      return
      end
      subroutine r8vec_normalize ( n, a )

c*********************************************************************72
c
cc R8VEC_NORMALIZE normalizes an R8VEC in the Euclidean norm.
c
c  Discussion:
c
c    An R8VEC is a vector of R8's.
c
c    The euclidean norm is also sometimes called the l2 or
c    least squares norm.
c
c  Licensing:
c
c    This code is distributed under the GNU LGPL license.
c
c  Modified:
c
c    17 August 2010
c
c  Author:
c
c    John Burkardt
c
c  Parameters:
c
c    Input, integer N, the dimension of the vector.
c
c    Input/output, double precision A(N), the vector to be normalized.
c
      implicit none

      integer n

      double precision a(n)
      integer i
      double precision norm

      norm = 0.0D+00
      do i = 1, n
        norm = norm + a(i) * a(i)
      end do
      norm = sqrt ( norm )

      if ( norm .ne. 0.0D+00 ) then
        do i = 1, n
          a(i) = a(i) / norm
        end do
      end if

      return
      end
      subroutine r8vec_normalize_l1 ( n, a )

c*********************************************************************72
c
cc R8VEC_NORMALIZE_L1 normalizes an R8VEC to have unit sum.
c
c  Discussion:
c
c    An R8VEC is a vector of R8's.
c
c  Licensing:
c
c    This code is distributed under the GNU LGPL license.
c
c  Modified:
c
c    17 August 2010
c
c  Author:
c
c    John Burkardt
c
c  Parameters:
c
c    Input, integer N, the number of entries in the vector.
c
c    Input/output, double precision A(N), the vector to be normalized.
c    On output, the entries of A should have unit sum.  However, if
c    the input vector has zero sum, the routine halts.
c
      implicit none

      integer n

      double precision a(n)
      double precision a_sum
      integer i

      a_sum = 0.0D+00
      do i = 1, n
        a_sum = a_sum + a(i)
      end do

      if ( a_sum .eq. 0.0D+00 ) then
        write ( *, '(a)' ) ' '
        write ( *, '(a)' ) 'R8VEC_UNIT_SUM - Fatal error!'
        write ( *, '(a)' ) '  The vector entries sum to 0.'
        stop
      end if

      do i = 1, n
        a(i) = a(i) / a_sum
      end do

      return
      end
      function r8vec_normsq ( n, v )

c*********************************************************************72
c
cc R8VEC_NORMSQ returns the square of the L2 norm of an R8VEC.
c
c  Discussion:
c
c    An R8VEC is a vector of R8's.
c
c    The square of the vector L2 norm is defined as:
c
c      R8VEC_NORMSQ = sum ( 1 <= I <= N ) V(I)^2.
c
c  Licensing:
c
c    This code is distributed under the GNU LGPL license.
c
c  Modified:
c
c    28 October 2010
c
c  Author:
c
c    John Burkardt
c
c  Parameters:
c
c    Input, integer N, the vector dimension.
c
c    Input, double precision V(N), the vector.
c
c    Output, double precision R8VEC_NORMSQ, the squared L2 norm.
c
      implicit none

      integer n

      double precision r8vec_normsq
      double precision v(n)

      r8vec_normsq = sum ( v(1:n)**2 )

      return
      end
      function r8vec_normsq_affine ( n, v0, v1 )

c*****************************************************************************80
c
cc R8VEC_NORMSQ_AFFINE returns the affine squared norm of an R8VEC.
c
c  Discussion:
c
c   An R8VEC is a vector of R8's.
c
c    The affine squared vector L2 norm is defined as:
c
c      R8VEC_NORMSQ_AFFINE(V0,V1)
c        = sum ( 1 <= I <= N ) ( V1(I) - V0(I) )^2
c
c  Licensing:
c
c    This code is distributed under the GNU LGPL license.
c
c  Modified:
c
c    28 October 2010
c
c  Author:
c
c    John Burkardt
c
c  Parameters:
c
c    Input, integer N, the vector dimension.
c
c    Input, double precision V0(N), the base vector.
c
c    Input, double precision V1(N), the vector.
c
c    Output, double precision R8VEC_NORMSQ_AFFINE, the squared affine L2 norm.
c
      implicit none

      integer n

      integer i
      double precision r8vec_normsq_affine
      double precision v0(n)
      double precision v1(n)

      r8vec_normsq_affine = 0.0D+00
      do i = 1, n
        r8vec_normsq_affine = r8vec_normsq_affine + ( v0(i) - v1(i) )**2
      end do

      return
      end
      subroutine r8vec_ones ( n, a )

c*********************************************************************72
c
cc R8VEC_ONES returns a vector of 1's.
c
c  Discussion:
c
c    An R8VEC is a vector of R8's.
c
c  Licensing:
c
c    This code is distributed under the GNU LGPL license.
c
c  Modified:
c
c    14 March 2011
c
c  Author:
c
c    John Burkardt
c
c  Parameters:
c
c    Input, integer N, the length of the vector.
c
c    Output, double precision A(N), a vector of 1's.
c
      implicit none

      integer n

      double precision a(n)
      integer i

      do i = 1, n
        a(i) = 1.0D+00
      end do

      return
      end
      subroutine r8vec_order_type ( n, a, order )

c*********************************************************************72
c
cc R8VEC_ORDER_TYPE determines if R8VEC is (non)strictly ascending/descending.
c
c  Discussion:
c
c    An R8VEC is a vector of R8's.
c
c  Licensing:
c
c    This code is distributed under the GNU LGPL license.
c
c  Modified:
c
c    19 August 2010
c
c  Author:
c
c    John Burkardt
c
c  Parameters:
c
c    Input, integer N, the number of entries of the array.
c
c    Input, double precision A(N), the array to be checked.
c
c    Output, integer ORDER, order indicator:
c    -1, no discernable order;
c    0, all entries are equal;
c    1, ascending order;
c    2, strictly ascending order;
c    3, descending order;
c    4, strictly descending order.
c
      implicit none

      integer n

      double precision a(n)
      integer i
      integer order
c
c  Search for the first value not equal to A(1).
c
      i = 1

10    continue

        i = i + 1

        if ( n .lt. i ) then
          order = 0
          return
        end if

        if ( a(1) .lt. a(i) ) then

          if ( i .eq. 2 ) then
            order = 2
          else
            order = 1
          end if

          go to 20

        else if ( a(i) .lt. a(1) ) then

          if ( i .eq. 2 ) then
            order = 4
          else
            order = 3
          end if

          go to 20

        end if

      go to 10

20    continue
c
c  Now we have a "direction".  Examine subsequent entries.
c
30    continue

      if ( i .lt. n ) then

        i = i + 1

        if ( order .eq. 1 ) then

          if ( a(i) .lt. a(i-1) ) then
            order = -1
            go to 40
          end if

        else if ( order .eq. 2 ) then

          if ( a(i) .lt. a(i-1) ) then
            order = -1
            go to 40
          else if ( a(i) .eq. a(i-1) ) then
            order = 1
          end if

        else if ( order .eq. 3 ) then

          if ( a(i-1) .lt. a(i) ) then
            order = -1
            go to 40
          end if

        else if ( order .eq. 4 ) then

          if ( a(i-1) .lt. a(i) ) then
            order = -1
            go to 40
          else if ( a(i) .eq. a(i-1) ) then
            order = 3
          end if

        end if

        go to 30

      end if

40    continue

      return
      end
      subroutine r8vec_part_quick_a ( n, a, l, r )

c*********************************************************************72
c
cc R8VEC_PART_QUICK_A reorders an R8VEC as part of a quick sort.
c
c  Discussion:
c
c    An R8VEC is a vector of R8's.
c
c    The routine reorders the entries of A.  Using A(1) as the key,
c    all entries of A that are less than or equal to the key will
c    precede the key which precedes all entries that are greater than the key.
c
c  Example:
c
c    Input:
c
c      N = 8
c
c      A = ( 6, 7, 3, 1, 6, 8, 2, 9 )
c
c    Output:
c
c      L = 3, R = 6
c
c      A = ( 3, 1, 2, 6, 6, 8, 9, 7 )
c            -------        -------
c
c  Modified:
c
c    25 July 2008
c
c  Author:
c
c    John Burkardt
c
c  Parameters:
c
c    Input, integer N, the number of entries of A.
c
c    Input/output, double precision A(N).  On input, the array to be checked.
c    On output, A has been reordered as described above.
c
c    Output, integer L, R, the indices of A that define the three segments.
c    Let KEY = the input value of A(1).  Then
c    I <= L                 A(I) < KEY;
c         L < I < R         A(I) = KEY;
c                 R <= I    KEY < A(I).
c
      implicit none

      integer n

      double precision a(n)
      integer i
      double precision key
      integer l
      integer m
      integer r
      double precision temp

      if ( n .lt. 1 ) then
        write ( *, '(a)' ) ' '
        write ( *, '(a)' ) 'R8VEC_PART_QUICK_A - Fatal error!'
        write ( *, '(a)' ) '  N < 1.'
        stop
      else if ( n .eq. 1 ) then
        l = 0
        r = 2
        return
      end if

      key = a(1)
      m = 1
c
c  The elements of unknown size have indices between L+1 and R-1.
c
      l = 1
      r = n + 1

      do i = 2, n

        if ( key .lt. a(l+1) ) then
          r = r - 1
          temp = a(r)
          a(r) = a(l+1)
          a(l+1) = temp
        else if ( a(l+1) .eq. key ) then
          m = m + 1
          temp = a(m)
          a(m) = a(l+1)
          a(l+1) = temp
          l = l + 1
        else if ( a(l+1) .lt. key ) then
          l = l + 1
        end if

      end do
c
c  Now shift small elements to the left, and KEY elements to center.
c
      do i = 1, l - m
        a(i) = a(i+m)
      end do
c
c  Out of bounds here, occasionally
c
      l = l - m

      do i = l + 1, l + m
        a(i) = key
      end do

      return
      end
      subroutine r8vec_permute ( n, p, a )

c*********************************************************************72
c
cc R8VEC_PERMUTE permutes an R8VEC in place.
c
c  Discussion:
c
c    An R8VEC is a vector of R8's.
c
c    This routine permutes an array of real "objects", but the same
c    logic can be used to permute an array of objects of any arithmetic
c    type, or an array of objects of any complexity.  The only temporary
c    storage required is enough to store a single object.  The number
c    of data movements made is N + the number of cycles of order 2 or more,
c    which is never more than N + N/2.
c
c    P(I) = J means that the I-th element of the output array should be
c    the J-th element of the input array.  P must be a legal permutation
c    of the integers from 1 to N, otherwise the algorithm will
c    fail catastrophically.
c
c  Example:
c
c    Input:
c
c      N = 5
c      P = (   2,   4,   5,   1,   3 )
c      A = ( 1.0, 2.0, 3.0, 4.0, 5.0 )
c
c    Output:
c
c      A    = ( 2.0, 4.0, 5.0, 1.0, 3.0 ).
c
c  Licensing:
c
c    This code is distributed under the GNU LGPL license.
c
c  Modified:
c
c    18 July 2010
c
c  Author:
c
c    John Burkardt
c
c  Parameters:
c
c    Input, integer N, the number of objects.
c
c    Input, integer P(N), the permutation.
c
c    Input/output, double precision A(N), the array to be permuted.
c
      implicit none

      integer n

      double precision a(n)
      double precision a_temp
      integer base
      parameter ( base = 1 )
      integer ierror
      integer iget
      integer iput
      integer istart
      integer p(n)

      call perm_check ( n, p, base, ierror )

      if ( ierror .ne. 0 ) then
        write ( *, '(a)' ) ' '
        write ( *, '(a)' ) 'R8VEC_PERMUTE - Fatal error!'
        write ( *, '(a)' ) '  PERM_CHECK rejects this permutation.'
        stop
      end if
c
c  Search for the next element of the permutation that has not been used.
c
      do istart = 1, n

        if ( p(istart) .lt. 0 ) then

          go to 20

        else if ( p(istart) .eq. istart ) then

          p(istart) = - p(istart)
          go to 20

        else

          a_temp = a(istart)
          iget = istart
c
c  Copy the new value into the vacated entry.
c
10        continue

            iput = iget
            iget = p(iget)

            p(iput) = - p(iput)

            if ( iget .lt. 1 .or. n .lt. iget ) then
             write ( *, '(a)' ) ' '
              write ( *, '(a)' ) 'R8VEC_PERMUTE - Fatal error!'
              write ( *, '(a)' ) '  An index is out of range.'
              write ( *, '(a,i8,a,i8)' ) '  P(', iput, ') = ', iget
              stop
            end if

            if ( iget .eq. istart ) then
              a(iput) = a_temp
              go to 20
            end if

            a(iput) = a(iget)

          go to 10

        end if

20      continue

      end do
c
c  Restore the signs of the entries.
c
      p(1:n) = - p(1:n)

      return
      end
      subroutine r8vec_permute_cyclic ( n, k, a )

c*********************************************************************72
c
cc R8VEC_PERMUTE_CYCLIC performs a cyclic permutation of an R8VEC.
c
c  Discussion:
c
c    An R8VEC is a vector of R8's.
c
c    For 0 <= K < N, this function cyclically permutes the input vector
c    to have the form
c
c     ( A(K+1), A(K+2), ..., A(N), A(1), ..., A(K) )
c
c  Licensing:
c
c    This code is distributed under the GNU LGPL license.
c
c  Modified:
c
c    22 August 2010
c
c  Author:
c
c    John Burkardt
c
c  Parameters:
c
c    Input, integer N, the number of objects.
c
c    Input, integer K, the increment used.
c
c    Input/output, double precision A(N), the array to be permuted.
c
      implicit none

      integer n

      double precision a(n)
      double precision b(n)
      integer i
      integer i4_modp
      integer i4_wrap
      integer ipk
      integer k

      do i = 1, n
        ipk = i4_wrap ( i + k, 1, n )
        b(i) = a(ipk)
      end do

      do i = 1, n
        a(i) = b(i)
      end  do

      return
      end
      subroutine r8vec_permute_uniform ( n, a, seed )

c*********************************************************************72
c
cc R8VEC_PERMUTE_UNIFORM randomly permutes an R8VEC.
c
c  Discussion:
c
c    An R8VEC is a vector of R8's.
c
c  Licensing:
c
c    This code is distributed under the GNU LGPL license.
c
c  Modified:
c
c    07 July 2009
c
c  Author:
c
c    John Burkardt
c
c  Parameters:
c
c    Input, integer N, the number of objects.
c
c    Input/output, double precision A(N), the array to be permuted.
c
c    Input/output, integer SEED, a seed for the random
c    number generator.
c
      implicit none

      integer n

      double precision a(n)
      integer base
      parameter ( base = 1 )
      integer p(n)
      integer seed

      call perm_uniform ( n, base, seed, p )

      call r8vec_permute ( n, p, a )

      return
      end
      subroutine r8vec_polarize ( n, a, p, a_normal, a_parallel )

c*********************************************************************72
c
cc R8VEC_POLARIZE decomposes an R8VEC into normal and parallel components.
c
c  Discussion:
c
c    An R8VEC is a vector of R8's.
c
c    The (nonzero) vector P defines a direction.
c
c    The vector A can be written as the sum
c
c      A = A_normal + A_parallel
c
c    where A_parallel is a linear multiple of P, and A_normal
c    is perpendicular to P.
c
c  Licensing:
c
c    This code is distributed under the GNU LGPL license.
c
c  Modified:
c
c    19 August 2010
c
c  Author:
c
c    John Burkardt
c
c  Parameters:
c
c    Input, integer N, the number of entries in the array.
c
c    Input, double precision A(N), the vector to be polarized.
c
c    Input, double precision P(N), the polarizing direction.
c
c    Output, double precision A_NORMAL(N), A_PARALLEL(N), the normal
c    and parallel components of A.
c
      implicit none

      integer n

      double precision a(n)
      double precision a_dot_p
      double precision a_normal(n)
      double precision a_parallel(n)
      integer i
      double precision p(n)
      double precision p_norm
      double precision r8vec_dot_product

      p_norm = 0.0D+00
      do i = 1, n
        p_norm = p_norm + p(i) * p(i)
      end do
      p_norm = sqrt ( p_norm )

      if ( p_norm .eq. 0.0D+00 ) then
        do i = 1, n
          a_normal(i) = a(i)
        end do
        do i = 1, n
          a_parallel(i) = 0.0D+00
        end do
        return
      end if

      a_dot_p = r8vec_dot_product ( n, a, p ) / p_norm

      do i = 1, n
        a_parallel(i) = a_dot_p * p(i) / p_norm
      end do

      do i = 1, n
        a_normal(i) = a(i) - a_parallel(i)
      end do

      return
      end
      function r8vec_positive_strict ( n, a )

c*********************************************************************72
c
cc R8VEC_POSITIVE_STRICT: every element of an R8VEC is strictly positive.
c
c  Discussion:
c
c    An R8VEC is a vector of R8's.
c
c  Licensing:
c
c    This code is distributed under the GNU LGPL license.
c
c  Modified:
c
c    24 June 2010
c
c  Author:
c
c    John Burkardt
c
c  Parameters:
c
c    Input, integer N, the number of entries in the vector.
c
c    Input, double precision A(N).
c
c    Output, logical R8VEC_POSITIVE_STRICT, is TRUE every entry of the
c    vector is strictly positive.
c
      implicit none

      integer n

      double precision a(n)
      integer i
      logical r8vec_positive_strict

      r8vec_positive_strict = .true.

      do i = 1, n
        if ( a(i) .le. 0.0D+00 ) then
          r8vec_positive_strict = .false.
          return
        end if
      end do

      return
      end
      subroutine r8vec_print ( n, a, title )

c*********************************************************************72
c
cc R8VEC_PRINT prints an R8VEC.
c
c  Discussion:
c
c    An R8VEC is a vector of R8's.
c
c  Licensing:
c
c    This code is distributed under the GNU LGPL license.
c
c  Modified:
c
c    12 January 2007
c
c  Author:
c
c    John Burkardt
c
c  Parameters:
c
c    Input, integer N, the number of components of the vector.
c
c    Input, double precision A(N), the vector to be printed.
c
c    Input, character * ( * ) TITLE, a title.
c
      implicit none

      integer n

      double precision a(n)
      integer i
      character ( len = * ) title

      write ( *, '(a)' ) ' '
      write ( *, '(a)' ) trim ( title )
      write ( *, '(a)' ) ' '
      do i = 1, n
        write ( *, '(2x,i8,a,1x,g16.8)' ) i, ':', a(i)
      end do

      return
      end
      subroutine r8vec_print_part ( n, a, max_print, title )

c*********************************************************************72
c
cc R8VEC_PRINT_PART prints "part" of an R8VEC.
c
c  Discussion:
c
c    The user specifies MAX_PRINT, the maximum number of lines to print.
c
c    If N, the size of the vector, is no more than MAX_PRINT, then
c    the entire vector is printed, one entry per line.
c
c    Otherwise, if possible, the first MAX_PRINT-2 entries are printed,
c    followed by a line of periods suggesting an omission,
c    and the last entry.
c
c  Licensing:
c
c    This code is distributed under the GNU LGPL license.
c
c  Modified:
c
c    22 June 2010
c
c  Author:
c
c    John Burkardt
c
c  Parameters:
c
c    Input, integer N, the number of entries of the vector.
c
c    Input, double precision A(N), the vector to be printed.
c
c    Input, integer MAX_PRINT, the maximum number of lines to print.
c
c    Input, character*(*) TITLE, a title.
c
      implicit none

      integer n

      double precision a(n)
      integer i
      integer max_print
      character*(*) title

      if ( max_print .le. 0 ) then
        return
      end if

      if ( n .le. 0 ) then
        return
      end if

      write ( *, '(a)' ) ' '
      write ( *, '(a)' ) title
      write ( *, '(a)' ) ' '

      if ( n .le. max_print ) then

        do i = 1, n
          write ( *, '(2x,i8,a1,1x,g14.6)' ) i, ':', a(i)
        end do

      else if ( 3 .le. max_print ) then

        do i = 1, max_print - 2
          write ( *, '(2x,i8,a1,1x,g14.6)' ) i, ':', a(i)
        end do

        write ( *, '(a)' ) '  ........  ..............'
        i = n

        write ( *, '(2x,i8,a1,1x,g14.6)' ) i, ':', a(i)

      else

        do i = 1, max_print - 1
          write ( *, '(2x,i8,a1,1x,g14.6)' ) i, ':', a(i)
        end do

        i = max_print

        write ( *, '(2x,i8,a1,1x,g14.6,a)' )
     &    i, ':', a(i), '...more entries...'

      end if

      return
      end
      subroutine r8vec_print_some ( n, a, i_lo, i_hi, title )

c*********************************************************************72
c
cc R8VEC_PRINT_SOME prints "some" of an R8VEC.
c
c  Discussion:
c
c    An R8VEC is a vector of R8's.
c
c  Licensing:
c
c    This code is distributed under the GNU LGPL license.
c
c  Modified:
c
c    13 November 2010
c
c  Author:
c
c    John Burkardt
c
c  Parameters:
c
c    Input, integer N, the number of entries of the vector.
c
c    Input, double precision A(N), the vector to be printed.
c
c    Input, integer I_LO, I_HI, the first and last indices
c    to print.  The routine expects 1 <= I_LO <= I_HI <= N.
c
c    Input, character * ( * ) TITLE, a title.
c
      implicit none

      integer n

      double precision a(n)
      integer i
      integer i_hi
      integer i_lo
      character * ( * ) title

      write ( *, '(a)' ) ' '
      write ( *, '(a)' ) trim ( title )

      write ( *, '(a)' ) ' '
      do i = max ( i_lo, 1 ), min ( i_hi, n )
        write ( *, '(2x,i8,a,1x,g14.8)' ) i, ':', a(i)
      end do

      return
      end
      subroutine r8vec_print2 ( n, a )

c*********************************************************************72
c
cc R8VEC_PRINT2 prints out an R8VEC.
c
c  Discussion:
c
c    An R8VEC is a vector of R8's.
c
c  Licensing:
c
c    This code is distributed under the GNU LGPL license.
c
c  Modified:
c
c    20 August 2010
c
c  Author:
c
c    John Burkardt
c
c  Parameters:
c
c    Input, integer N, the number of entries of A.
c
c    Input, double precision A(N), the vector to be printed.
c
      implicit none

      integer n

      double precision a(n)
      double precision amax
      double precision amin
      integer i
      character*11 iform
      logical integ
      integer lmax
      double precision r8_log_10
c
c Check if all entries are integral.
c
      integ = .true.

      do i = 1, n

        if ( a(i) .ne. dble ( int ( a(i) ) ) ) then
          integ = .false.
          go to 10
        end if

      end do

10    continue
c
c  Find the range of the array.
c
      call r8vec_amax ( n, a, amax )
      call r8vec_amin ( n, a, amin )
c
c  Use the information about the maximum size of an entry to
c  compute an intelligent format for use with integer entries.
c
c  Later, we might also do this for real vectors.
c
      lmax = int ( r8_log_10 ( amax ) )

      if ( integ ) then
        write ( iform, '( ''(2x,i'', i2, '')'' )' ) lmax + 3
      else
        iform = ' '
      end if

      do i = 1, n

        if ( integ ) then
          write ( *, iform ) int ( a(i) )
        else
          write ( *, '(2x,g14.6)' ) a(i)
        end if

      end do

      return
      end
      function r8vec_product ( n, v1 )

c*********************************************************************72
c
cc R8VEC_PRODUCT multiplies the entries of an R8VEC.
c
c  Discussion:
c
c    An R8VEC is a vector of R8 values.
c
c    In FORTRAN90, the system routine PRODUCT should be called
c    directly.
c
c  Licensing:
c
c    This code is distributed under the GNU LGPL license.
c
c  Modified:
c
c    22 July 2008
c
c  Author:
c
c    John Burkardt
c
c  Parameters:
c
c    Input, integer N, the dimension of the vectors.
c
c    Input, double precision V1(N), the vector.
c
c    Output, double precision R8VEC_PRODUCT, the product of the entries.
c
      implicit none

      integer n

      integer i
      double precision r8vec_product
      double precision v1(n)
      double precision value

      value = 1.0D+00
      do i = 1, n
        value = value * v1(i)
      end do

      r8vec_product = value

      return
      end
      subroutine r8vec_range ( n, x, xmin, xmax, y, ymin, ymax )

c*********************************************************************72
c
cc R8VEC_RANGE finds the range of Y's within a restricted X range.
c
c  Discussion:
c
c    An R8VEC is a vector of R8's.
c
c    The routine is given a set of pairs of points (X,Y), and a range
c    XMIN to XMAX of valid X values.  Over this range, it seeks
c    YMIN and YMAX, the minimum and maximum values of Y for
c    valid X's.
c
c  Licensing:
c
c    This code is distributed under the GNU LGPL license.
c
c  Modified:
c
c    20 August 2010
c
c  Author:
c
c    John Burkardt
c
c  Parameters:
c
c    Input, integer N, the number of entries in the array.
c
c    Input, double precision X(N), the X array.
c
c    Input, double precision XMIN, XMAX, the range of X values to check.
c
c    Input, double precision Y(N), the Y array.
c
c    Output, double precision YMIN, YMAX, the range of Y values whose
c    X value is within the X range.
c
      implicit none

      integer n

      integer i
      double precision r8_huge
      double precision x(n)
      double precision xmax
      double precision xmin
      double precision y(n)
      double precision ymax
      double precision ymin

      ymin =   r8_huge ( )
      ymax = - r8_huge ( )

      do i = 1, n

        if ( xmin .le. x(i) .and. x(i) .le. xmax ) then

          ymin = min ( ymin, y(i) )
          ymax = max ( ymax, y(i) )

        end if

      end do

      return
      end
      subroutine r8vec_range_2 ( n, a, amin, amax )

c*********************************************************************72
c
cc R8VEC_RANGE_2 updates a range to include a new array.
c
c  Discussion:
c
c    An R8VEC is a vector of R8's.
c
c    Given a range AMIN to AMAX, and an array A, the routine will
c    decrease AMIN if necessary, or increase AMAX if necessary, so that
c    every entry of A is between AMIN and AMAX.
c
c    However, AMIN will not be increased, nor AMAX decreased.
c
c    This routine may be used to compute the maximum and minimum of a
c    collection of arrays one at a time.
c
c  Licensing:
c
c    This code is distributed under the GNU LGPL license.
c
c  Modified:
c
c    11 September 201
c
c  Author:
c
c    John Burkardt
c
c  Parameters:
c
c    Input, integer N, the number of entries in the array.
c
c    Input, double precision A(N), the array.
c
c    Input/output, double precision AMIN, AMAX.  On input, the
c    current legal range of values for A.  On output, AMIN and AMAX
c    are either unchanged, or else "widened" so that all entries
c    of A are within the range.
c
      implicit none

      integer n

      double precision a(n)
      double precision amax
      double precision amax2
      double precision amin
      double precision amin2

      call r8vec_max ( n, a, amax2 )
      call r8vec_min ( n, a, amin2 )

      amax = max ( amax, amax2 )
      amin = min ( amin, amin2 )

      return
      end
      subroutine r8vec_reverse ( n, a )

c*********************************************************************72
c
cc R8VEC_REVERSE reverses the elements of an R8VEC.
c
c  Discussion:
c
c    An R8VEC is a vector of R8's.
c
c    In FORTRAN90, calling R8VEC_REVERSE is equivalent to
c
c      A(1:N) = A(N:1:-1)
c
c  Example:
c
c    Input:
c
c      N = 5,
c      A = ( 11.0, 12.0, 13.0, 14.0, 15.0 ).
c
c    Output:
c
c      A = ( 15.0, 14.0, 13.0, 12.0, 11.0 ).
c
c  Licensing:
c
c    This code is distributed under the GNU LGPL license.
c
c  Modified:
c
c    04 July 2009
c
c  Author:
c
c    John Burkardt
c
c  Parameters:
c
c    Input, integer N, the number of entries in the array.
c
c    Input/output, double precision A(N), the array to be reversed.
c
      implicit none

      integer n

      double precision a(n)
      integer i
      double precision t

      do i = 1, n/2
        t        = a(i)
        a(i)     = a(n+1-i)
        a(n+1-i) = t
      end do

      return
      end
      function r8vec_rms ( n, a )

c*********************************************************************72
c
cc R8VEC_RMS returns the RMS norm of an R8VEC.
c
c  Discussion:
c
c    An R8VEC is a vector of R8 values.
c
c    The vector RMS norm is defined as:
c
c      R8VEC_RMS = sqrt ( sum ( 1 <= I <= N ) A(I)^2 / N ).
c
c  Licensing:
c
c    This code is distributed under the GNU LGPL license.
c
c  Modified:
c
c    26 October 2011
c
c  Author:
c
c    John Burkardt
c
c  Parameters:
c
c    Input, integer N, the number of entries in A.
c
c    Input, double precision A(N), the vector.
c
c    Output, double precision R8VEC_RMS, the RMS norm of A.
c
      implicit none

      integer n

      double precision a(n)
      integer i
      double precision r8vec_rms
      double precision value

      value = 0.0D+00

      if ( 0 .lt. n ) then
        do i = 1, n
          value = value + a(i) * a(i)
        end do
        value = sqrt ( value / dble ( n  ) )
      end if

      r8vec_rms = value

      return
      end
      subroutine r8vec_rotate ( n, a, m )

c*********************************************************************72
c
cc R8VEC_ROTATE "rotates" the entries of an R8VEC in place.
c
c  Discussion:
c
c    An R8VEC is a vector of R8's.
c
c    This routine rotates an array of real "objects", but the same
c    logic can be used to permute an array of objects of any arithmetic
c    type, or an array of objects of any complexity.  The only temporary
c    storage required is enough to store a single object.  The number
c    of data movements made is N + the number of cycles of order 2 or more,
c    which is never more than N + N/2.
c
c  Example:
c
c    Input:
c
c      N = 5, M = 2
c      A    = ( 1.0, 2.0, 3.0, 4.0, 5.0 )
c
c    Output:
c
c      A    = ( 4.0, 5.0, 1.0, 2.0, 3.0 ).
c
c  Licensing:
c
c    This code is distributed under the GNU LGPL license.
c
c  Modified:
c
c    07 July 2009
c
c  Author:
c
c    John Burkardt
c
c  Parameters:
c
c    Input, integer N, the number of objects.
c
c    Input, integer M, the number of positions to the right that
c    each element should be moved.  Elements that shift pass position
c    N "wrap around" to the beginning of the array.
c
c    Input/output, double precision A(N), the array to be rotated.
c
      implicit none

      integer n

      double precision a(n)
      integer i4_modp
      integer iget
      integer iput
      integer istart
      integer m
      integer mcopy
      integer nset
      double precision temp
c
c  Force M to be positive, between 0 and N-1.
c
      mcopy = i4_modp ( m, n )

      if ( mcopy .eq. 0 ) then
        return
      end if

      istart = 0
      nset = 0

10    continue

        istart = istart + 1

        if ( n .lt. istart ) then
          go to 40
        end if

        temp = a(istart)
        iget = istart
c
c  Copy the new value into the vacated entry.
c
20    continue

        iput = iget

          iget = iget - mcopy
          if ( iget .lt. 1 ) then
            iget = iget + n
          end if

          if ( iget .eq. istart ) then
            go to 30
          end if

          a(iput) = a(iget)
          nset = nset + 1

        go to 20

30      continue

        a(iput) = temp
        nset = nset + 1

        if ( n .le. nset ) then
          go to 40
        end if

      go to 10

40    continue

      return
      end
      function r8vec_scalar_triple_product ( v1, v2, v3 )

c*********************************************************************72
c
cc R8VEC_SCALAR_TRIPLE_PRODUCT computes the scalar triple product.
c
c  Discussion:
c
c    STRIPLE = V1 dot ( V2 x V3 ).
c
c    STRIPLE is the volume of the parallelogram whose sides are
c    formed by V1, V2 and V3.
c
c  Licensing:
c
c    This code is distributed under the GNU LGPL license.
c
c  Modified:
c
c    27 October 2010
c
c  Author:
c
c    John Burkardt
c
c  Parameters:
c
c    Input, double precision V1(3), V2(3), V3(3), the three vectors.
c
c    Output, double precision R8VEC_SCALAR_TRIPLE_PRODUCT, the scalar
c    triple product.
c
      implicit none

      double precision r8vec_scalar_triple_product
      double precision v1(3)
      double precision v2(3)
      double precision v3(3)

      r8vec_scalar_triple_product =
     &    v1(1) * ( v2(2) * v3(3) - v2(3) * v3(2) )
     &  + v1(2) * ( v2(3) * v3(1) - v2(1) * v3(3) )
     &  + v1(3) * ( v2(1) * v3(2) - v2(2) * v3(1) )

      return
      end
      subroutine r8vec_search_binary_a ( n, a, aval, indx )

c*********************************************************************72
c
cc R8VEC_SEARCH_BINARY_A searches an ascending sorted R8VEC.
c
c  Discussion:
c
c    An R8VEC is a vector of R8's.
c
c    Binary search is used.
c
c  Licensing:
c
c    This code is distributed under the GNU LGPL license.
c
c  Modified:
c
c    04 July 2009
c
c  Author:
c
c    John Burkardt
c
c  Reference:
c
c    Donald Kreher, Douglas Simpson,
c    Algorithm 1.9,
c    Combinatorial Algorithms,
c    CRC Press, 1998, page 26.
c
c  Parameters:
c
c    Input, integer N, the number of elements in the array.
c
c    Input, double precision A(N), the array to be searched.  The array must
c    be sorted in ascending order.
c
c    Input, double precision AVAL, the value to be searched for.
c
c    Output, integer INDX, the result of the search.
c    -1, AVAL does not occur in the array.
c    I, A(I) = AVAL.
c
      implicit none

      integer n

      double precision a(n)
      double precision aval
      integer high
      integer indx
      integer low
      integer mid

      indx = -1

      low = 1
      high = n

10    continue

      if ( low .le. high ) then

        mid = ( low + high ) / 2

        if ( a(mid) .eq. aval ) then
          indx = mid
          go to 20
        else if ( a(mid) .lt. aval ) then
          low = mid + 1
        else if ( aval .lt. a(mid) ) then
          high = mid - 1
        end if

        go to 10

      end if

20    continue

      return
      end
      subroutine r8vec_shift ( shift, n, x )

c*********************************************************************72
c
cc R8VEC_SHIFT performs a shift on an R8VEC.
c
c  Discussion:
c
c    An R8VEC is a vector of R8 values.
c
c  Licensing:
c
c    This code is distributed under the GNU LGPL license.
c
c  Modified:
c
c    12 March 2011
c
c  Author:
c
c    John Burkardt
c
c  Parameters:
c
c    Input, integer SHIFT, the amount by which each entry is to
c    be shifted.
c
c    Input, integer N, the length of the vector.
c
c    Input/output, double precision X(N), the vector to be shifted.
c
      implicit none

      integer n

      integer i
      integer j
      integer shift
      double precision x(n)
      double precision y(n)

      do i = 1, n
        y(i) = x(i)
      end do

      do i = 1, n
        x(i) = 0.0D+00
      end do

      do i = 1, n
        j = i - shift
        if ( 1 .le. j .and. j .le. n ) then
          x(i) = y(j)
        end if
      end do

      return
      end
      subroutine r8vec_shift_circular ( shift, n, x )

c*********************************************************************72
c
cc R8VEC_SHIFT_CIRCULAR performs a circular shift on an R8VEC.
c
c  Discussion:
c
c    An R8VEC is a vector of R8 values.
c
c  Licensing:
c
c    This code is distributed under the GNU LGPL license.
c
c  Modified:
c
c    11 March 2011
c
c  Author:
c
c    John Burkardt
c
c  Parameters:
c
c    Input, integer SHIFT, the amount by which each entry is to
c    be shifted.
c
c    Input, integer N, the length of the vector.
c
c    Input/output, double precision X(N), the vector to be shifted.
c
      implicit none

      integer n

      integer i
      integer i4_wrap
      integer j
      integer shift
      double precision x(n)
      double precision y(n)

      do i = 1, n
        y(i) = x(i)
      end do

      do i = 1, n
        j = i4_wrap ( i - shift, 1, n )
        x(i) = y(j)
      end do

      return
      end
      subroutine r8vec_sort_bubble_a ( n, a )

c*********************************************************************72
c
cc R8VEC_SORT_BUBBLE_A ascending sorts an R8VEC using bubble sort.
c
c  Discussion:
c
c    An R8VEC is a vector of R8's.
c
c    Bubble sort is simple to program, but inefficient.  It should not
c    be used for large arrays.
c
c  Licensing:
c
c    This code is distributed under the GNU LGPL license.
c
c  Modified:
c
c    31 May 2009
c
c  Author:
c
c    John Burkardt
c
c  Parameters:
c
c    Input, integer N, the number of entries in the array.
c
c    Input/output, double precision A(N).
c    On input, an unsorted array.
c    On output, the array has been sorted.
c
      implicit none

      integer n

      double precision a(n)
      integer i
      integer  j
      double precision t

      do i = 1, n - 1
        do j = i + 1, n
          if ( a(j) .lt. a(i) ) then
            t    = a(i)
            a(i) = a(j)
            a(j) = t
          end if
        end do
      end do

      return
      end
      subroutine r8vec_sort_bubble_d ( n, a )

c*********************************************************************72
c
cc R8VEC_SORT_BUBBLE_D descending sorts an R8VEC using bubble sort.
c
c  Discussion:
c
c    An R8VEC is a vector of R8's.
c
c    Bubble sort is simple to program, but inefficient.  It should not
c    be used for large arrays.
c
c  Licensing:
c
c    This code is distributed under the GNU LGPL license.
c
c  Modified:
c
c    31 May 2009
c
c  Author:
c
c    John Burkardt
c
c  Parameters:
c
c    Input, integer N, the number of entries in the array.
c
c    Input/output, double precision A(N).
c    On input, an unsorted array.
c    On output, the array has been sorted.
c
      implicit none

      integer n

      double precision a(n)
      integer i
      integer j
      double precision t

      do i = 1, n - 1
        do j = i + 1, n
          if ( a(i) .lt. a(j) ) then
            t    = a(i)
            a(i) = a(j)
           a(j) = t
          end if
        end do
      end do

      return
      end
      subroutine r8vec_sort_heap_a ( n, a )

c*********************************************************************72
c
cc R8VEC_SORT_HEAP_A ascending sorts an R8VEC using heap sort.
c
c  Discussion:
c
c    An R8VEC is a vector of R8's.
c
c  Licensing:
c
c    This code is distributed under the GNU LGPL license.
c
c  Modified:
c
c    01 June 2009
c
c  Author:
c
c    John Burkardt
c
c  Reference:
c
c    Albert Nijenhuis, Herbert Wilf,
c    Combinatorial Algorithms for Computers and Calculators,
c    Academic Press, 1978,
c    ISBN: 0-12-519260-6,
c    LC: QA164.N54.
c
c  Parameters:
c
c    Input, integer N, the number of entries in the array.
c
c    Input/output, double precision A(N).
c    On input, the array to be sorted;
c    On output, the array has been sorted.
c
      implicit none

      integer n

      double precision a(n)
      integer n1
      double precision temp

      if ( n .le. 1 ) then
        return
      end if
c
c  1: Put A into descending heap form.
c
      call r8vec_heap_d ( n, a )
c
c  2: Sort A.
c
c  The largest object in the heap is in A(1).
c  Move it to position A(N).
c
      temp = a(1)
      a(1) = a(n)
      a(n) = temp
c
c  Consider the diminished heap of size N1.
c
      do n1 = n - 1, 2, -1
c
c  Restore the heap structure of A(1) through A(N1).
c
        call r8vec_heap_d ( n1, a )
c
c  Take the largest object from A(1) and move it to A(N1).
c
        temp = a(1)
        a(1) = a(n1)
        a(n1) = temp

      end do

      return
      end
      subroutine r8vec_sort_heap_d ( n, a )

c*********************************************************************72
c
cc R8VEC_SORT_HEAP_D descending sorts an R8VEC using heap sort.
c
c  Discussion:
c
c    An R8VEC is a vector of R8's.
c
c  Licensing:
c
c    This code is distributed under the GNU LGPL license.
c
c  Modified:
c
c    01 June 2009
c
c  Author:
c
c    John Burkardt
c
c  Reference:
c
c    Albert Nijenhuis, Herbert Wilf,
c    Combinatorial Algorithms for Computers and Calculators,
c    Academic Press, 1978,
c    ISBN: 0-12-519260-6,
c    LC: QA164.N54.
c
c  Parameters:
c
c    Input, integer N, the number of entries in the array.
c
c    Input/output, double precision A(N).
c    On input, the array to be sorted;
c    On output, the array has been sorted.
c
      implicit none

      integer n

      double precision a(n)
      integer n1

      if ( n .le. 1 ) then
        return
      end if
c
c  1: Put A into ascending heap form.
c
      call r8vec_heap_a ( n, a )
c
c  2: Sort A.
c
c  The smallest object in the heap is in A(1).
c  Move it to position A(N).
c
      call r8_swap ( a(1), a(n) )
c
c  Consider the diminished heap of size N1.
c
      do n1 = n - 1, 2, -1
c
c  Restore the heap structure of A(1) through A(N1).
c
        call r8vec_heap_a ( n1, a )
c
c  Take the smallest object from A(1) and move it to A(N1).
c
        call r8_swap ( a(1), a(n1) )

      end do

      return
      end
      subroutine r8vec_sort_heap_index_a ( n, a, indx )

c*********************************************************************72
c
cc R8VEC_SORT_HEAP_INDEX_A does an indexed heap ascending sort of an R8VEC.
c
c  Discussion:
c
c    An R8VEC is a vector of R8's.
c
c    The sorting is not actually carried out.  Rather an index array is
c    created which defines the sorting.  This array may be used to sort
c    or index the array, or to sort or index related arrays keyed on the
c    original array.
c
c    Once the index array is computed, the sorting can be carried out
c    "implicitly:
c
c      A(INDX(I:N)) is sorted,
c
c    or explicitly, by the call
c
c      call r8vec_permute ( n, indx, a )
c
c    after which A(1:N) is sorted.
c
c  Licensing:
c
c    This code is distributed under the GNU LGPL license.
c
c  Modified:
c
c    01 June 2009
c
c  Author:
c
c    John Burkardt
c
c  Parameters:
c
c    Input, integer N, the number of entries in the array.
c
c    Input, double precision A(N), an array to be index-sorted.
c
c    Output, integer INDX(N), the sort index.  The
c    I-th element of the sorted array is A(INDX(I)).
c
      implicit none

      integer n

      double precision a(n)
      double precision aval
      integer i
      integer indx(n)
      integer indxt
      integer ir
      integer j
      integer l

      if ( n .lt. 1 ) then
        return
      end if

      do i = 1, n
        indx(i) = i
      end do

      if ( n .eq. 1 ) then
        return
      end if

      l = n / 2 + 1
      ir = n

10    continue

        if ( 1 .lt. l ) then

          l = l - 1
          indxt = indx(l)
          aval = a(indxt)

        else

          indxt = indx(ir)
          aval = a(indxt)
          indx(ir) = indx(1)
          ir = ir - 1

          if ( ir .eq. 1 ) then
            indx(1) = indxt
            go to 30
          end if

        end if

        i = l
        j = l + l

20      continue

        if ( j .le. ir ) then

          if ( j .lt. ir ) then
            if ( a(indx(j)) .lt. a(indx(j+1)) ) then
              j = j + 1
            end if
          end if

          if ( aval .lt. a(indx(j)) ) then
            indx(i) = indx(j)
            i = j
            j = j + j
          else
            j = ir + 1
          end if

          go to 20

        end if

        indx(i) = indxt

      go to 10

30    continue

      return
      end
      subroutine r8vec_sort_heap_index_d ( n, a, indx )

c*********************************************************************72
c
cc R8VEC_SORT_HEAP_INDEX_D does an indexed heap descending sort of an R8VEC.
c
c  Discussion:
c
c    An R8VEC is a vector of R8's.
c
c    The sorting is not actually carried out.  Rather an index array is
c    created which defines the sorting.  This array may be used to sort
c    or index the array, or to sort or index related arrays keyed on the
c    original array.
c
c    Once the index array is computed, the sorting can be carried out
c    "implicitly:
c
c      A(INDX(1:N)) is sorted,
c
c    or explicitly, by the call
c
c      call r8vec_permute ( n, indx, a )
c
c    after which A(1:N) is sorted.
c
c  Licensing:
c
c    This code is distributed under the GNU LGPL license.
c
c  Modified:
c
c    01 June 2009
c
c  Author:
c
c    John Burkardt
c
c  Parameters:
c
c    Input, integer N, the number of entries in the array.
c
c    Input, double precision A(N), an array to be index-sorted.
c
c    Output, integer INDX(N), the sort index.  The
c    I-th element of the sorted array is A(INDX(I)).
c
      implicit none

      integer n

      double precision a(n)
      double precision aval
      integer i
      integer indx(n)
      integer indxt
      integer ir
      integer j
      integer l

      if ( n .lt. 1 ) then
        return
      end if

      do i = 1, n
        indx(i) = i
      end do

      if ( n .eq. 1 ) then
        return
      end if

      l = n / 2 + 1
      ir = n

10    continue

        if ( 1 .lt. l ) then

          l = l - 1
          indxt = indx(l)
          aval = a(indxt)

        else

          indxt = indx(ir)
          aval = a(indxt)
          indx(ir) = indx(1)
          ir = ir - 1

          if ( ir .eq. 1 ) then
            indx(1) = indxt
            go to 30
          end if

        end if

        i = l
        j = l + l

20      continue

        if ( j .le. ir ) then

          if ( j .lt. ir ) then
            if ( a(indx(j+1)) .lt. a(indx(j)) ) then
              j = j + 1
            end if
          end if

          if ( a(indx(j)) .lt. aval ) then
            indx(i) = indx(j)
            i = j
            j = j + j
          else
            j = ir + 1
          end if

          go to 20

        end if

        indx(i) = indxt

      go to 10

30    continue

      return
      end
      subroutine r8vec_sort_heap_mask_a ( n, a, mask_num, mask, indx )

c*********************************************************************72
c
cc R8VEC_SORT_HEAP_MASK_A: indexed heap ascending sort of a masked R8VEC.
c
c  Discussion:
c
c    An R8VEC is a vector of R8's.
c
c    An array A is given.  An array MASK of indices into A is given.
c    The routine produces a vector INDX, which is a permutation of the
c    entries of MASK, so that:
c
c      A(MASK(INDX(I)) <= A(MASK(INDX(J))
c
c    whenever
c
c      I <= J
c
c    In other words, only the elements of A that are indexed by MASK
c    are to be considered, and the only thing that happens is that
c    a rearrangment of the indices in MASK is returned that orders the
c    masked elements.
c
c  Licensing:
c
c    This code is distributed under the GNU LGPL license.
c
c  Modified:
c
c    22 August 2010
c
c  Author:
c
c    John Burkardt
c
c  Parameters:
c
c    Input, integer N, the number of entries in the array.
c
c    Input, double precision A(N), an array to be index-sorted.
c
c    Input, integer MASK_NUM, the number of mask elements.
c
c    Input, integer MASK(MASK_NUM), the mask array.  This is
c    simply a list of indices of A.  The entries of MASK should
c    be unique, and each one should be between 1 and N.
c
c    Output, integer INDX(MASK_NUM), the sort index.  There are
c    MASK_NUM elements of A selected by MASK.  If we want to list those
c    elements in order, then the I-th element is A(MASK(INDX(I))).
c
      implicit none

      integer mask_num
      integer n

      double precision a(n)
      double precision aval
      integer i
      integer indx(mask_num)
      integer indxt
      integer ir
      integer j
      integer l
      integer mask(mask_num)

      if ( n .lt. 1 ) then
        return
      end if

      if ( mask_num .lt. 1 ) then
        return
      end if

      if ( mask_num .eq. 1 ) then
        indx(1) = 1
        return
      end if

      call i4vec_indicator ( mask_num, indx )

      l = mask_num / 2 + 1
      ir = mask_num

10    continue

        if ( 1 .lt. l ) then

          l = l - 1
          indxt = indx(l)
          aval = a(mask(indxt))

        else

          indxt = indx(ir)
          aval = a(mask(indxt))
          indx(ir) = indx(1)
          ir = ir - 1

          if ( ir .eq. 1 ) then
            indx(1) = indxt
            go to 30
          end if

        end if

        i = l
        j = l + l

20      continue

        if ( j .le. ir ) then

          if ( j .lt. ir ) then
            if ( a(mask(indx(j))) .lt. a(mask(indx(j+1))) ) then
              j = j + 1
            end if
          end if

          if ( aval .lt. a(mask(indx(j))) ) then
            indx(i) = indx(j)
            i = j
            j = j + j
          else
            j = ir + 1
          end if

          go to 20

        end if

        indx(i) = indxt

      go to 10

30    continue

      return
      end
      subroutine r8vec_sort_insert_a ( n, a )

c*********************************************************************72
c
cc R8VEC_SORT_INSERT_A ascending sorts an R8VEC using an insertion sort.
c
c  Discussion:
c
c    An R8VEC is a vector of R8's.
c
c  Licensing:
c
c    This code is distributed under the GNU LGPL license.
c
c  Modified:
c
c    21 August 2010
c
c  Author:
c
c    John Burkardt
c
c  Reference:
c
c    Donald Kreher, Douglas Simpson,
c    Algorithm 1.1,
c    Combinatorial Algorithms,
c    CRC Press, 1998, page 11.
c
c  Parameters:
c
c    Input, integer N, the number of items in the vector.
c    N must be positive.
c
c    Input/output, double precision A(N).
c    On input, the array to be sorted;
c    On output, the array has been sorted.
c
      implicit none

      integer n

      double precision a(n)
      integer i
      integer j
      double precision x

      do i = 2, n

        x = a(i)

        j = i - 1

10      continue

        if ( 1 .le. j ) then

          if ( a(j) .le. x ) then
            go to 20
          end if

          a(j+1) = a(j)
          j = j - 1

          go to 10

        end if

20      continue

        a(j+1) = x

      end do

      return
      end
      subroutine r8vec_sort_insert_index_a ( n, a, indx )

c*********************************************************************72
c
cc R8VEC_SORT_INSERT_INDEX_A ascending index sorts an R8VEC using insertion.
c
c  Discussion:
c
c    An R8VEC is a vector of R8's.
c
c  Licensing:
c
c    This code is distributed under the GNU LGPL license.
c
c  Modified:
c
c    22 August 2010
c
c  Author:
c
c    John Burkardt
c
c  Reference:
c
c    Donald Kreher, Douglas Simpson,
c    Algorithm 1.1,
c    Combinatorial Algorithms,
c    CRC Press, 1998, page 11.
c
c  Parameters:
c
c    Input, integer N, the number of items in the vector.
c    N must be positive.
c
c    Input, double precision A(N), the array to be sorted.
c
c    Output, integer INDX(N), the sorted indices.  The array
c    is sorted when listed from A(INDX(1)) through A(INDX(N)).
c
      implicit none

      integer n

      double precision a(n)
      integer i
      integer indx(n)
      integer j
      double precision x

      if ( n .lt. 1 ) then
        return
      end if

      do i = 1, n
        indx(i) = i
      end do

      do i = 2, n

        x = a(i)

        j = i - 1

10      continue

        if ( 1 .le. j ) then

          if ( a(indx(j)) .le. x ) then
            go to 20
          end if

          indx(j+1) = indx(j)
          j = j - 1

          go to 10

        end if

20      continue

        indx(j+1) = i

      end do

      return
      end
      subroutine r8vec_sort_insert_index_d ( n, a, indx )

c*********************************************************************72
c
cc R8VEC_SORT_INSERT_INDEX_D descending index sorts an R8VEC using insertion.
c
c  Discussion:
c
c    An R8VEC is a vector of R8's.
c
c  Licensing:
c
c    This code is distributed under the GNU LGPL license.
c
c  Modified:
c
c    20 August 2010
c
c  Author:
c
c    John Burkardt
c
c  Reference:
c
c    Donald Kreher, Douglas Simpson,
c    Algorithm 1.1,
c    Combinatorial Algorithms,
c    CRC Press, 1998, page 11.
c
c  Parameters:
c
c    Input, integer N, the number of items in the vector.
c    N must be positive.
c
c    Input, double precision A(N), the array to be sorted.
c
c    Output, integer INDX(N), the sorted indices.  The array
c    is sorted when listed from A(INDX(1)) through A(INDX(N)).
c
      implicit none

      integer n

      double precision a(n)
      integer i
      integer indx(n)
      integer j
      double precision x

      if ( n .lt. 1 ) then
        return
      end if

      do i = 1, n
        indx(i) = i
      end do

      do i = 2, n

        x = a(i)

        j = i - 1

10      continue

        if ( 1 .le. j ) then

          if ( x .le. a(indx(j)) ) then
            go to 20
          end if

          indx(j+1) = indx(j)
          j = j - 1

          go to 10

        end if

20      continue

        indx(j+1) = i

      end do

      return
      end
      subroutine r8vec_sort_quick_a ( n, a )

c*********************************************************************72
c
cc R8VEC_SORT_QUICK_A ascending sorts an R8VEC using quick sort.
c
c  Discussion:
c
c    An R8VEC is a vector of R8's.
c
c  Example:
c
c    Input:
c
c      N = 7
c      A = ( 6, 7, 3, 2, 9, 1, 8 )
c
c    Output:
c
c      A = ( 1, 2, 3, 6, 7, 8, 9 )
c
c  Modified:
c
c    25 July 2008
c
c  Author:
c
c    John Burkardt
c
c  Parameters:
c
c    Input, integer N, the number of entries in the array.
c
c    Input/output, double precision A(N).
c    On input, the array to be sorted.
c    On output, the array has been sorted.
c
      implicit none

      integer level_max
      parameter ( level_max = 25 )
      integer n

      double precision a(n)
      integer base
      integer l_segment
      integer level
      integer n_segment
      integer rsave(level_max)
      integer r_segment

      if ( n .lt. 1 ) then
        write ( *, '(a)' ) ' '
        write ( *, '(a)' ) 'R8VEC_SORT_QUICK_A - Fatal error!'
        write ( *, '(a)' ) '  N < 1.'
        stop
      else if ( n .eq. 1 ) then
        return
      end if

      level = 1
      rsave(level) = n + 1
      base = 1
      n_segment = n

10    continue
c
c  Partition the segment.
c
        call r8vec_part_quick_a ( n_segment, a(base), l_segment,
     &    r_segment )
c
c  If the left segment has more than one element, we need to partition it.
c
        if ( 1 .lt. l_segment ) then

          if ( level_max .lt. level ) then
            write ( *, '(a)' ) ' '
            write ( *, '(a)' ) 'R8VEC_SORT_QUICK_A - Fatal error!'
            write ( *, '(a,i6)' )
     &        '  Exceeding recursion maximum of ', level_max
            stop
          end if

          level = level + 1
          n_segment = l_segment
          rsave(level) = r_segment + base - 1
c
c  The left segment and the middle segment are sorted.
c  Must the right segment be partitioned?
c
        else if ( r_segment .lt. n_segment ) then

          n_segment = n_segment + 1 - r_segment
          base = base + r_segment - 1
c
c  Otherwise, we back up a level if there is an earlier one.
c
        else

20        continue

            if ( level .le. 1 ) then
              go to 40
            end if

            base = rsave(level)
            n_segment = rsave(level-1) - rsave(level)
            level = level - 1

            if ( 0 .lt. n_segment ) then
              go to 30
            end if

          go to 20

30        continue

        end if

      go to 10

40    continue

      return
      end
      subroutine r8vec_sorted_merge_a ( na, a, nb, b, nc, c )

c*********************************************************************72
c
cc R8VEC_SORTED_MERGE_A merges two ascending sorted R8VEC's.
c
c  Discussion:
c
c    An R8VEC is a vector of R8's.
c
c    The elements of A and B should be sorted in ascending order.
c
c    The elements in the output array C will also be in ascending order,
c    and unique.
c
c    The output vector C may share storage with A or B.
c
c  Licensing:
c
c    This code is distributed under the GNU LGPL license.
c
c  Modified:
c
c    25 September 2010
c
c  Author:
c
c    John Burkardt
c
c  Parameters:
c
c    Input, integer NA, the dimension of A.
c
c    Input, double precision A(NA), the first sorted array.
c
c    Input, integer NB, the dimension of B.
c
c    Input, double precision B(NB), the second sorted array.
c
c    Output, integer NC, the number of elements in the output
c    array.  Note that C should usually be dimensioned at least NA+NB in the
c    calling routine.
c
c    Output, double precision C(NC), the merged unique sorted array.
c
      implicit none

      integer na
      integer nb

      double precision a(na)
      double precision b(nb)
      double precision c(na+nb)
      double precision d(na+nb)
      integer i
      integer j
      integer ja
      integer jb
      integer na2
      integer nb2
      integer nc
      integer order

      na2 = na
      nb2 = nb

      ja = 0
      jb = 0
      nc = 0

      call r8vec_order_type ( na2, a, order )

      if ( order .lt. 0 .or. 2 .lt. order ) then
        write ( *, '(a)' ) ' '
        write ( *, '(a)' ) 'R8VEC_SORTED_MERGE_A - Fatal error!'
        write ( *, '(a)' )
     &    '  The input array A is not ascending sorted!'
        stop
      end if

      call r8vec_order_type ( nb2, b, order )

      if ( order .lt. 0 .or. 2 .lt. order ) then
        write ( *, '(a)' ) ' '
        write ( *, '(a)' ) 'R8VEC_SORTED_MERGE_A - Fatal error!'
        write ( *, '(a)' )
     &    '  The input array B is not ascending sorted!'
        stop
      end if

10    continue
c
c  If we've used up all the entries of A, stick the rest of B on the end.
c
        if ( na2 .le. ja ) then

          do j = 1, nb2 - jb
            jb = jb + 1
            if ( nc .eq. 0 ) then
              nc = nc + 1
              d(nc) = b(jb)
            else if ( d(nc) .lt. b(jb) ) then
              nc = nc + 1
              d(nc) = b(jb)
            end if
          end do

          do i = 1, nc
            c(i) = d(i)
          end do

          go to 20
c
c  If we've used up all the entries of B, stick the rest of A on the end.
c
        else if ( nb2 .le. jb ) then

          do j = 1, na2 - ja
            ja = ja + 1
            if ( nc .eq. 0 ) then
              nc = nc + 1
              d(nc) = a(ja)
            else if ( d(nc) .lt. a(ja) ) then
              nc = nc + 1
              d(nc) = a(ja)
            end if
          end do

          do i = 1, nc
            c(i) = d(i)
          end do

          go to 20
c
c  Otherwise, if the next entry of A is smaller, that's our candidate.
c
        else if ( a(ja+1) .le. b(jb+1) ) then

          ja = ja + 1
          if ( nc .eq. 0 ) then
            nc = nc + 1
            d(nc) = a(ja)
          else if ( d(nc) .lt. a(ja) ) then
            nc = nc + 1
            d(nc) = a(ja)
          end if
c
c  ...or if the next entry of B is the smaller, consider that.
c
        else

          jb = jb + 1
          if ( nc .eq. 0 ) then
            nc = nc + 1
            d(nc) = b(jb)
          else if ( d(nc) .lt. b(jb) ) then
            nc = nc + 1
            d(nc) = b(jb)
          end if
        end if

      go to 10

20    continue

      return
      end
      function r8vec_sorted_nearest ( n, a, value )

c*********************************************************************72
c
cc R8VEC_SORTED_NEAREST returns the nearest element in a sorted R8VEC.
c
c  Discussion:
c
c    An R8VEC is a vector of R8's.
c
c  Licensing:
c
c    This code is distributed under the GNU LGPL license.
c
c  Modified:
c
c    25 September 2010
c
c  Author:
c
c    John Burkardt
c
c  Parameters:
c
c    Input, integer N, the number of elements of A.
c
c    Input, double precision A(N), a sorted vector.
c
c    Input, double precision VALUE, the value whose nearest vector
c    entry is sought.
c
c    Output, integer R8VEC_SORTED_NEAREST, the index of the nearest
c    entry in the vector.
c
      implicit none

      integer n

      double precision a(n)
      integer r8vec_sorted_nearest
      integer hi
      integer lo
      integer mid
      double precision value

      if ( n .lt. 1 ) then
        r8vec_sorted_nearest = -1
        return
      end if

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

      if ( a(1) .lt. a(n) ) then

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

10      continue

        if ( lo .lt. hi - 1 ) then

          mid = ( lo + hi ) / 2

          if ( value .eq. a(mid) ) then
            r8vec_sorted_nearest = mid
            return
          else if ( value .lt. a(mid) ) then
            hi = mid
          else
            lo = mid
          end if

          go to 10

        end if
c
c  Take the nearest.
c
        if ( abs ( value - a(lo) ) .lt. abs ( value - a(hi) ) ) then
          r8vec_sorted_nearest = lo
        else
          r8vec_sorted_nearest = hi
        end if

        return
c
c  A descending sorted vector A.
c
      else

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

20      continue

        if ( lo .lt. hi - 1 ) then

          mid = ( lo + hi ) / 2

          if ( value .eq. a(mid) ) then
            r8vec_sorted_nearest = mid
            return
          else if ( value .lt. a(mid) ) then
            hi = mid
          else
            lo = mid
          end if

          go to 20

        end if
c
c  Take the nearest.
c
        if ( abs ( value - a(lo) ) .lt. abs ( value - a(hi) ) ) then
          r8vec_sorted_nearest = lo
        else
          r8vec_sorted_nearest = hi
        end if

        return

      end if

      return
      end
      subroutine r8vec_sorted_range ( n, r, r_lo, r_hi, i_lo, i_hi )

c*********************************************************************72
c
cc R8VEC_SORTED_RANGE searches a sorted vector for elements in a range.
c
c  Licensing:
c
c    This code is distributed under the GNU LGPL license.
c
c  Modified:
c
c    25 September 2010
c
c  Author:
c
c    John Burkardt
c
c  Parameters:
c
c    Input, integer N, the number of items in the vector.
c
c    Input, double precision R(N), the sorted vector.
c
c    Input, double precision R_LO, R_HI, the limits of the range.
c
c    Output, integer I_LO, I_HI, the range of indices
c    so that I_LO .le. I .le. I_HI => R_LO .le. R(I) .le. R_HI.  If no
c    values in R lie in the range, then I_HI .lt. I_LO will be returned.
c
      implicit none

      integer n

      integer i_hi
      integer i_lo
      integer i1
      integer i2
      integer j1
      integer j2
      double precision r(n)
      double precision r_hi
      double precision r_lo
c
c  Cases we can handle immediately.
c
      if ( r(n) .lt. r_lo ) then
        i_lo = 0
        i_hi = - 1
        return
      end if

      if ( r_hi .lt. r(1) ) then
        i_lo = 0
        i_hi = - 1
        return
      end if
c
c  Are there are least two intervals?
c
      if ( n .eq. 1 ) then
        if ( r_lo .le. r(1) .and. r(1) .le. r_hi ) then
          i_lo = 1
          i_hi = 1
        else
          i_lo = 0
          i_hi = -1
        end if
        return
      end if
c
c  Bracket R_LO.
c
      if ( r_lo .le. r(1) ) then

        i_lo = 1

      else
c
c  R_LO is in one of the intervals spanned by R(J1) to R(J2).
c  Examine the intermediate interval [R(I1), R(I1+1)].
c  Does R_LO lie here, or below or above?
c
        j1 = 1
        j2 = n
        i1 = ( j1 + j2 - 1 ) / 2
        i2 = i1 + 1

10      continue

          if ( r_lo .lt. r(i1) ) then
            j2 = i1
            i1 = ( j1 + j2 - 1 ) / 2
            i2 = i1 + 1
          else if ( r(i2) .lt. r_lo ) then
            j1 = i2
            i1 = ( j1 + j2 - 1 ) / 2
            i2 = i1 + 1
          else
            i_lo = i1
            go to 20
          end if

        go to 10

20      continue

      end if
c
c  Bracket R_HI
c
      if ( r(n) .le. r_hi ) then

        i_hi = n

      else

        j1 = i_lo
        j2 = n
        i1 = ( j1 + j2 - 1 ) / 2
        i2 = i1 + 1

30      continue

          if ( r_hi .lt. r(i1) ) then
            j2 = i1
            i1 = ( j1 + j2 - 1 ) / 2
            i2 = i1 + 1
          else if ( r(i2) .lt. r_hi ) then
            j1 = i2
            i1 = ( j1 + j2 - 1 ) / 2
            i2 = i1 + 1
          else
            i_hi = i2
            go to 40
          end if

        go to 30

40      continue

      end if
c
c  We expect to have computed the largest I_LO and smallest I_HI such that
c    R(I_LO) .le. R_LO .le. R_HI .le. R(I_HI)
c  but what we want is actually
c    R_LO .le. R(I_LO) .le. R(I_HI) .le. R_HI
c  which we can usually get simply by incrementing I_LO and decrementing I_HI.
c
      if ( r(i_lo) .lt. r_lo ) then
        i_lo = i_lo + 1
        if ( n .lt. i_lo ) then
          i_hi = i_lo - 1
        end if
      end if

      if ( r_hi .lt. r(i_hi) ) then
        i_hi = i_hi - 1
        if ( i_hi .lt. 1 ) then
          i_lo = i_hi + 1
        end if
      end if

      return
      end
      subroutine r8vec_sorted_split ( n, a, split, i_lt, i_gt )

c*********************************************************************72
c
cc R8VEC_SORTED_SPLIT "splits" a sorted R8VEC, given a splitting value.
c
c  Discussion:
c
c    An R8VEC is a vector of R8's.
c
c    Given a splitting value SPLIT, the routine seeks indices
c    I_LT and I_GT so that
c
c      A(I_LT) .lt. SPLIT .lt. A(I_GT),
c
c    and if there are intermediate index values between I_LT and
c    I_GT, then those entries of A are exactly equal to SPLIT.
c
c  Licensing:
c
c    This code is distributed under the GNU LGPL license.
c
c  Modified:
c
c    25 September 2010
c
c  Author:
c
c    John Burkardt
c
c  Parameters
c
c    Input, integer N, the number of entries in A.
c
c    Input, double precision A(N), a sorted array.
c
c    Input, double precision SPLIT, a value to which the entries in A are
c    to be compared.
c
c    Output, integer I_LT:
c    0 if no entries are less than SPLIT;
c    N if all entries are less than SPLIT;
c    otherwise, the index of the last entry in A less than SPLIT.
c
c    Output, integer I_GT:
c    1 if all entries are greater than SPLIT;
c    N+1 if no entries are greater than SPLIT;
c    otherwise the index of the first entry in A greater than SPLIT.
c
      implicit none

      integer n

      double precision a(n)
      integer hi
      integer i
      integer i_gt
      integer i_lt
      integer lo
      integer mid
      double precision split

      if ( n .lt. 1 ) then
        i_lt = -1
        i_gt = -1
        return
      end if

      if ( split .lt. a(1) ) then
        i_lt = 0
        i_gt = 1
        return
      end if

      if ( a(n) .lt. split ) then
        i_lt = n
        i_gt = n + 1
        return
      end if

      lo = 1
      hi = n

10    continue

        if ( lo + 1 .eq. hi ) then
          i_lt = lo
          go to 20
        end if

        mid = ( lo + hi ) / 2

        if ( split .le. a(mid) ) then
          hi = mid
        else
          lo = mid
        end if

      go to 10

20    continue

      do i = i_lt + 1, n
        if ( split .lt. a(i) ) then
          i_gt = i
          return
        end if
      end do

      i_gt = n + 1

      return
      end
      subroutine r8vec_sorted_undex ( x_num, x_val, x_unique_num, tol,
     &  undx, xdnu )

c*********************************************************************72
c
cc R8VEC_SORTED_UNDEX returns unique sorted indexes for a sorted R8VEC.
c
c  Discussion:
c
c    An R8VEC is a vector of R8's.
c
c    The goal of this routine is to determine a vector UNDX,
c    which points, to the unique elements of X, in sorted order,
c    and a vector XDNU, which identifies, for each entry of X, the index of
c    the unique sorted element of X.
c
c    This is all done with index vectors, so that the elements of
c    X are never moved.
c
c    Assuming X is already sorted, we examine the entries of X in order,
c    noting the unique entries, creating the entries of XDNU and
c    UNDX as we go.
c
c    Once this process has been completed, the vector X could be
c    replaced by a compressed vector XU, containing the unique entries
c    of X in sorted order, using the formula
c
c      XU(I) = X(UNDX(I)).
c
c    We could then, if we wished, reconstruct the entire vector X, or
c    any element of it, by index, as follows:
c
c      X(I) = XU(XDNU(I)).
c
c    We could then replace X by the combination of XU and XDNU.
c
c    Later, when we need the I-th entry of X, we can locate it as
c    the XDNU(I)-th entry of XU.
c
c    Here is an example of a vector X, the sort and inverse sort
c    index vectors, and the unique sort and inverse unique sort vectors
c    and the compressed unique sorted vector.
c
c    Here is an example of a vector X, the unique sort and
c    inverse unique sort vectors and the compressed unique sorted vector.
c
c      I      X      XU  Undx  Xdnu
c    ----+------+------+-----+-----+
c      1 | 11.0 |  11.0    1     1
c      2 | 11.0 |  22.0    5     1
c      3 | 11.0 |  33.0    8     1
c      4 | 11.0 |  55.0    9     1
c      5 | 22.0 |                2
c      6 | 22.0 |                2
c      7 | 22.0 |                2
c      8 | 33.0 |                3
c      9 | 55.0 |
c
c    INDX(2) = 3 means that sorted item(2) is X(3).
c    XDNI(2) = 5 means that X(2) is sorted item(5).
c
c    UNDX(3) = 4 means that unique sorted item(3) is at X(4).
c    XDNU(8) = 2 means that X(8) is at unique sorted item(2).
c
c    XU(XDNU(I))) = X(I).
c    XU(I)        = X(UNDX(I)).
c
c  Licensing:
c
c    This code is distributed under the GNU LGPL license.
c
c  Modified:
c
c    07 July 2009
c
c  Author:
c
c    John Burkardt
c
c  Parameters:
c
c    Input, integer X_NUM, the number of data values.
c
c    Input, double precision X_VAL(X_NUM), the data values.
c
c    Input, integer X_UNIQUE_NUM, the number of unique values
c    in X_VAL.  This value is only required for languages in which the size of
c    UNDX must be known in advance.
c
c    Input, double precision TOL, a tolerance for equality.
c
c    Output, integer UNDX(X_UNIQUE_NUM), the UNDX vector.
c
c    Output, integer XDNU(X_NUM), the XDNU vector.
c
      implicit none

      integer x_num
      integer x_unique_num

      integer i
      integer j
      double precision tol
      integer undx(x_unique_num)
      double precision x_val(x_num)
      integer xdnu(x_num)
c
c  Walk through the sorted array X.
c
      i = 1

      j = 1
      undx(j) = i

      xdnu(i) = j

      do i = 2, x_num

        if ( tol .lt. abs ( x_val(i) - x_val(undx(j)) ) ) then
          j = j + 1
          undx(j) = i
        end if

        xdnu(i) = j

      end do

      return
      end
      subroutine r8vec_sorted_unique ( n, a, tol, unique_num )

c*********************************************************************72
c
cc R8VEC_SORTED_UNIQUE keeps the unique elements in a sorted R8VEC.
c
c  Discussion:
c
c    An R8VEC is a vector of R8's.
c
c  Licensing:
c
c    This code is distributed under the GNU LGPL license.
c
c  Modified:
c
c    04 July 2009
c
c  Author:
c
c    John Burkardt
c
c  Parameters:
c
c    Input, integer N, the number of elements of A.
c
c    Input/output, double precision A(N).
c    On input, the sorted array of N elements;
c    On output, the sorted unique array of UNIQUE_NUM elements.
c
c    Input, double precision TOL, a nonnegative tolerance for equality.
c    Set it to 0.0 for the strictest test.
c
c    Output, integer UNIQUE_NUM, the number of unique elements
c    of A.
c
      implicit none

      integer n

      double precision a(n)
      integer i
      integer unique_num
      double precision tol

      if ( n .le. 0 ) then
        unique_num = 0
        return
      end if

      unique_num = 1

      do i = 2, n

        if ( tol .lt. abs ( a(i) - a(unique_num) ) ) then
          unique_num = unique_num + 1
          a(unique_num) = a(i)
        end if

      end do

      return
      end
      subroutine r8vec_sorted_unique_count ( n, a, tol, unique_num )

c*********************************************************************72
c
cc R8VEC_SORTED_UNIQUE_COUNT counts the unique elements in a sorted R8VEC.
c
c  Discussion:
c
c    An R8VEC is a vector of R8's.
c
c    Because the array is sorted, this algorithm is O(N).
c
c  Licensing:
c
c    This code is distributed under the GNU LGPL license.
c
c  Modified:
c
c    04 July 2009
c
c  Author:
c
c    John Burkardt
c
c  Parameters:
c
c    Input, integer N, the number of elements of A.
c
c    Input, double precision A(N), the sorted array to examine.
c
c    Input, double precision TOL, a nonnegative tolerance for equality.
c    Set it to 0.0 for the strictest test.
c
c    Output, integer UNIQUE_NUM, the number of unique elements
c    of A.
c
      implicit none

      integer n

      double precision a(n)
      integer i
      integer unique_num
      double precision tol

      if ( n .lt. 1 ) then
        unique_num = 0
        return
      end if

      unique_num = 1

      do i = 2, n

        if ( tol .lt. abs ( a(i-1) - a(i) ) ) then
          unique_num = unique_num + 1
        end if

      end do

      return
      end
      subroutine r8vec_sorted_unique_hist ( n, a, tol, maxuniq,
     &  unique_num, auniq, acount )

c*********************************************************************72
c
cc R8VEC_SORTED_UNIQUE_HIST histograms the unique elements of a sorted R8VEC.
c
c  Discussion:
c
c    An R8VEC is a vector of R8's.
c
c  Licensing:
c
c    This code is distributed under the GNU LGPL license.
c
c  Modified:
c
c    21 August 2010
c
c  Author:
c
c    John Burkardt
c
c  Parameters:
c
c    Input, integer N, the number of elements of A.
c
c    Input, double precision A(N), the array to examine.  The elements of A
c    should have been sorted.
c
c    Input, double precision TOL, a nonnegative tolerance for equality.
c    Set it to 0.0 for the strictest test.
c
c    Input, integer MAXUNIQ, the maximum number of unique elements
c    that can be handled.  If there are more than MAXUNIQ unique
c    elements in A, the excess will be ignored.
c
c    Output, integer UNIQUE_NUM, the number of unique elements
c    of A.
c
c    Output, double precision AUNIQ(UNIQUE_NUM), the unique elements of A.
c
c    Output, integer ACOUNT(UNIQUE_NUM), the number of times
c    each element of AUNIQ occurs in A.
c
      implicit none

      integer maxuniq
      integer n

      double precision a(n)
      integer acount(maxuniq)
      double precision auniq(maxuniq)
      integer i
      integer unique_num
      double precision tol
c
c  Start taking statistics.
c
      unique_num = 0

      do i = 1, n

        if ( i .eq. 1 ) then

          unique_num = 1
          auniq(unique_num) = a(1)
          acount(unique_num) = 1

        else if ( abs ( a(i) - auniq(unique_num) ) .le. tol ) then

          acount(unique_num) = acount(unique_num) + 1

        else if ( unique_num .lt. maxuniq ) then

          unique_num = unique_num + 1
          auniq(unique_num) = a(i)
          acount(unique_num) = 1

        end if

      end do

      return
      end
      subroutine r8vec_split ( n, a, split, isplit )

c*********************************************************************72
c
cc R8VEC_SPLIT "splits" an unsorted R8VEC based on a splitting value.
c
c  Discussion:
c
c    An R8VEC is a vector of R8's.
c
c    If the vector is already sorted, it is simpler to do a binary search
c    on the data than to call this routine.
c
c    The vector is not assumed to be sorted before input, and is not
c    sorted during processing.  If sorting is not needed, then it is
c    more efficient to use this routine.
c
c  Licensing:
c
c    This code is distributed under the GNU LGPL license.
c
c  Modified:
c
c    01 June 2009
c
c  Author:
c
c    John Burkardt
c
c  Parameters:
c
c    Input, integer N, the number of elements of A.
c
c    Input/output, double precision A(N), the array to split.  On output,
c    all the entries of A that are less than or equal to SPLIT
c    are in A(1:ISPLIT).
c
c    Input, double precision SPLIT, the value used to split the vector.
c    It is not necessary that any value of A actually equal SPLIT.
c
c    Output, integer ISPLIT, indicates the position of the last
c    entry of the split vector that is less than or equal to SPLIT.
c
      implicit none

      integer n

      double precision a(n)
      integer i
      integer i1
      integer i2
      integer i3
      integer isplit
      integer j1
      integer j2
      integer j3
      double precision split
c
c  Partition the vector into A1, A2, A3, where
c    A1 = A(I1:J1) holds values <= SPLIT,
c    A2 = A(I2:J2) holds untested values,
c    A3 = A(I3:J3) holds values > SPLIT.
c
      i1 = 1
      j1 = 0

      i2 = 1
      j2 = n

      i3 = n + 1
      j3 = n
c
c  Pick the next item from A2, and move it into A1 or A3.
c  Adjust indices appropriately.
c
      do i = 1, n

        if ( a(i2) .le. split ) then
          i2 = i2 + 1
          j1 = j1 + 1
        else
          call r8_swap ( a(i2), a(i3-1) )
          i3 = i3 - 1
          j2 = j2 - 1
        end if

      end do

      isplit = j1

      return
      end
      subroutine r8vec_std ( n, a, std )

c*********************************************************************72
c
cc R8VEC_STD returns the standard deviation of an R8VEC.
c
c  Discussion:
c
c    An R8VEC is a vector of R8's.
c
c    The standard deviation of a vector X of length N is defined as
c
c      mean ( X(1:n) ) = sum ( X(1:n) ) / n
c
c      std ( X(1:n) ) = sqrt ( sum ( ( X(1:n) - mean )^2 ) / ( n - 1 ) )
c
c  Licensing:
c
c    This code is distributed under the GNU LGPL license.
c
c  Modified:
c
c    01 June 2009
c
c  Author:
c
c    John Burkardt
c
c  Parameters:
c
c    Input, integer N, the number of entries in the vector.
c    N should be at least 2.
c
c    Input, double precision A(N), the vector.
c
c    Output, double precision STD, the standard deviation of the vector.
c
      implicit none

      integer n

      double precision a(n)
      integer i
      double precision mean
      double precision std

      if ( n .lt. 2 ) then

        std = 0.0D+00

      else

        mean = 0.0D+00
        do i = 1, n
          mean = mean + a(i)
        end do
        mean = mean / dble ( n )

        std = 0.0D+00
        do i = 1, n
          std = std + ( a(i) - mean )**2
        end do
        std = sqrt ( std / dble ( n - 1 ) )

      end if

      return
      end
      subroutine r8vec_stutter ( n, a, m, am )

c*********************************************************************72
c
cc R8VEC_STUTTER makes a "stuttering" copy of an R8VEC.
c
c  Discussion:
c
c    An R8VEC is a vector of R8's.
c
c    Applying a stuttering factor M of 3, the vector A = ( 1, 5, 8 ) becomes
c    AM = ( 1, 1, 1, 5, 5, 5, 8, 8, 8 ).
c
c  Licensing:
c
c    This code is distributed under the GNU LGPL license.
c
c  Modified:
c
c    23 March 2011
c
c  Author:
c
c    John Burkardt
c
c  Parameters:
c
c    Input, integer N, the size of the input vector.
c
c    Input, double precision A(N), the vector.
c
c    Input, integer M, the "stuttering factor".
c
c    Output, double precision AM(M*N), the stuttering vector.
c
      implicit none

      integer m
      integer n

      double precision a(n)
      double precision am(m*n)
      integer i
      integer j
      integer jhi
      integer jlo

      do i = 1, n
        jlo = m * ( i - 1 ) + 1
        jhi = m *   i
        do j = jlo, jhi
          am(j) = a(i)
        end do
      end do

      return
      end
      function r8vec_sum ( n, v1 )

c*********************************************************************72
c
cc R8VEC_SUM sums the entries of an R8VEC.
c
c  Discussion:
c
c    An R8VEC is a vector of R8's.
c
c    In FORTRAN90, the system routine SUM should be called
c    directly.
c
c  Licensing:
c
c    This code is distributed under the GNU LGPL license.
c
c  Modified:
c
c    22 July 2008
c
c  Author:
c
c    John Burkardt
c
c  Parameters:
c
c    Input, integer N, the dimension of the vectors.
c
c    Input, double precision V1(N), the vector.
c
c    Output, double precision R8VEC_SUM, the sum of the entries.
c
      implicit none

      integer n

      integer i
      double precision r8vec_sum
      double precision v1(n)
      double precision value

      value = 0.0D+00
      do i = 1, n
        value = value + v1(i)
      end do

      r8vec_sum = value

      return
      end
      subroutine r8vec_swap ( n, a1, a2 )

c*********************************************************************72
c
cc R8VEC_SWAP swaps two R8VEC's.
c
c  Discussion:
c
c    An R8VEC is a vector of R8's.
c
c  Licensing:
c
c    This code is distributed under the GNU LGPL license.
c
c  Modified:
c
c    22 July 2008
c
c  Author:
c
c    John Burkardt
c
c  Parameters:
c
c    Input, integer N, the number of entries in the arrays.
c
c    Input/output, double precision A1(N), A2(N), the vectors to swap.
c
      implicit none

      integer n

      double precision a1(n)
      double precision a2(n)
      integer i
      double precision t

      do i = 1, n
        t     = a1(i)
        a1(i) = a2(i)
        a2(i) = t
      end do

      return
      end
      subroutine r8vec_transpose_print ( n, a, title )

c*********************************************************************72
c
cc R8VEC_TRANSPOSE_PRINT prints an R8VEC "transposed".
c
c  Discussion:
c
c    An R8VEC is a vector of R8's.
c
c  Example:
c
c    A = (/ 1.0, 2.1, 3.2, 4.3, 5.4, 6.5, 7.6, 8.7, 9.8, 10.9, 11.0 /)
c    TITLE = 'My vector:  '
c
c    My vector:
c
c        1.0    2.1    3.2    4.3    5.4
c        6.5    7.6    8.7    9.8   10.9
c       11.0
c
c  Licensing:
c
c    This code is distributed under the GNU LGPL license.
c
c  Modified:
c
c    12 November 2010
c
c  Author:
c
c    John Burkardt
c
c  Parameters:
c
c    Input, integer N, the number of components of the vector.
c
c    Input, double precision A(N), the vector to be printed.
c
c    Input, character * ( * ) TITLE, a title.
c
      implicit none

      integer n

      double precision a(n)
      integer ihi
      integer ilo
      character * ( * )  title

      write ( *, '(a)' ) ' '
      write ( *, '(a)' ) trim ( title )
      write ( *, '(a)' ) ' '
      do ilo = 1, n, 5
        ihi = min ( ilo + 5 - 1, n )
        write ( *, '(5g14.6)' ) a(ilo:ihi)
      end do

      return
      end
      subroutine r8vec_undex ( x_num, x_val, x_unique_num, tol, undx,
     &  xdnu )

c*********************************************************************72
c
cc R8VEC_UNDEX returns unique sorted indexes for an R8VEC.
c
c  Discussion:
c
c    An R8VEC is a vector of R8's.
c
c    The goal of this routine is to determine a vector UNDX,
c    which points, to the unique elements of X, in sorted order,
c    and a vector XDNU, which identifies, for each entry of X, the index of
c    the unique sorted element of X.
c
c    This is all done with index vectors, so that the elements of
c    X are never moved.
c
c    The first step of the algorithm requires the indexed sorting
c    of X, which creates arrays INDX and XDNI.  (If all the entries
c    of X are unique, then these arrays are the same as UNDX and XDNU.)
c
c    We then use INDX to examine the entries of X in sorted order,
c    noting the unique entries, creating the entries of XDNU and
c    UNDX as we go.
c
c    Once this process has been completed, the vector X could be
c    replaced by a compressed vector XU, containing the unique entries
c    of X in sorted order, using the formula
c
c      XU(1:X_UNIQUE_NUM) = X(UNDX(1:X_UNIQUE_NUM)).
c
c    We could then, if we wished, reconstruct the entire vector X, or
c    any element of it, by index, as follows:
c
c      X(I) = XU(XDNU(I)).
c
c    We could then replace X by the combination of XU and XDNU.
c
c    Later, when we need the I-th entry of X, we can locate it as
c    the XDNU(I)-th entry of XU.
c
c    Here is an example of a vector X, the sort and inverse sort
c    index vectors, and the unique sort and inverse unique sort vectors
c    and the compressed unique sorted vector.
c
c      I    X   Indx  Xdni      XU   Undx  Xdnu
c    ----+-----+-----+-----+--------+-----+-----+
c      1 | 11.     1     1 |    11,     1     1
c      2 | 22.     3     5 |    22,     2     2
c      3 | 11.     6     2 |    33,     4     1
c      4 | 33.     9     8 |    55,     5     3
c      5 | 55.     2     9 |                  4
c      6 | 11.     7     3 |                  1
c      7 | 22.     8     6 |                  2
c      8 | 22.     4     7 |                  2
c      9 | 11.     5     4 |                  1
c
c    INDX(2) = 3 means that sorted item(2) is X(3).
c    XDNI(2) = 5 means that X(2) is sorted item(5).
c
c    UNDX(3) = 4 means that unique sorted item(3) is at X(4).
c    XDNU(8) = 2 means that X(8) is at unique sorted item(2).
c
c    XU(XDNU(I))) = X(I).
c    XU(I)        = X(UNDX(I)).
c
c  Licensing:
c
c    This code is distributed under the GNU LGPL license.
c
c  Modified:
c
c    04 July 2009
c
c  Author:
c
c    John Burkardt
c
c  Parameters:
c
c    Input, integer X_NUM, the number of data values.
c
c    Input, double precision X_VAL(X_NUM), the data values.
c
c    Input, integer X_UNIQUE_NUM, the number of unique values
c    in X_VAL.  This value is only required for languages in which the size of
c    UNDX must be known in advance.
c
c    Input, double precision TOL, a tolerance for equality.
c
c    Output, integer UNDX(X_UNIQUE_NUM), the UNDX vector.
c
c    Output, integer XDNU(X_NUM), the XDNU vector.
c
      implicit none

      integer x_num
      integer x_unique_num

      integer i
      integer indx(x_num)
      integer j
      double precision tol
      integer undx(x_unique_num)
      double precision x_val(x_num)
      integer xdnu(x_num)
c
c  Implicitly sort the array.
c
      call r8vec_sort_heap_index_a ( x_num, x_val, indx )
c
c  Walk through the implicitly sorted array X.
c
      i = 1

      j = 1
      undx(j) = indx(i)

      xdnu(indx(i)) = j

      do i = 2, x_num

        if ( tol .lt. abs ( x_val(indx(i)) - x_val(undx(j)) ) ) then
          j = j + 1
          undx(j) = indx(i)
        end if

        xdnu(indx(i)) = j

      end do

      return
      end
      subroutine r8vec_uniform_01 ( n, seed, r )

c*********************************************************************72
c
cc R8VEC_UNIFORM_01 returns a unit pseudorandom R8VEC.
c
c  Discussion:
c
c    An R8VEC is a vector of R8's.
c
c  Licensing:
c
c    This code is distributed under the GNU LGPL license.
c
c  Modified:
c
c    17 July 2006
c
c  Author:
c
c    John Burkardt
c
c  Reference:
c
c    Paul Bratley, Bennett Fox, Linus Schrage,
c    A Guide to Simulation,
c    Springer Verlag, pages 201-202, 1983.
c
c    Bennett Fox,
c    Algorithm 647:
c    Implementation and Relative Efficiency of Quasirandom
c    Sequence Generators,
c    ACM Transactions on Mathematical Software,
c    Volume 12, Number 4, pages 362-376, 1986.
c
c    Peter Lewis, Allen Goodman, James Miller,
c    A Pseudo-Random Number Generator for the System/360,
c    IBM Systems Journal,
c    Volume 8, pages 136-143, 1969.
c
c  Parameters:
c
c    Input, integer N, the number of entries in the vector.
c
c    Input/output, integer SEED, the "seed" value, which should NOT be 0.
c    On output, SEED has been updated.
c
c    Output, double precision R(N), the vector of pseudorandom values.
c
      implicit none

      integer n

      integer i
      integer k
      integer seed
      double precision r(n)

      do i = 1, n

        k = seed / 127773

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

        if ( seed .lt. 0 ) then
          seed = seed + 2147483647
        end if

        r(i) = dble ( seed ) * 4.656612875D-10

      end do

      return
      end
      subroutine r8vec_uniform_ab ( n, a, b, seed, r )

c*********************************************************************72
c
cc R8VEC_UNIFORM_AB returns a scaled pseudorandom R8VEC.
c
c  Discussion:
c
c    Each dimension ranges from A to B.
c
c  Licensing:
c
c    This code is distributed under the GNU LGPL license. 
c
c  Modified:
c
c    29 January 2005
c
c  Author:
c
c    John Burkardt
c
c  Reference:
c
c    Paul Bratley, Bennett Fox, Linus Schrage,
c    A Guide to Simulation,
c    Second Edition,
c    Springer, 1987,
c    ISBN: 0387964673,
c    LC: QA76.9.C65.B73.
c
c    Bennett Fox,
c    Algorithm 647:
c    Implementation and Relative Efficiency of Quasirandom
c    Sequence Generators,
c    ACM Transactions on Mathematical Software,
c    Volume 12, Number 4, December 1986, pages 362-376.
c
c    Pierre L'Ecuyer,
c    Random Number Generation,
c    in Handbook of Simulation,
c    edited by Jerry Banks,
c    Wiley, 1998,
c    ISBN: 0471134031,
c    LC: T57.62.H37.
c
c    Peter Lewis, Allen Goodman, James Miller,
c    A Pseudo-Random Number Generator for the System/360,
c    IBM Systems Journal,
c    Volume 8, Number 2, 1969, pages 136-143.
c
c  Parameters:
c
c    Input, integer N, the number of entries in the vector.
c
c    Input, double precision A, B, the lower and upper limits.
c
c    Input/output, integer SEED, the "seed" value, which should NOT be 0.
c    On output, SEED has been updated.
c
c    Output, double precision R(N), the vector of pseudorandom values.
c
      implicit none

      integer n

      double precision a
      double precision b
      integer i
      integer i4_huge
      parameter ( i4_huge = 2147483647 )
      integer k
      integer seed
      double precision r(n)

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

      do i = 1, n

        k = seed / 127773

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

        if ( seed .lt. 0 ) then
          seed = seed + i4_huge
        end if

        r(i) = a + ( b - a ) * dble ( seed ) * 4.656612875D-10

      end do

      return
      end
      subroutine r8vec_uniform_abvec ( n, a, b, seed, r )

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

      integer n

      double precision a(n)
      double precision b(n)
      integer i
      integer i4_huge
      parameter ( i4_huge = 2147483647 )
      integer k
      integer seed
      double precision r(n)

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

      do i = 1, n

        k = seed / 127773

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

        if ( seed .lt. 0 ) then
          seed = seed + i4_huge
        end if

        r(i) = a(i) + ( b(i) - a(i) ) * dble ( seed ) * 4.656612875D-10

      end do

      return
      end
      subroutine r8vec_uniform_unit ( m, seed, w )

c*********************************************************************72
c
cc R8VEC_UNIFORM_UNIT generates a uniformly random unit vector.
c
c  Licensing:
c
c    This code is distributed under the GNU LGPL license. 
c
c  Modified:
c
c    04 October 2012
c
c  Author:
c
c    John Burkardt
c
c  Parameters:
c
c    Input, integer M, the spatial dimension.
c
c    Input/output, integer SEED, a seed for the random number 
c    generator.
c
c    Output, double precision W(M), a random direction vector,
c    with unit norm.
c
      implicit none

      integer m

      integer i
      double precision norm
      double precision r8vec_norm_l2
      integer seed
      double precision w(m)
c
c  Get N values from a standard normal distribution.
c
      call r8vec_normal_01 ( m, seed, w )
c
c  Compute the length of the vector.
c
      norm = r8vec_norm_l2 ( m, w )
c
c  Normalize the vector.
c
      do i = 1, m
        w(i) = w(i) / norm
      end do

      return
      end
      subroutine r8vec_unique_count ( n, a, tol, unique_num )

c*********************************************************************72
c
cc R8VEC_UNIQUE_COUNT counts the unique elements in an unsorted R8VEC.
c
c  Discussion:
c
c    An R8VEC is a vector of R8 values.
c
c    Because the array is unsorted, this algorithm is O(N^2).
c
c  Licensing:
c
c    This code is distributed under the GNU LGPL license.
c
c  Modified:
c
c    28 August 2008
c
c  Author:
c
c    John Burkardt
c
c  Parameters:
c
c    Input, integer N, the number of elements of A.
c
c    Input, double precision A(N), the unsorted array to examine.
c
c    Input, double precision TOL, a nonnegative tolerance for equality.
c    Set it to 0.0 for the strictest test.
c
c    Output, integer UNIQUE_NUM, the number of unique elements
c    of A.
c
      implicit none

      integer n

      double precision a(n)
      integer i
      integer j
      integer unique_num
      double precision tol

      unique_num = 0

      do i = 1, n

        unique_num = unique_num + 1

        do j = 1, i - 1

          if ( abs ( a(i) - a(j) ) .le. tol ) then
            unique_num = unique_num - 1
            exit
          end if

        end do

      end do

      return
      end
      subroutine r8vec_unique_index ( n, a, tol, unique_index )

c*********************************************************************72
c
cc R8VEC_UNIQUE_INDEX indexes the first occurrence of values in an R8VEC.
c
c  Discussion:
c
c    An R8VEC is a vector of R8's.
c
c    For element A(I) of the vector, FIRST_UNIQUE(I) is the uniqueness index
c    of A(I).  That is, if A_UNIQUE contains the unique elements of A,
c    gathered in order, then
c
c      A_UNIQUE ( UNIQUE_INDEX(I) ) = A(I)
c
c  Licensing:
c
c    This code is distributed under the GNU LGPL license.
c
c  Modified:
c
c    28 August 2008
c
c  Author:
c
c    John Burkardt
c
c  Parameters:
c
c    Input, integer N, the number of elements of A.
c
c    Input, double precision A(N), the array.
c
c    Input, double precision TOL, a tolerance for equality.
c
c    Output, integer UNIQUE_INDEX(N), the unique index.
c
      implicit none

      integer n

      double precision a(n)
      integer i
      integer j
      double precision tol
      integer unique_index(n)
      integer unique_num

      do i = 1, n
        unique_index(i) = -1
      end do
      unique_num = 0

      do i = 1, n

        if ( unique_index(i) .eq. -1 ) then

          unique_num = unique_num + 1
          unique_index(i) = unique_num

          do j = i + 1, n
            if ( abs ( a(i) - a(j) ) .le. tol ) then
              unique_index(j) = unique_num
            end if
          end do

        end if

      end do

      return
      end
      subroutine r8vec_variance ( n, a, variance )

c*********************************************************************72
c
cc R8VEC_VARIANCE returns the variance of an R8VEC.
c
c  Discussion:
c
c    An R8VEC is a vector of R8's.
c
c    The variance of a vector X of length N is defined as
c
c      mean ( X(1:n) ) = sum ( X(1:n) ) / n
c
c      var ( X(1:n) ) = sum ( ( X(1:n) - mean )^2 ) / ( n - 1 )
c
c  Licensing:
c
c    This code is distributed under the GNU LGPL license.
c
c  Modified:
c
c    04 July 2009
c
c  Author:
c
c    John Burkardt
c
c  Parameters:
c
c    Input, integer N, the number of entries in the vector.
c    N should be at least 2.
c
c    Input, double precision A(N), the vector.
c
c    Output, double precision VARIANCE, the variance of the vector.
c
      implicit none

      integer n

      double precision a(n)
      integer i
      double precision mean
      double precision variance

      if ( n .lt. 2 ) then

        variance = 0.0D+00

      else

        mean = 0.0D+00
        do i = 1, n
          mean = mean + a(i)
        end do
        mean = mean / dble ( n )

        variance = 0.0D+00
        do i = 1, n
          variance = variance + ( a(i) - mean )**2
        end do
        variance = variance / dble ( n - 1 )

      end if

      return
      end
      subroutine r8vec_vector_triple_product ( v1, v2, v3, v )

c*********************************************************************72
c
cc R8VEC_VECTOR_TRIPLE_PRODUCT computes the vector triple product.
c
c  Discussion:
c
c    VTRIPLE = V1 x ( V2 x V3 )
c
c    VTRIPLE is a vector perpendicular to V1, lying in the plane
c    spanned by V2 and V3.  The norm of VTRIPLE is the product
c    of the norms of V1, V2 and V3.
c
c  Licensing:
c
c    This code is distributed under the GNU LGPL license.
c
c  Modified:
c
c    27 October 2010
c
c  Author:
c
c    John Burkardt
c
c  Parameters:
c
c    Input, double precision V1(3), V2(3), V3(3), three vectors.
c
c    Output, double precision V(3), the vector triple product.
c
      implicit none

      double precision v(3)
      double precision v1(3)
      double precision v2(3)
      double precision v3(3)
      double precision v4(3)

      call r8vec_cross_product_3d ( v2, v3, v4 )

      call r8vec_cross_product_3d ( v1, v4, v )

      return
      end
      subroutine r8vec_write ( n, r, output_file )

c*********************************************************************72
c
cc R8VEC_WRITE writes an R8VEC to a file.
c
c  Discussion:
c
c    An R8VEC is a vector of R8's.
c
c  Licensing:
c
c    This code is distributed under the GNU LGPL license.
c
c  Modified:
c
c    20 August 2010
c
c  Author:
c
c    John Burkardt
c
c  Parameters:
c
c    Input, integer N, the order of the matrix.
c
c    Input, double precision R(N), the vector to be written.
c
c    Input, character * ( * ) OUTPUT_FILE, the name of the file to which
c    the information is to be written.
c
      implicit none

      integer n

      integer i
      character * ( * ) output_file
      integer output_unit
      double precision r(n)

      call get_unit ( output_unit )

      open ( unit = output_unit, file = output_file,
     &  status = 'replace' )

      do i = 1, n
        write ( output_unit, '(2x,g16.8)' ) r(i)
      end do

      close ( unit = output_unit )

      return
      end
      subroutine r8vec_zero ( n, a )

c*********************************************************************72
c
cc R8VEC_ZERO zeroes out an R8VEC.
c
c  Discussion:
c
c    An R8VEC is a vector of R8's.
c
c  Licensing:
c
c    This code is distributed under the GNU LGPL license.
c
c  Modified:
c
c    04 July 2009
c
c  Author:
c
c    John Burkardt
c
c  Parameters:
c
c    Input, integer N, the number of entries in the vector.
c
c    Output, double precision A(N), the vector to be zeroed.
c
      implicit none

      integer n

      double precision a(n)
      integer i

      do i = 1, n
        a(i) = 0.0D+00
      end do

      return
      end
      subroutine r8vec2_compare ( n, a1, a2, i, j, isgn )

c*********************************************************************72
c
cc R8VEC2_COMPARE compares two entries in an R8VEC2.
c
c  Discussion:
c
c    An R8VEC2 is a dataset consisting of N pairs of R8's, stored
c    as two separate vectors A1 and A2.
c
c    The lexicographic ordering is used.
c
c  Example:
c
c    A1(I) A2(I)   A1(J) A2(J)  ISGN
c    -----------   -----------  ----
c    1.0   5.0  <  1.0   6.0     -1
c    1.0   5.0  <  2.0   8.0     -1
c    1.0   5.0  <  9.0   1.0     -1
c    1.0   5.0  =  1.0   5.0      0
c    1.0   5.0  >  0.0   2.0     +1
c    1.0   5.0  >  0.0   5.0     +1
c    1.0   5.0  >  1.0   3.0     +1
c
c  Licensing:
c
c    This code is distributed under the GNU LGPL license.
c
c  Modified:
c
c    22 August 2010
c
c  Author:
c
c    John Burkardt
c
c  Parameters:
c
c    Input, integer N, the number of data items.
c
c    Input, double precision A1(N), A2(N), the two components of each item.
c
c    Input, integer I, J, the items to be compared.
c
c    Output, integer ISGN, the results of the comparison:
c    -1, item I < item J,
c     0, item I = item J,
c    +1, item I > item J.
c
      implicit none

      integer n

      double precision a1(n)
      double precision a2(n)
      integer i
      integer isgn
      integer j

      isgn = 0

           if ( a1(i) .lt. a1(j) ) then

        isgn = -1

      else if ( a1(i) .eq. a1(j) ) then

             if ( a2(i) .lt. a2(j) ) then
          isgn = -1
        else if ( a2(i) .lt. a2(j) ) then
          isgn = 0
        else if ( a2(j) .lt. a2(i) ) then
          isgn = +1
        end if

      else if ( a1(j) .lt. a1(i) ) then

        isgn = +1

      end if

      return
      end
      subroutine r8vec2_print ( n, a1, a2, title )

c*********************************************************************72
c
cc R8VEC2_PRINT prints an R8VEC2.
c
c  Discussion:
c
c    An R8VEC2 is a dataset consisting of N pairs of R8s, stored
c    as two separate vectors A1 and A2.
c
c  Licensing:
c
c    This code is distributed under the GNU LGPL license.
c
c  Modified:
c
c    06 February 2008
c
c  Author:
c
c    John Burkardt
c
c  Parameters:
c
c    Input, integer N, the number of components of the vector.
c
c    Input, double precision A1(N), A2(N), the vectors to be printed.
c
c    Input, character ( len = * ) TITLE, a title.
c
      implicit none

      integer n

      double precision a1(n)
      double precision a2(n)
      integer i
      character ( len = * ) title

      write ( *, '(a)' ) ' '
      write ( *, '(a)' ) trim ( title )
      write ( *, '(a)' ) ' '
      do i = 1, n
        write ( *, '(2x,i8,a,1x,g14.6,2x,g14.6)' ) i, ':', a1(i), a2(i)
      end do

      return
      end
      subroutine r8vec2_print_some ( n, x1, x2, max_print, title )

c*********************************************************************72
c
cc R8VEC2_PRINT_SOME prints "some" of an R8VEC2.
c
c  Discussion:
c
c    An R8VEC2 is a dataset consisting of N pairs of R8's, stored
c    as two separate vectors A1 and A2.
c
c    The user specifies MAX_PRINT, the maximum number of lines to print.
c
c    If N, the size of the vectors, is no more than MAX_PRINT, then
c    the entire vectors are printed, one entry of each per line.
c
c    Otherwise, if possible, the first MAX_PRINT-2 entries are printed,
c    followed by a line of periods suggesting an omission,
c    and the last entry.
c
c  Licensing:
c
c    This code is distributed under the GNU LGPL license.
c
c  Modified:
c
c    08 June 2011
c
c  Author:
c
c    John Burkardt
c
c  Parameters:
c
c    Input, integer N, the number of entries of the vectors.
c
c    Input, double precision X1(N), X2(N), the vector to be printed.
c
c    Input, integer MAX_PRINT, the maximum number of lines
c    to print.
c
c    Input, character * ( * ) TITLE, a title.
c
      implicit none

      integer n

      integer i
      integer max_print
      character * ( * )  title
      double precision x1(n)
      double precision x2(n)

      if ( max_print .le. 0 ) then
        return
      end if

      if ( n .le. 0 ) then
        return
      end if

      write ( *, '(a)' ) ' '
      write ( *, '(a)' ) trim ( title )
      write ( *, '(a)' ) ' '

      if ( n .le. max_print ) then

        do i = 1, n
          write ( *, '(2x,i8,2x,g14.6,2x,g14.6)' ) i, x1(i), x2(i)
        end do

      else if ( 3 .le. max_print ) then

        do i = 1, max_print - 2
          write ( *, '(2x,i8,2x,g14.6,2x,g14.6)' ) i, x1(i), x2(i)
        end do
        write ( *, '(a)' ) '  ......  ..............  ..............'
        i = n
        write ( *, '(2x,i8,2x,g14.6,2x,g14.6)' ) i, x1(i), x2(i)

      else

        do i = 1, max_print - 1
          write ( *, '(2x,i8,2x,g14.6,2x,g14.6)' ) i, x1(i), x2(i)
        end do
        i = max_print
        write ( *, '(2x,i8,2x,g14.6,2x,g14.6,2x,a)' ) i, x1(i), x2(i), 
     &    '...more entries...'

      end if

      return
      end
      subroutine r8vec2_sort_a ( n, a1, a2 )

c*********************************************************************72
c
cc R8VEC2_SORT_A ascending sorts an R8VEC2.
c
c  Discussion:
c
c    An R8VEC2 is a dataset consisting of N pairs of R8's, stored
c    as two separate vectors A1 and A2.
c
c    Each item to be sorted is a pair (I,J), with the I
c    and J values stored in separate vectors A1 and A2.
c
c  Licensing:
c
c    This code is distributed under the GNU LGPL license.
c
c  Modified:
c
c    05 September 2011
c
c  Author:
c
c    John Burkardt
c
c  Parameters:
c
c    Input, integer N, the number of items of data.
c
c    Input/output, double precision A1(N), A2(N), the data to be sorted.
c
      implicit none

      integer n

      double precision a1(n)
      double precision a2(n)
      integer i
      integer indx
      integer isgn
      integer j

      if ( n .le. 1 ) then
        return
      end if
c
c  Initialize.
c
      i = 0
      indx = 0
      isgn = 0
      j = 0
c
c  Call the external heap sorter.
c
10    continue

        call sort_heap_external ( n, indx, i, j, isgn )
c
c  Interchange the I and J objects.
c
        if ( 0 .lt. indx ) then

          call r8_swap ( a1(i), a1(j) )
          call r8_swap ( a2(i), a2(j) )
c
c  Compare the I and J objects.
c
        else if ( indx .lt. 0 ) then

          call r8vec2_compare ( n, a1, a2, i, j, isgn )

        else if ( indx .eq. 0 ) then

          go to 20

        end if

      go to 10

20    continue

      return
      end
      subroutine r8vec2_sort_d ( n, a1, a2 )

c*********************************************************************72
c
cc R8VEC2_SORT_D descending sorts an R8VEC2.
c
c  Discussion:
c
c    An R8VEC2 is a dataset consisting of N pairs of R8's, stored
c    as two separate vectors A1 and A2.
c
c    Each item to be sorted is a pair (I,J), with the I
c    and J values stored in separate vectors A1 and A2.
c
c  Licensing:
c
c    This code is distributed under the GNU LGPL license.
c
c  Modified:
c
c    05 September 2011
c
c  Author:
c
c    John Burkardt
c
c  Parameters:
c
c    Input, integer N, the number of items of data.
c
c    Input/output, double precision A1(N), A2(N), the data to be sorted.
c
      implicit none

      integer n

      double precision a1(n)
      double precision a2(n)
      integer i
      integer indx
      integer isgn
      integer j

      if ( n .le. 1 ) then
        return
      end if
c
c  Initialize.
c
      i = 0
      indx = 0
      isgn = 0
      j = 0
c
c  Call the external heap sorter.
c
10    continue

        call sort_heap_external ( n, indx, i, j, isgn )
c
c  Interchange the I and J objects.
c
        if ( 0 .lt. indx ) then

          call r8_swap ( a1(i), a1(j) )
          call r8_swap ( a2(i), a2(j) )
c
c  Compare the I and J objects.
c  Reverse the value of ISGN to effect a descending sort.
c
        else if ( indx .lt. 0 ) then

          call r8vec2_compare ( n, a1, a2, i, j, isgn )

          isgn = -isgn

        else if ( indx .eq. 0 ) then

          go to 20

        end if

      go to 10

20    continue

      return
      end
      subroutine r8vec2_sort_heap_index_a ( n, x, y, indx )

c*********************************************************************72
c
cc R8VEC2_SORT_HEAP_INDEX_A does an indexed heap ascending sort of an R8VEC2.
c
c  Discussion:
c
c    An R8VEC2 is a dataset consisting of N pairs of R8's, stored
c    as two separate vectors A1 and A2.
c
c    The sorting is not actually carried out.  Rather an index array is
c    created which defines the sorting.  This array may be used to sort
c    or index the array, or to sort or index related arrays keyed on the
c    original array.
c
c    ( X(I), Y(I) ) < ( X(J), Y(J) ) if:
c
c    * X(I) < X(J), or
c
c    * X(I) = X(J), and Y(I) < Y(J).
c
c    Once the index array is computed, the sorting can be carried out
c    "implicitly:
c
c      ( X(INDX(1:N)), Y(INDX(1:N) ), is sorted,
c
c    or explicitly, by the call
c
c      call r8vec_permute ( n, indx, x )
c      call r8vec_permute ( n, indx, y )
c
c    after which ( X(1:N), Y(1:N) ), is sorted.
c
c  Licensing:
c
c    This code is distributed under the GNU LGPL license.
c
c  Modified:
c
c    05 September 2011
c
c  Author:
c
c    John Burkardt
c
c  Parameters:
c
c    Input, integer N, the number of entries in the array.
c
c    Input, double precision X(N),Y(N), pairs of X, Y coordinates of points.
c
c    Output, integer INDX(N), the sort index.  The
c    I-th element of the sorted array has coordinates ( X(INDX(I)), Y(INDX(I) ).
c
      implicit none

      integer n

      integer i
      integer indx(n)
      integer indxt
      integer ir
      integer j
      integer l
      double precision x(n)
      double precision xval
      double precision y(n)
      double precision yval

      if ( n .lt. 1 ) then
        return
      end if

      call i4vec_indicator ( n, indx )

      if ( n .eq. 1 ) then
        return
      end if

      l = n / 2 + 1
      ir = n

10    continue

        if ( 1 .lt. l ) then

          l = l - 1
          indxt = indx(l)
          xval = x(indxt)
          yval = y(indxt)

        else

          indxt = indx(ir)
          xval = x(indxt)
          yval = y(indxt)
          indx(ir) = indx(1)
          ir = ir - 1

          if ( ir .eq. 1 ) then
            indx(1) = indxt
            go to 30
          end if

        end if

        i = l
        j = l + l

20      continue

        if ( j .le. ir ) then

          if ( j .lt. ir ) then

            if ( x(indx(j)) .lt. x(indx(j+1)) .or. 
     &        ( x(indx(j)) .eq. x(indx(j+1)) .and. 
     &          y(indx(j)) .lt. y(indx(j+1)) ) ) then
              j = j + 1
            end if

          end if

          if ( xval .lt. x(indx(j)) .or. 
     &        ( xval .eq. x(indx(j)) .and. yval .lt. y(indx(j)) ) ) then
            indx(i) = indx(j)
            i = j
            j = j + j
          else
            j = ir + 1
          end if

          go to 20

        end if

        indx(i) = indxt

      go to 10

30    continue

      return
      end
      subroutine r8vec2_sorted_unique ( n, a1, a2, unique_num )

c*********************************************************************72
c
cc R8VEC2_SORTED_UNIQUE keeps unique elements in a sorted R8VEC2.
c
c  Discussion:
c
c    An R8VEC2 is a dataset consisting of N pairs of R8's, stored
c    as two separate vectors A1 and A2.
c
c    Item I is stored as the pair A1(I), A2(I).
c
c    The items must have been sorted, or at least it must be the
c    case that equal items are stored in adjacent vector locations.
c
c    If the items were not sorted, then this routine will only
c    replace a string of equal values by a single representative.
c
c  Licensing:
c
c    This code is distributed under the GNU LGPL license.
c
c  Modified:
c
c    05 September 2011
c
c  Author:
c
c    John Burkardt
c
c  Parameters:
c
c    Input, integer N, the number of items.
c
c    Input/output, double precision A1(N), A2(N).
c    On input, the array of N items.
c    On output, an array of unique items.
c
c    Output, integer UNIQUE_NUM, the number of unique items.
c
      implicit none

      integer n

      double precision a1(n)
      double precision a2(n)
      integer itest
      integer unique_num

      if ( n .le. 0 ) then
        unique_num = 0
        return
      end if

      unique_num = 1

      do itest = 2, n

        if ( a1(itest) .ne. a1(unique_num) .or. 
     &       a2(itest) .ne. a2(unique_num) ) then

          unique_num = unique_num + 1

          a1(unique_num) = a1(itest)
          a2(unique_num) = a2(itest)

        end if

      end do

      return
      end
      subroutine r8vec2_sorted_unique_index ( n, a1, a2, unique_num, 
     &  indx )

c*********************************************************************72
c
cc R8VEC2_SORTED_UNIQUE_INDEX indexes unique elements in a sorted R8VEC2.
c
c  Discussion:
c
c    An R8VEC2 is a dataset consisting of N pairs of R8's, stored
c    as two separate vectors A1 and A2.
c
c    Item I is stored as the pair A1(I), A2(I).
c
c    The items must have been sorted, or at least it should be the
c    case that equal items are stored in adjacent vector locations.
c
c  Licensing:
c
c    This code is distributed under the GNU LGPL license.
c
c  Modified:
c
c    05 September 2011
c
c  Author:
c
c    John Burkardt
c
c  Parameters:
c
c    Input, integer N, the number of items.
c
c    Input, double precision A1(N), A2(N), the array of N items.
c
c    Output, integer UNIQUE_NUM, the number of unique items.
c
c    Output, integer INDX(N), contains in entries 1 through
c    UNIQUE_NUM an index array of the unique items.  To build new arrays
c    with no repeated elements:
c      B1(1:UNIQUE_NUM) = A1(INDX(1:UNIQUE_NUM))
c
      implicit none

      integer n

      double precision a1(n)
      double precision a2(n)
      integer i
      integer indx(n)
      integer itest
      integer unique_num

      if ( n .le. 0 ) then
        unique_num = 0
        return
      end if

      unique_num = 1
      indx(1) = 1

      do itest = 2, n

        if ( a1(itest-1) .ne. a1(itest) .or. 
     &       a2(itest-1) .ne. a2(itest) ) then

          unique_num = unique_num + 1

          indx(unique_num) = itest

        end if

      end do

      do i = unique_num + 1, n
        indx(i) = 0
      end do

      return
      end
      subroutine r8vec2_sum_max_index ( n, a, b, sum_max_index )

c*********************************************************************72
c
cc R8VEC2_SUM_MAX_INDEX returns the index of the maximum sum of two R8VEC's.
c
c  Discussion:
c
c    An R8VEC2 is a dataset consisting of N pairs of R8's, stored
c    as two separate vectors A1 and A2.
c
c  Licensing:
c
c    This code is distributed under the GNU LGPL license.
c
c  Modified:
c
c    05 September 2011
c
c  Author:
c
c    John Burkardt
c
c  Parameters:
c
c    Input, integer N, the number of entries in the array.
c
c    Input, double precision A(N), B(N), two arrays whose sum
c    is to be examined.
c
c    Output, integer SUM_MAX_INDEX, the index of the largest
c    entry in A+B.
c
      implicit none

      integer n

      double precision a(n)
      double precision b(n)
      integer i
      double precision sum_max
      integer sum_max_index

      if ( n .le. 0 ) then

        sum_max_index = -1

      else

        sum_max_index = 1
        sum_max = a(1) + b(1)

        do i = 2, n
          if ( sum_max .lt. a(i) + b(i) ) then
            sum_max = a(i) + b(i)
            sum_max_index = i
          end if
        end do

      end if

      return
      end
      subroutine r8vec3_print ( n, a1, a2, a3, title )

c*********************************************************************72
c
cc R8VEC3_PRINT prints an R8VEC3.
c
c  Discussion:
c
c    An R8VEC3 is a dataset consisting of N triples of R8's, stored
c    as three separate vectors A1, A2, A3.
c
c  Licensing:
c
c    This code is distributed under the GNU LGPL license.
c
c  Modified:
c
c    05 September 2011
c
c  Author:
c
c    John Burkardt
c
c  Parameters:
c
c    Input, integer N, the number of components of the vector.
c
c    Input, double precision A1(N), A2(N), A3(N), the vectors to be printed.
c
c    Input, character * ( * ) TITLE, a title.
c
      implicit none

      integer n

      double precision a1(n)
      double precision a2(n)
      double precision a3(n)
      integer i
      character * ( * )  title

      write ( *, '(a)' ) ' '
      write ( *, '(a)' ) trim ( title )
      write ( *, '(a)' ) ' '

      do i = 1, n
        write ( *, '(i8,3g14.6)' ) i, a1(i), a2(i), a3(i)
      end do

      return
      end
      subroutine r8vecs_print ( m, nvec, na, a, title )

c*********************************************************************72
c
cc R8VECS_PRINT prints a packed R8VEC.
c
c  Example:
c
c    M = 5
c    NVEC = (/ 1, 4, 6, 11, 13, 14 /)
c    A = (/ 11, 12, 13, 21, 22, 31, 32, 33, 34, 35, 41, 42, 51 /)
c
c    11 12 13
c    21 22
c    31 32 33 34 35
c    41 42
c    51
c
c  Licensing:
c
c    This code is distributed under the GNU LGPL license.
c
c  Modified:
c
c    26 June 2012
c
c  Author:
c
c    John Burkardt
c
c  Parameters:
c
c    Input, integer M, the number of vectors packed into A.
c
c    Input, integer NVEC(M+1), pointers to the first entry 
c    in each vector.
c
c    Input, integer NA, the number of entries in A.
c
c    Input, double precision A(NA), the packed vector.  The I-th vector
c    extends from A(NVEC(I)) to A(NVEC(I+1)-1).
c
c    Input, character * ( * ) TITLE, a title.
c
      implicit none

      integer m
      integer na

      double precision a(na)
      integer i
      integer j
      integer jhi
      integer jlo
      integer khi
      integer klo
      integer n
      integer nvec(m+1)
      character * ( * ) title

      write ( *, '(a)' ) ' '
      write ( *, '(a)' ) trim ( title )
      write ( *, '(a)' ) ' '

      khi = 0

      do i = 1, m

        n = nvec(i+1) - nvec(i)

        do jlo = 1, n, 5
          jhi = min ( jlo + 5 - 1, n )
          klo = khi + 1
          khi = klo + ( jhi - jlo )
          if ( jlo .eq. 1 ) then
            write ( *, '(2x,i3,2x,5g14.6)' ) i, a(klo:khi)
          else
            write ( *, '(7x,5g14.6)' ) a(klo:khi)
          end if
        end do

      end do

      return
      end
      subroutine roots_to_r8poly ( n, x, c )

c*********************************************************************72
c
cc ROOTS_TO_R8POLY converts polynomial roots to polynomial coefficients.
c
c  Licensing:
c
c    This code is distributed under the GNU LGPL license.
c
c  Modified:
c
c    17 July 2010
c
c  Author:
c
c    John Burkardt
c
c  Parameters:
c
c    Input, integer N, the number of roots specified.
c
c    Input, double precision X(N), the roots.
c
c    Output, double precision C(0:N), the coefficients of the polynomial.
c
      implicit none

      integer n

      double precision c(0:n)
      integer i
      integer j
      double precision x(n)
c
c  Initialize C to (0, 0, ..., 0, 1).
c  Essentially, we are setting up a divided difference table.
c
      do i = 0, n - 1
        c(i) = 0.0D+00
      end do
      c(n) = 1.0D+00
c
c  Convert to standard polynomial form by shifting the abscissas
c  of the divided difference table to 0.
c
      do j = 1, n
        do i = 1, n + 1 - j
          c(n-i) = c(n-i) - x(n+1-i-j+1) * c(n-i+1)
        end do
      end do

      return
      end
      subroutine sort_heap_external ( n, indx, i, j, isgn )

c*********************************************************************72
c
cc SORT_HEAP_EXTERNAL externally sorts a list of items into ascending order.
c
c  Discussion:
c
c    The actual list of data is not passed to the routine.  Hence this
c    routine may be used to sort integers, reals, numbers, names,
c    dates, shoe sizes, and so on.  After each call, the routine asks
c    the user to compare or interchange two items, until a special
c    return value signals that the sorting is completed.
c
c  Licensing:
c
c    This code is distributed under the GNU LGPL license.
c
c  Modified:
c
c    25 January 2007
c
c  Author:
c
c    Original FORTRAN77 version by Albert Nijenhuis, Herbert Wilf.
c    This FORTRAN77 version by John Burkardt.
c
c  Reference:
c
c    Albert Nijenhuis, Herbert Wilf,
c    Combinatorial Algorithms for Computers and Calculators,
c    Academic Press, 1978,
c    ISBN: 0-12-519260-6,
c    LC: QA164.N54.
c
c  Parameters:
c
c    Input, integer N, the number of items to be sorted.
c
c    Input/output, integer INDX, the main communication signal.
c
c    The user must set INDX to 0 before the first call.
c    Thereafter, the user should not change the value of INDX until
c    the sorting is done.
c
c    On return, if INDX is
c
c      greater than 0,
c      * interchange items I and J;
c      * call again.
c
c      less than 0,
c      * compare items I and J;
c      * set ISGN = -1 if I .lt. J, ISGN = +1 if J .lt. I;
c      * call again.
c
c      equal to 0, the sorting is done.
c
c    Output, integer I, J, the indices of two items.
c    On return with INDX positive, elements I and J should be interchanged.
c    On return with INDX negative, elements I and J should be compared, and
c    the result reported in ISGN on the next call.
c
c    Input, integer ISGN, results of comparison of elements I and J.
c    (Used only when the previous call returned INDX less than 0).
c    ISGN .le. 0 means I is less than or equal to J;
c    0 .le. ISGN means I is greater than or equal to J.
c
      implicit none

      integer i
      integer i_save
      integer indx
      integer isgn
      integer j
      integer j_save
      integer k
      integer k1
      integer n
      integer n1

      save i_save
      save j_save
      save k
      save k1
      save n1

      data i_save / 0 /
      data j_save / 0 /
      data k / 0 /
      data k1 / 0 /
      data n1 / 0 /
c
c  INDX = 0: This is the first call.
c
      if ( indx .eq. 0 ) then

        i_save = 0
        j_save = 0
        k = n / 2
        k1 = k
        n1 = n
c
c  INDX .lt. 0: The user is returning the results of a comparison.
c
      else if ( indx .lt. 0 ) then

        if ( indx .eq. -2 ) then

          if ( isgn .lt. 0 ) then
            i_save = i_save + 1
          end if

          j_save = k1
          k1 = i_save
          indx = -1
          i = i_save
          j = j_save
          return

        end if

        if ( 0 .lt. isgn ) then
          indx = 2
          i = i_save
          j = j_save
          return
        end if

        if ( k .le. 1 ) then

          if ( n1 .eq. 1 ) then
            i_save = 0
            j_save = 0
            indx = 0
          else
            i_save = n1
            n1 = n1 - 1
            j_save = 1
            indx = 1
          end if

          i = i_save
          j = j_save
          return

        end if

        k = k - 1
        k1 = k
c
c  0 .lt. INDX, the user was asked to make an interchange.
c
      else if ( indx .eq. 1 ) then

        k1 = k

      end if

10    continue

        i_save = 2 * k1

        if ( i_save .eq. n1 ) then
          j_save = k1
          k1 = i_save
          indx = -1
          i = i_save
          j = j_save
          return
        else if ( i_save .le. n1 ) then
          j_save = i_save + 1
          indx = -2
          i = i_save
          j = j_save
          return
        end if

        if ( k .le. 1 ) then
          go to 20
        end if

        k = k - 1
        k1 = k

      go to 10

20    continue

      if ( n1 .eq. 1 ) then
        i_save = 0
        j_save = 0
        indx = 0
        i = i_save
        j = j_save
      else
        i_save = n1
        n1 = n1 - 1
        j_save = 1
        indx = 1
        i = i_save
        j = j_save
      end if

      return
      end
      subroutine timestamp ( )

c*********************************************************************72
c
cc TIMESTAMP prints out the current YMDHMS date as a timestamp.
c
c  Licensing:
c
c    This code is distributed under the GNU LGPL license.
c
c  Modified:
c
c    12 January 2007
c
c  Author:
c
c    John Burkardt
c
c  Parameters:
c
c    None
c
      implicit none

      character * ( 8 ) ampm
      integer d
      character * ( 8 ) date
      integer h
      integer m
      integer mm
      character * ( 9 ) month(12)
      integer n
      integer s
      character * ( 10 ) time
      integer y

      save month

      data month /
     &  'January  ', 'February ', 'March    ', 'April    ',
     &  'May      ', 'June     ', 'July     ', 'August   ',
     &  'September', 'October  ', 'November ', 'December ' /

      call date_and_time ( date, time )

      read ( date, '(i4,i2,i2)' ) y, m, d
      read ( time, '(i2,i2,i2,1x,i3)' ) h, n, s, mm

      if ( h .lt. 12 ) then
        ampm = 'AM'
      else if ( h .eq. 12 ) then
        if ( n .eq. 0 .and. s .eq. 0 ) then
          ampm = 'Noon'
        else
          ampm = 'PM'
        end if
      else
        h = h - 12
        if ( h .lt. 12 ) then
          ampm = 'PM'
        else if ( h .eq. 12 ) then
          if ( n .eq. 0 .and. s .eq. 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, month(m), y, h, ':', n, ':', s, '.', mm, ampm

      return
      end