      subroutine brownian_displacement_display ( k, n, d, t, dsq,
     &  header )

c*********************************************************************72
c
cc BROWNIAN_DISPLACEMENT_DISPLAY displays average Brownian motion displacement.
c
c  Licensing:
c
c    This code is distributed under the GNU LGPL license.
c
c  Modified:
c
c    30 September 2012
c
c  Author:
c
c    John Burkardt
c
c  Parameters:
c
c    Input, integer K, the number of repetitions.
c
c    Input, integer N, the number of time steps.
c
c    Input, double precision D, the diffusion coefficient.
c
c    Input, double precision T, the total time.
c
c    Input, double precision DSQ(K,N), the displacements over time for
c    each repetition.
c
c    Input, character * ( * ) HEADER, an identifier for the output files.
c
      implicit none

      integer k
      integer n

      character * ( 80 ) command_filename
      integer command_unit
      double precision d
      character * ( 80 ) data_filename
      integer data_unit
      double precision dsq(k,n)
      double precision dsq_ave
      double precision dsq_ideal
      character * ( * ) header
      integer i
      integer i4_uniform
      integer ii(5)
      integer j
      integer seed
      double precision t
      double precision ti

      seed = 123456789
c
c  Choose 5 paths at random.
c
      do j = 1, 5
        ii(j) = i4_uniform ( 1, k, seed )
      end do
c
c  Create the data file.
c
      call get_unit ( data_unit )

      data_filename = trim ( header ) // '_data.txt'

      open ( unit = data_unit, file = data_filename,
     &  status = 'replace' )

      do j = 1, n
        ti = dble ( j - 1 ) * t / dble ( n - 1 )
        dsq_ave = 0.0D+00
        do i = 1, k
          dsq_ave = dsq_ave + dsq(i,j)
        end do
        dsq_ave = dsq_ave / dble ( k )
        dsq_ideal = d * ti
        write ( data_unit, '(8(2x,g14.6))' )
     &    ti, dsq(ii(1:5),j), dsq_ave, dsq_ideal
      end do

      close ( unit = data_unit )

      write ( *, '(a)' ) ' '
      write ( *, '(a)' ) '  BROWNIAN_DISPLACEMENT data stored in "'
     &  // trim ( data_filename ) // '".'
c
c  Create the command file.
c
      call get_unit ( command_unit )

      command_filename = trim ( header ) // '_commands.txt'

      open ( unit = command_unit, file = command_filename,
     &  status = 'replace' )

      write ( command_unit, '(a)' ) '# ' // trim ( command_filename )
      write ( command_unit, '(a)' ) '#'
      write ( command_unit, '(a)' ) '# Usage:'
      write ( command_unit, '(a)' ) '#  gnuplot < ' //
     &  trim ( command_filename )
      write ( command_unit, '(a)' ) '#'
      write ( command_unit, '(a)' ) 'set term png'
      write ( command_unit, '(a)' ) 'set output "'
     &  // trim ( header ) // '.png"'
      write ( command_unit, '(a)' ) 'set xlabel "T"'
      write ( command_unit, '(a)' ) 'set ylabel "D^2"'
      write ( command_unit, '(a)' ) 'set title "Squared ' //
     &  'displacement (Red), Predicted (Black), Samples (Blue)"'
      write ( command_unit, '(a)' ) 'set grid'
      write ( command_unit, '(a)' ) 'set style data lines'
      write ( command_unit, '(a)' ) 'plot "'
     &  // trim ( data_filename ) //
     &  '" using 1:2 title "sample 1" linecolor rgb "blue", \'
      write ( command_unit, '(a)' ) '     "'
     &  // trim ( data_filename ) //
     &  '" using 1:3 title "sample 2" linecolor rgb "blue", \'
      write ( command_unit, '(a)' ) '     "'
     &  // trim ( data_filename ) //
     &  '" using 1:4 title "sample 3" linecolor rgb "blue", \'
      write ( command_unit, '(a)' ) '     "'
     &  // trim ( data_filename ) //
     &  '" using 1:5 title "sample 4" linecolor rgb "blue", \'
      write ( command_unit, '(a)' ) '     "'
     &  // trim ( data_filename ) //
     &  '" using 1:6 title "sample 5" linecolor rgb "blue", \'
      write ( command_unit, '(a)' ) '     "'
     &  // trim ( data_filename ) //
     &  '" using 1:7 title "Averaged" lw 3 linecolor rgb "red", \'
      write ( command_unit, '(a)' ) '     "'
     &  // trim ( data_filename ) //
     &  '" using 1:8 title "Ideal" lw 3 linecolor rgb "black"'
      write ( command_unit, '(a)' ) 'quit'

      close ( unit = command_unit )

      write ( *, '(a)' )
     &  '  BROWNIAN_DISPLACEMENT plot commands stored in "'
     &  // trim ( command_filename ) // '".'

      return
      end
      subroutine brownian_displacement_simulation ( k, n, m, d, t,
     &  seed, dsq )

c*********************************************************************72
c
cc BROWNIAN_DISPLACEMENT_SIMULATION simulates Brownian displacement.
c
c  Discussion:
c
c    This function computes the square of the distance of the Brownian
c    particle from the starting point, repeating this calculation
c    several times.
c
c  Licensing:
c
c    This code is distributed under the GNU LGPL license.
c
c  Modified:
c
c    30 September 2012
c
c  Author:
c
c    John Burkardt
c
c  Parameters:
c
c    Input, integer K, the number of repetitions.
c
c    Input, integer N, the number of time steps to take, plus 1.
c
c    Input, integer M, the spatial dimension.
c
c    Input, double precision D, the diffusion coefficient.
c    Computationally, this is simply a scale factor between time and space.
c
c    Input, double precision T, the total time.
c
c    Input/output, integer SEED, a seed for the random
c    number generator.
c
c    Output, double precision DSQ(K,N), the displacements over time for each
c    repetition.  DSQ(:,1) is 0.0, because we include the displacement at the
c    initial time.
c
      implicit none

      integer k
      integer m
      integer n

      double precision d
      double precision dt
      double precision dsq(k,n)
      integer i
      integer i2
      integer j
      double precision s
      integer seed
      double precision t
      double precision x(m,n)

      do i = 1, k

        call brownian_motion_simulation ( m, n, d, t, seed, x )

        do j = 1, n
          s = 0.0D+00
          do i2 = 1, m
            s = s + x(i2,j)**2
          end do
          dsq(i,j) = s
        end do

      end do

      return
      end
      subroutine brownian_motion_display ( m, n, x, header )

c*********************************************************************72
c
cc BROWNIAN_MOTION_DISPLAY displays successive Brownian motion positions.
c
c  Licensing:
c
c    This code is distributed under the GNU LGPL license.
c
c  Modified:
c
c    30 September 2012
c
c  Author:
c
c    John Burkardt
c
c  Parameters:
c
c    Input, integer M, the spatial dimension.
c    M should be 1 or 2.
c
c    Input, integer N, the number of time steps.
c
c    Input, double precision X(M,N), the particle positions.
c
c    Input, character ( len = * ) HEADER, an identifier for the output files.
c
      implicit none

      integer m
      integer n

      character * ( 80 ) command_filename
      integer command_unit
      character * ( 80 ) data_filename
      integer data_unit
      character * ( * ) header
      integer i
      double precision t
      double precision x(m,n)

      if ( m .ne. 1 .and. m .ne. 2 ) then
        write ( *, '(a)' ) ' '
        write ( *, '(a)' ) 'BROWNIAN_MOTION_DISPLAY - Fatal error!'
        write ( *, '(a)' ) '  This routine can only handle M = 1 or 2.'
        stop
      end if
c
c  Create the data file.
c
      call get_unit ( data_unit )

      data_filename = trim ( header ) // '_data.txt'

      open ( unit = data_unit, file = data_filename,
     &  status = 'replace' )

      if ( m .eq. 1 ) then
        do i = 1, n
          t = dble ( i - 1 ) / dble ( n - 1 )
          write ( data_unit, '(2x,g14.6,2x,g14.6)' ) t, x(1,i)
        end do
      else if ( m .eq. 2 ) then
        do i = 1, n
          write ( data_unit, '(2x,g14.6,2x,g14.6)' ) x(1,i), x(2,i)
        end do
      end if

      close ( unit = data_unit )

      write ( *, '(a)' ) ' '
      write ( *, '(a)' ) '  BROWNIAN_MOTION data stored in "'
     &  // trim ( data_filename ) // '".'
c
c  Create the command file.
c
      call get_unit ( command_unit )

      command_filename = trim ( header ) // '_commands.txt'

      open ( unit = command_unit, file = command_filename,
     &  status = 'replace' )

      write ( command_unit, '(a)' ) '# ' // trim ( command_filename )
      write ( command_unit, '(a)' ) '#'
      write ( command_unit, '(a)' ) '# Usage:'
      write ( command_unit, '(a)' ) '#  gnuplot < '
     &  // trim ( command_filename )
      write ( command_unit, '(a)' ) '#'
      write ( command_unit, '(a)' ) 'set term png'
      write ( command_unit, '(a)' ) 'set output "'
     &  // trim ( header ) // '.png"'
      write ( command_unit, '(a)' ) 'set xlabel "X"'
      write ( command_unit, '(a)' ) 'set ylabel "T"'
      write ( command_unit, '(a)' ) 'set title "Brownian motion in 1D"'
      write ( command_unit, '(a)' ) 'set grid'
      write ( command_unit, '(a)' ) 'set style data lines'
      write ( command_unit, '(a)' ) 'plot "' // trim ( data_filename )
     &  // '" using 1:2'
      write ( command_unit, '(a)' ) 'quit'

      close ( unit = command_unit )

      write ( *, '(a)' ) '  BROWNIAN_MOTION commands stored in "'
     &  // trim ( command_filename ) // '".'

      return
      end
      subroutine brownian_motion_simulation ( m, n, d, t, seed, x )

c*********************************************************************72
c
cc BROWNIAN_MOTION_SIMULATION simulates Brownian motion.
c
c  Licensing:
c
c    This code is distributed under the GNU LGPL license.
c
c  Modified:
c
c    30 September 2012
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 time steps to take, plus 1.
c
c    Input, double precision D, the diffusion coefficient.
c
c    Input, double precision T, the total time.
c
c    Input/output, integer SEED, a seed for the random
c    number generator.
c
c    Output, double precision X(M,N), the initial position at time 0.0, and
c    the N-1 successive locations of the particle.
c
      implicit none

      integer m
      integer n

      double precision d
      double precision dt
      double precision dx(m)
      integer i
      integer j
      double precision norm_dx
      double precision r8_normal_01
      double precision s
      integer seed
      double precision t
      double precision x(m,n)
c
c  Set the time step.
c
      dt = t / dble ( n - 1 )
c
c  Start at the origin.
c
      do i = 1, m
        x(i,1) = 0.0D+00
      end do
c
c  Take N - 1 steps.
c
      do j = 2, n
c
c  S is the stepsize.
c
        s = sqrt ( d * dt ) * r8_normal_01 ( seed )
c
c  Direction DX is random, unit norm.
c
        if ( m .eq. 1 ) then
          dx(1) = s
        else
          call r8vec_normal_01 ( m, seed, dx )
          norm_dx = 0.0D+00
          do i = 1, m
            norm_dx = norm_dx + dx(i)**2
          end do
          norm_dx = sqrt ( norm_dx )
          do i = 1, m
            dx(i) = s * dx(i) / norm_dx
          end do
        end if
c
c  Add the step to the current position.
c
        do i = 1, m
          x(i,j) = x(i,j-1) + dx(i)
        end do

      end do

      return
      end
      subroutine get_unit ( iunit )

c*********************************************************************72
c
cc GET_UNIT returns a free FORTRAN unit number.
c
c  Discussion:
c
c    A "free" FORTRAN unit number is a value 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 IUNIT = 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, IUNIT is a value 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    02 September 2013
c
c  Author:
c
c    John Burkardt
c
c  Parameters:
c
c    Output, integer IUNIT, the free unit number.
c
      implicit none

      integer i
      integer iunit
      logical value

      iunit = 0

      do i = 1, 99

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

          inquire ( unit = i, opened = value, err = 10 )

          if ( .not. value ) then
            iunit = i
            return
          end if

        end if

10      continue

      end do

      return
      end
      function i4_uniform ( a, b, seed )

c*********************************************************************72
c
cc I4_UNIFORM 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, a number between A and B.
c
      implicit none

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

      if ( seed .eq. 0 ) then
        write ( *, '(a)' ) ' '
        write ( *, '(a)' ) 'I4_UNIFORM - 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 = value

      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_uniform_01 ( seed )

c*********************************************************************72
c
cc R8_UNIFORM_01 returns a unit pseudorandom R8.
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 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_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 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


module mymodule
    use, intrinsic :: iso_fortran_env, only : dp => REAL64
    use, intrinsic :: iso_fortran_env, only : sp => REAL32
    implicit none

    public :: sum_array, norm_array

contains

    function sum_array(a) result(s)
        implicit none
        real(kind=8), intent(in), dimension(:) :: a
        real(kind=8) :: s
        integer :: i, n
        n = size(a)
        s = 0.0D00
        do i = 1, n
            s = s + a(i)
            write (6,*) a(i)
        end do
    end function sum_array

    subroutine norm_array(a,c,n)
        integer :: n
        real(8),dimension(n),intent(in) :: a
        !f2py optional , depend(a) :: n=len(a)
        real(8),intent(out) :: c
        real(8) :: sommec
        integer :: i
        sommec = 0
        do i=1,n
        sommec=sommec+a( i )*a( i )
        end do
        c=sqrt (sommec)
    end subroutine norm_array

end module mymodule


           program demo_storage_size
           implicit none
              write(*,*)'size of integer ',storage_size(0)
              write(*,*)'size of real    ',storage_size(0.0)
              write(*,*)'size of logical ',storage_size(.true.)
              write(*,*)'size of complex ',storage_size((0.0,0.0))
              write(*,*)'size of integer array ',storage_size([0,1,2,3,4,5,6,7,8,9])
           end program demo_storage_size


program test7
#if (_DP==0)
 use iso_fortran_env,only:int32,int64,wp=>real32
#else
 use iso_fortran_env,only:int32,int64,wp=>real64
#endif
#if (_METIS==1)
 use modmetis,only:METIS_CTYPE_SHEM
#endif
 use modsparse
 implicit none
 integer(kind=int32)::nrow
 integer(kind=int32)::row
 integer(kind=int32)::col
 integer(kind=int32)::iunit, istat
 integer(kind=int32)::i,j
 integer(kind=int32),allocatable::iarray(:,:)
 integer(kind=int32),allocatable::perm(:)
 real(kind=wp)::val
 real(kind=wp),allocatable::x(:),y(:)
 real(kind=wp),allocatable::x2(:,:),y2(:,:)
 real(kind=wp),allocatable::xx(:)
 logical::lup=.false.
 type(coosparse)::coo
 type(crssparse)::crs
 type(crssparse)::crs1

 !!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!
 !COO UPPER
 open(newunit=iunit,file='crsinput.ascii',status='old',action='read')
 read(iunit,*) nrow

 coo=coosparse(5,lupper=.true.)

 do
  read(iunit,*,iostat=istat) row,col,val
  if(istat.ne.0)exit
  call coo%add(row,col,val)
 end do
 close(iunit)

 call coo%add(5,5,1._wp)
 !!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!
 !CSR UPPER
 crs=coo

 call crs%printsquare()

 !perm=crs%getordering()
#if (_METIS==1)
 perm=crs%getordering(compress=1,ctype=METIS_CTYPE_SHEM)
#else
 perm=(/(i,i=1,crs%getdim(1))/)
#endif

 call crs%printstats()

 call crs%setpermutation(perm)
 call crs%printstats()

 allocate(x(crs%getdim(1)),y(crs%getdim(1)))
 do i=1,crs%getdim(1)
  y(i)=i
 enddo
 print*,'y=[',y,' ]'

 x=0._wp
 call crs%solve(x,y)

 !!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!
 !CSR UPPER
 call coo%add(5,5,10._wp)
 call coo%add(2,5,11._wp)
 call coo%add(5,2,11._wp)
 call coo%add(1,5,11._wp)
 call coo%add(5,1,11._wp)

 do i=1,coo%getdim(1)
  call coo%add(i,i,1._wp)
 enddo

 crs1=coo

 call crs1%printsquare()

#if (_METIS==1)
 perm=crs1%getordering(compress=1,ctype=METIS_CTYPE_SHEM)
#else
 perm=(/(i,i=1,crs1%getdim(1))/)
#endif

 call crs1%printstats()

 call crs1%setpermutation(perm)
 call crs1%printstats()

 allocate(xx(crs1%getdim(1)))
 do i=1,crs1%getdim(1)
  y(i)=i
 enddo

 xx=0._wp
 call crs1%solve(xx,y)

 do i=1,crs1%getdim(1)
  write(*,*)x(i),xx(i)
 enddo

 !!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!
 !CSR UPPER
 write(*,'(a)')' Multiple RHS'

 allocate(x2(crs1%getdim(1),5),y2(crs1%getdim(1),5))
 do j=1,5
  do i=1,crs1%getdim(1)
   y2(i,j)=real(i,kind=wp)/j
  enddo
 enddo

 x2=0._wp
 call crs1%solve(x2,y2)

 do i=1,crs1%getdim(1)
  write(*,*)x2(i,:)
 enddo

end program


      SUBROUTINE SG02CX( JOBE, FLAG, JOBG, UPLO, TRANS, N, M, E, LDE, R,
     $                   LDR, S, LDS, G, LDG, ALPHA, RNORM, DWORK,
     $                   LDWORK, IWARN, INFO )
C
C     SLICOT RELEASE 5.7.
C
C     Copyright (c) 2002-2020 NICONET e.V.
C
C     PURPOSE
C
C     To find the line search parameter alpha minimizing the Frobenius
C     norm (in a MATLAB-style notation)
C
C        P(alpha) := norm(R(X+alpha*S), 'fro')
C                  = norm((1-alpha)*R(X) +/- alpha^2*V, 'fro'),
C
C     where R(X) is the residual of a (generalized) continuous-time
C     algebraic Riccati equation
C
C        0 = op(A)'*X + X*op(A) +/- X*G*X + Q  =:  R(X),
C     or
C        0 = op(A)'*X*op(E) + op(E)'*X*op(A) +/- op(E)'*X*G*X*op(E) + Q
C          =:  R(X),
C
C     V = op(E)'*S*G*S*op(E), and op(W) is either W or W'. The matrix S
C     is the Newton step.
C                                                     _-1
C     Instead of the symmetric N-by-N matrix G, G = B*R  *B', the N-by-M
C                      -1
C     matrix D, D = B*L  , such that G = D*D', may be given on entry.
C                _  _
C     The matrix R, R = L'*L, is a weighting matrix of the optimal
C     problem, and L is its (Cholesky) factor.
C
C     Optionally, V is specified as V = H*K, or V = F*F', but F or H and
C     K must be evaluated in S. See the SLICOT Library routine SG02CW
C     description for more details.
C
C     ARGUMENTS
C
C     Mode Parameters
C
C     JOBE    CHARACTER*1
C             Specifies whether E is a general or an identity matrix,
C             as follows:
C             = 'G':  The matrix E is general and is given;
C             = 'I':  The matrix E is assumed identity and is not given.
C
C     FLAG    CHARACTER*1
C             Specifies which sign is used, as follows:
C             = 'P':  The plus sign is used;
C             = 'M':  The minus sign is used.
C
C     JOBG    CHARACTER*1
C             Specifies how the matrix product V is defined, as follows:
C             = 'G':  The matrix G is given:  V = op(E)'*S*G*S*op(E);
C             = 'D':  The matrix D is given:  V = op(E)'*S*D*D'*S*op(E);
C             = 'F':  The matrix F is given:           V = F*F';
C             = 'H':  The matrices H and K are given:  V = H*K.
C
C     UPLO    CHARACTER*1
C             Specifies which triangles of the symmetric matrices R, G,
C             if JOBG = 'G', and S, if JOBG = 'G' or JOBG = 'D', are
C             given, as follows:
C             = 'U':  The upper triangular part is given;
C             = 'L':  The lower triangular part is given.
C
C     TRANS   CHARACTER*1
C             Specifies the form of op(W) to be used in the matrix
C             multiplication, as follows:
C             = 'N':  op(W) = W;
C             = 'T':  op(W) = W';
C             = 'C':  op(W) = W'.
C
C     Input/Output Parameters
C
C     N       (input) INTEGER
C             The order of the matrices E, R, and S.  N >= 0.
C
C     M       (input) INTEGER
C             If JOBG <> 'G', the number of columns of the matrices D,
C             F, or K'.  M >= 0.
C             If JOBG = 'G', the value of M is meaningless.
C
C     E       (input) DOUBLE PRECISION array, dimension (LDE,*)
C             If JOBE = 'G' and (JOBG = 'G' or JOBG = 'D'), the leading
C             N-by-N part of this array must contain the matrix E.
C             If JOBE = 'I' or JOBG = 'F' or JOBG = 'H', this array is
C             not referenced.
C
C     LDE     INTEGER
C             The leading dimension of array E.
C             LDE >= MAX(1,N), if JOBE = 'G' and (JOBG = 'G' or
C                                                 JOBG = 'D');
C             LDE >= 1,        if JOBE = 'I'  or  JOBG = 'F' or
C                                                 JOBG = 'H'.
C
C     R       (input) DOUBLE PRECISION array, dimension (LDR,N)
C             The leading N-by-N upper or lower triangular part
C             (depending on UPLO) of this array must contain the upper
C             or lower triangular part, respectively, of the matrix
C             R(X), the residual of the algebraic Riccati equation.
C             The other strictly triangular part is not referenced.
C
C     LDR     INTEGER
C             The leading dimension of array R.  LDR >= MAX(1,N).
C
C     S       (input) DOUBLE PRECISION array, dimension (LDS,*)
C             If JOBG = 'G' or JOBG = 'D', the leading N-by-N part of
C             this array must contain the symmetric Newton step
C             matrix S. If JOBE = 'I', the full matrix must be given.
C             Otherwise, it is sufficient to input only the triangular
C             part specified by UPLO, and the remaining strictly
C             triangular part is not referenced.
C             If JOBG = 'F', this array is not referenced.
C             If JOBG = 'H', the leading M-by-N part of this array must
C             contain the matrix K.
C
C     LDS     INTEGER
C             The leading dimension of array S.
C             LDS >= MAX(1,N), if JOBG =  'G' or JOBG =  'D';
C             LDS >= 1,        if JOBG =  'F';
C             LDS >= MAX(1,M), if JOBG =  'H'.
C
C     G       (input/works.) DOUBLE PRECISION array, dimension (LDG,*)
C             If JOBG = 'G', the leading N-by-N upper or lower
C             triangular part (depending on UPLO) of this array must
C             contain the upper or lower triangular part, respectively,
C             of the matrix G. The other strictly triangular part is not
C             referenced. The diagonal elements of this array are
C             modified internally, but are restored on exit.
C             If JOBG = 'D', the leading N-by-M part of this array must
C             contain the matrix D, so that G = D*D'.
C             If JOBG = 'F', the leading N-by-M part of this array must
C             contain the matrix F.
C             If JOBG = 'H', leading N-by-M part of this array must
C             contain the matrix H.
C
C     LDG     INTEGER
C             The leading dimension of array G.  LDG >= MAX(1,N).
C
C     ALPHA   (output) DOUBLE PRECISION
C             If INFO = 0, ALPHA contains the real number alpha which
C             minimizes  P(alpha) = norm(R(X+alpha*S), 'fro') in the
C             interval [0,2].
C             If INFO = 1 or IWARN = 2, ALPHA is set equal to 1.
C
C     RNORM   (output) DOUBLE PRECISION
C             On exit, if INFO >= 0, RNORM contains the Frobenius norm
C             of the residual R(X+alpha*S).
C
C     Workspace
C
C     DWORK   DOUBLE PRECISION array, dimension (LDWORK)
C             On exit, if LDWORK = -1 on input, then DWORK(1) returns
C             the optimal value of LDWORK.
C             On exit, if LDWORK = -2 on input or INFO = -19, then
C             DWORK(1) returns the minimal value of LDWORK.
C             On exit, if INFO = 0, the leading N-by-N upper or lower
C             triangular part (depending on UPLO) of this array contains
C             the corresponding triangular part of the matrix V.
C
C     LDWORK  The length of the array DWORK.
C             LDWORK >= N*N + MAX( 2*N*N, 51 ),
C                                       if JOBG = 'G' and JOBE = 'G';
C             LDWORK >= N*N + MAX( N*N, 51 ),
C                                       if JOBG = 'G' and JOBE = 'I',
C                                       or JOBG = 'F', or JOBG = 'H';
C             LDWORK >= N*N + MAX( MAX( N*N, 51 ), MIN( 2*N*N, N*M ) ),
C                                       if JOBG = 'D' and JOBE = 'G';
C             LDWORK >= N*N + MAX( N*N, N*M, 51 ),
C                                       if JOBG = 'D' and JOBE = 'I'.
C             For M <= N, the last two formulas simplify to
C             LDWORK >= N*N + MAX( N*N, 51).
C
C             If LDWORK = -1, an optimal workspace query is assumed; the
C             routine only calculates the optimal size of the DWORK
C             array, returns this value as the first entry of the DWORK
C             array, and no error message is issued by XERBLA.
C
C             If LDWORK = -2, a minimal workspace query is assumed; the
C             routine only calculates the minimal size of the DWORK
C             array, returns this value as the first entry of the DWORK
C             array, and no error message is issued by XERBLA.
C
C     Warning Indicator
C
C     IWARN   INTEGER
C             = 0:  no warnings;
C             = 2:  no optimal line search parameter t := alpha in [0,2]
C                   was found; t = 1 was set.
C
C     Error Indicator
C
C     INFO    INTEGER
C             = 0:  successful exit;
C             < 0:  if INFO = -k, the k-th argument had an illegal
C                   value;
C             = 1:  an error occurred during the call of the SLICOT
C                   Library routine MC01XD: the eigenvalues computation
C                   for the 3-by-3 (generalized) eigenproblem failed.
C                   ALPHA and RNORM are set as specified above.
C
C     METHOD
C
C     The matrix V is computed with the suitable formula, and used to
C     set up a third order polynomial whose roots in [0,2], if any, are
C     candidates for the solution of the minimum residual problem.
C     The roots of the polynomial are computed by solving an equivalent
C     3-by-3 (generalized) eigenproblem.
C
C     REFERENCES
C
C     [1] Benner, P.
C         Contributions to the Numerical Solution of Algebraic
C         Riccati Equations and Related Eigenvalue Problems.
C         Fakultat fur Mathematik, Technische Universitat Chemnitz-
C         Zwickau, D-09107 Chemnitz, Germany, Feb. 1997.
C
C     NUMERICAL ASPECTS
C
C     The calculations are backward stable. The computational effort is
C     of the order of c*N**2*M operations. Here, M = N, if JOBG = 'G',
C     and the coefficient c varies between 0.5 and 2.5, depending on
C     JOBE and JOBG. (An "operation" includes a multiplication, an
C     addition, and some address calculations.)
C     The computed value of norm(R(X+alpha*S),'fro'), returned in RNORM,
C     could be inaccurate if R(X) is small, since then subtraction
C     cancellation could appear in the updating formula which is used.
C     (This can happen, e.g., when solving a Riccati equation by
C     Newton's method with line search, since then the sequence of R(.)
C     tends to zero.) In such a case, it is better to recompute the
C     residual from the data.
C
C     FURTHER COMMENTS
C
C     The routine does not ckeck if the matrix S is zero, when a quick
C     return with ALPHA = 1 is possible.
C     With suitable input arguments E and G, this routine may also be
C     used for discrete-time algebraic Riccati equations. (Matrix E
C     must be the current closed-loop matrix.)
C
C     CONTRIBUTORS
C
C     M. Slowik, Institut fur Mathematik, TU Berlin, July 2005.
C     P. Benner, Institut fur Mathematik, TU Chemnitz, July 2005.
C     V. Sima, Research Institute for Informatics, Bucharest, Nov. 2005.
C
C     REVISIONS
C
C     V. Sima, Jan. 2013, Feb. 2013, Jun. 2013, Dec. 2013, Feb. 2014.
C
C     KEYWORDS
C
C     Algebraic Riccati equation, eigenvalues, generalized eigenproblem.
C
C     ******************************************************************
C
C     .. Parameters ..
      DOUBLE PRECISION  ZERO, ONE, TWO, THREE, FOUR, SIX
      PARAMETER         ( ZERO  = 0.0D0, ONE  = 1.0D0, TWO = 2.0D0,
     $                    THREE = 3.0D0, FOUR = 4.0D0, SIX = 6.0D0 )
C     .. Scalar Arguments ..
      CHARACTER         FLAG, JOBE, JOBG, TRANS, UPLO
      INTEGER           INFO, IWARN, LDE, LDG, LDR, LDS, LDWORK, M, N
      DOUBLE PRECISION  ALPHA, RNORM
C     .. Array Arguments ..
      DOUBLE PRECISION  DWORK(*), E(LDE,*), G(LDG,*), R(LDR,*), S(LDS,*)
C     .. Local Scalars ..
      CHARACTER         NT, NTRANS, SIDE, TR
      LOGICAL           LCND, LFLAG, LJOBE, LJOBF, LJOBG, LJOBH, LJOBL,
     $                  LQUERY, LTRANS, LUPLO, USE1, WWT
      INTEGER           CRITNR, EVIPOS, EVQPOS, EVRPOS, I, J, NM, NMIN,
     $                  NN, NOPT, RPOS, SP
      DOUBLE PRECISION  BETA, DELTA, GAMMA, MX, PA, PB, PC, VNORM
C     .. Local Arrays ..
      DOUBLE PRECISION  CRD(2), CRN(2)
C     .. External Functions ..
      LOGICAL           LSAME
      DOUBLE PRECISION  DDOT, DLANSY
      EXTERNAL          DDOT, DLANSY, LSAME
C     .. External Subroutines ..
      EXTERNAL          DAXPY, DGEMM, DLACPY, DLASCL, DSCAL, DSYMM,
     $                  DSYRK, MB01RB, MB01RU, MC01XD, XERBLA
C     .. Intrinsic Functions ..
      INTRINSIC         ABS, MAX, MIN
C     .. Executable Statements ..
C
C     Test the input scalar arguments.
C
      IWARN = 0
      INFO  = 0
      NN    = N*N
C
      LJOBE  = LSAME( JOBE,  'G' )
      LFLAG  = LSAME( FLAG,  'M' )
      LJOBG  = LSAME( JOBG,  'G' )
      LJOBF  = LSAME( JOBG,  'F' )
      LJOBH  = LSAME( JOBG,  'H' )
      LUPLO  = LSAME( UPLO,  'U' )
      LTRANS = LSAME( TRANS, 'T' ) .OR. LSAME( TRANS, 'C' )
      LJOBL  = LJOBF .OR. LJOBH
C
      IF (      .NOT.LJOBE  .AND. .NOT.LSAME( JOBE,  'I' ) ) THEN
         INFO = -1
      ELSE IF ( .NOT.LFLAG  .AND. .NOT.LSAME( FLAG,  'P' ) ) THEN
         INFO = -2
      ELSE IF ( .NOT.LJOBG  .AND. .NOT.LSAME( JOBG,  'D' ) .AND.
     $          .NOT.LJOBL ) THEN
         INFO = -3
      ELSE IF ( .NOT.LUPLO  .AND. .NOT.LSAME( UPLO,  'L' ) ) THEN
         INFO = -4
      ELSE IF ( .NOT.LTRANS .AND. .NOT.LSAME( TRANS, 'N' ) ) THEN
         INFO = -5
      ELSE IF ( N.LT.0 ) THEN
         INFO = -6
      ELSE IF ( .NOT.LJOBG .AND. M.LT.0 ) THEN
         INFO = -7
      ELSE IF ( LDE.LT.1 .OR. ( LJOBE .AND. .NOT.LJOBL .AND. LDE.LT.N )
     $        ) THEN
         INFO = -9
      ELSE IF ( LDR.LT.MAX( 1, N ) ) THEN
         INFO = -11
      ELSE IF ( LDS.LT.1 .OR. ( LJOBH .AND. LDS.LT.M ) .OR.
     $                   ( .NOT.LJOBL .AND. LDS.LT.N ) ) THEN
         INFO = -13
      ELSE IF ( LDG.LT.MAX( 1, N ) ) THEN
         INFO = -15
      ELSE
C
C        Check the needed size of the workspace.
C
         LQUERY = LDWORK.EQ.-1
         IF ( LJOBL ) THEN
            NMIN = NN + MAX( NN, 51 )
            IF ( LQUERY )
     $         NOPT = NMIN
         ELSE IF ( LJOBG ) THEN
            IF ( LJOBE ) THEN
               NMIN = NN + MAX( 2*NN, 51 )
            ELSE
               NMIN = NN + MAX( NN, 51 )
            END IF
            IF ( LQUERY )
     $         NOPT = NMIN
         ELSE
            NM = N*M
            IF ( LJOBE ) THEN
               NMIN = NN + MAX( MAX( NN, 51 ), MIN( 2*NN, NM ) )
               LCND = 2*M.GT.3*N
               IF ( LQUERY ) THEN
                  IF ( LCND ) THEN
                     NOPT = 3*NN
                  ELSE
                     NOPT = NN + NM
                  END IF
               END IF
            ELSE
               NMIN = NN + MAX( NN, NM, 51 )
               LCND = M.GT.3*N
               IF ( LQUERY ) THEN
                  IF ( LCND ) THEN
                     NOPT = 2*NN
                  ELSE
                     NOPT = NN + NM
                  END IF
               END IF
            END IF
            IF ( LQUERY )
     $         NOPT = MAX( NOPT, NMIN )
         END IF
         IF ( LQUERY ) THEN
C
C           The array DWORK should have at least 3 entries here.
C
            CALL MC01XD( ALPHA, BETA, GAMMA, DELTA, DWORK, DWORK, DWORK,
     $                   DWORK, -1, INFO )
            NOPT = MAX( NOPT, NN + 9 + INT( DWORK(1) ) )
            DWORK(1) = NOPT
            RETURN
         ELSE IF ( LDWORK.EQ.-2 ) THEN
            DWORK(1) = NMIN
            RETURN
         ELSE IF ( LDWORK.LT.NMIN ) THEN
            INFO = -19
            DWORK(1) = NMIN
         END IF
      END IF
C
      IF ( INFO.NE.0 ) THEN
C
C        Error return.
C
         CALL XERBLA( 'SG02CX', -INFO )
         RETURN
      END IF
C
C     Quick return if possible.
C
      IF ( N.EQ.0 .OR. ( .NOT.LJOBG .AND. M.EQ.0 ) ) THEN
         ALPHA = ONE
         RNORM = ZERO
         RETURN
      END IF
C
      RNORM = DLANSY( 'F-norm', UPLO, N, R, LDR, DWORK )
      IF ( RNORM.EQ.ZERO ) THEN
         ALPHA = ZERO
         RETURN
      END IF
C
C     Initialize scalar arguments for the called routines.
C
      NT = 'No transpose'
      IF ( LJOBE ) THEN
         TR = 'Transpose'
         IF ( LTRANS ) THEN
            SIDE   = 'Right'
            NTRANS = NT
         ELSE
            SIDE   = 'Left'
            NTRANS = TR
         END IF
      END IF
C
C     Initialize DWORK positions.
C
      SP = NN + 1
C
C     Compute the matrix
C
C       V = op(E)'*S*G*S*op(E), or
C       V = op(E)'*S*D*D'*S*op(E), or
C       V = F*F', or V = H*K.
C
      IF ( LJOBL ) THEN
C
C        Compute F*F' or H*K.
C
C        Workspace: N*N.
C
         IF ( LJOBF ) THEN
            CALL DSYRK( UPLO, NT, N, M, ONE, G, LDG, ZERO, DWORK, N )
         ELSE
            CALL MB01RB( 'Left', UPLO, NT, N, M, ZERO, ONE, DWORK, N, G,
     $                   LDG, S, LDS, INFO )
        END IF
C
      ELSE IF ( LJOBG ) THEN
         IF ( LJOBE ) THEN
C
C           Compute the following steps, if TRANS = 'N'
C           1.  W = S*E       (stored in DWORK(SP));
C           2.  V = W'*G*W    (stored in DWORK).
C
C           Compute the following steps, if TRANS = 'T'
C           1.  W = E*S       (stored in DWORK(SP));
C           2.  V = W*G*W'    (stored in DWORK).
C
C           Workspace: 3*N*N.
C
            CALL DSYMM(  SIDE, UPLO, N, N, ONE, S, LDS, E, LDE,
     $                   ZERO, DWORK(SP), N )
            CALL MB01RU( UPLO, NTRANS, N, N, ZERO, ONE, DWORK, N,
     $                   DWORK(SP), N, G, LDG, DWORK(SP+NN), NN, INFO )
         ELSE
C
C           Compute V = S*G*S    (stored in DWORK).
C
C           Workspace: 2*N*N.
C
            CALL MB01RU( UPLO, NT, N, N, ZERO, ONE, DWORK, N, S, LDS, G,
     $                   LDG, DWORK(SP), NN, INFO )
         END IF
C
      ELSE
C
         WWT = N.GE.M
         IF ( LJOBE ) THEN
            USE1 = LCND .AND. LDWORK.GE.3*NN
C
            IF ( USE1 ) THEN
C
C              Compute
C                 Y = D*D'                 in DWORK,
C                 W = S*E or W = E*S       in DWORK(SP),
C                 V = W'*Y*W or V = W*Y*W' in DWORK.
C
C              Workspace: 3*N*N.
C
               CALL DSYMM(  SIDE, UPLO, N, N, ONE, S, LDS, E, LDE, ZERO,
     $                      DWORK(SP), N )
               CALL DSYRK(  UPLO, NT, N, M, ONE, G, LDG, ZERO, DWORK,
     $                      N )
               CALL MB01RU( UPLO, NTRANS, N, N, ZERO, ONE, DWORK, N,
     $                      DWORK(SP), N, DWORK, N, DWORK(SP+NN), NN,
     $                      INFO )
               CALL DSCAL(  N, ONE/TWO, DWORK, N+1 )
C
            ELSE IF ( WWT ) THEN
C
C              Compute W = S*D               (stored in DWORK);
C              Compute W = E'*W or W = E*W   (stored in DWORK(SP)).
C
C              Workspace (including for W*W'):  N*N + N*M.
C
               CALL DSYMM( 'Left', UPLO, N, M, ONE, S, LDS, G, LDG,
     $                     ZERO, DWORK, N )
C
               CALL DGEMM( NTRANS, NT, N, M, N, ONE, E, LDE, DWORK, N,
     $                     ZERO, DWORK(SP), N )
            ELSE
C
C              Compute W = S*E  or W = E*S   (stored in DWORK);
C              Compute W = D'*W or W = W*D   (stored in DWORK(SP)).
C
C              Workspace (including for W'*W):  N*N + N*M.
C
               CALL DSYMM( SIDE, UPLO, N, N, ONE, S, LDS, E, LDE,
     $                     ZERO, DWORK, N )
C
               IF ( LTRANS ) THEN
                  CALL DGEMM( NT, NT, N, M, N, ONE, DWORK, N, G, LDG,
     $                        ZERO, DWORK(SP), N )
               ELSE
                  CALL DGEMM( TR, NT, M, N, N, ONE, G, LDG, DWORK, N,
     $                        ZERO, DWORK(SP), M )
               END IF
            END IF
C
         ELSE
            USE1 = LCND .OR. LDWORK.LT.NN + NM
C
            IF ( USE1 ) THEN
C
C              Compute
C                 Y = D*D'   in DWORK,
C                 W = S*Y*S  in DWORK.
C
C              Workspace: 2*N*N.
C
               CALL DSYRK(  UPLO, NT, N, M, ONE, G, LDG, ZERO, DWORK,
     $                      N )
               CALL MB01RU( UPLO, NT, N, N, ZERO, ONE, DWORK, N, S, LDS,
     $                      DWORK, N, DWORK(SP), NN, INFO )
               CALL DSCAL(  N, ONE/TWO, DWORK, N+1 )
C
            ELSE
C
C              Compute W = S*D        (stored in DWORK(SP)).
C
C              Workspace (including for W*W'): N*M + N*N.
C
               CALL DSYMM( 'Left', UPLO, N, M, ONE, S, LDS, G, LDG,
     $                     ZERO, DWORK(SP), N )
            END IF
         END IF
C
C        Compute V = W*W' or V = W'*W       (stored in DWORK).
C
         IF ( .NOT.USE1 ) THEN
            IF ( WWT .OR. .NOT.LJOBE .OR. LTRANS ) THEN
               CALL DSYRK( UPLO, NT, N, M, ONE, DWORK(SP), N, ZERO,
     $                     DWORK, N )
            ELSE
               CALL DSYRK( UPLO, NTRANS, N, M, ONE, DWORK(SP), M, ZERO,
     $                     DWORK, N )
            END IF
         END IF
      END IF
C
C     Initialize scalar values.
C
      PB = ZERO
      CRITNR = 0
C
C     Compute the parameters alpha, beta, gamma.
C
      VNORM = DLANSY( 'F-norm', UPLO, N, DWORK, N, DWORK )
C
      MX = MAX( ONE, RNORM, VNORM )
      PA = ( RNORM/MX )*( RNORM/MX )
C
      I = 1
C
      IF ( LUPLO ) THEN
C
         DO 10 J = 1, N
            PB = PB + TWO*DDOT( J-1, R(1,J), 1, DWORK(I), 1 )/MX/MX +
     $           ( R(J,J)/MX )*( DWORK(I+J-1)/MX )
            I  = I + N
   10    CONTINUE
C
      ELSE
C
         DO 20 J = 1, N - 1
            PB = PB + ( R(J,J)/MX )*( DWORK(I)/MX ) +
     $           TWO*DDOT( N-J, R(J+1,J), 1, DWORK(I+1), 1 )/MX/MX
            I  = I + N + 1
   20    CONTINUE
C
         PB = PB + ( R(N,N)/MX )*( DWORK(I)/MX )
      END IF
C
C     Compute the coefficients of the derivative polynomial.
C
      ALPHA = -TWO*PA
      IF ( LFLAG ) THEN
         BETA  =  TWO*( PA - TWO*PB )
         GAMMA =  SIX*PB
      ELSE
         BETA  =  TWO*( PA + TWO*PB )
         GAMMA = -SIX*PB
      END IF
      DELTA = FOUR*( VNORM/MX )*( VNORM/MX )
C
C     Compute the roots of the polynomial.
C
C     Workspace: N*N + 51.
C
      EVRPOS = SP
      EVIPOS = EVRPOS + 3
      EVQPOS = EVIPOS + 3
      RPOS   = EVQPOS + 3
C
      CALL MC01XD( ALPHA, BETA, GAMMA, DELTA, DWORK(EVRPOS),
     $             DWORK(EVIPOS), DWORK(EVQPOS), DWORK(RPOS),
     $             LDWORK-RPOS+1, INFO )
C
      IF ( INFO.NE.0 ) THEN
         INFO  = 1
         ALPHA = ONE
         RNORM = VNORM
         RETURN
      END IF
C
C     Find the global minimum of the polynomial in [0,2], if it exists.
C
      DO 30 J = 0, 2
C
C        Check if EVR(J+1)/EVQ(J+1) is a critical value.
C
         IF ( DWORK(EVIPOS+J).EQ.ZERO )  THEN
C
C           Check if EVR(J+1)/EVQ(J+1) is in [0,2].
C
            PA = DWORK(EVRPOS+J)
            PB = DWORK(EVQPOS+J)
            IF ( PA.GE.ZERO .AND. PB.GT.ZERO .AND. PA.LE.TWO*PB ) THEN
C
C              Check the second derivative (min or max).
C
               MX = MAX( ABS( BETA ), ABS( GAMMA ), DELTA, ABS( PA ),
     $                   ABS( PB ) )
               IF ( MX.GT.ZERO ) THEN
                  PA = PA/MX
                  PB = PB/MX
                  PC = ( BETA/MX )*PB*PB + TWO*( GAMMA/MX )*PA*PB +
     $                                   THREE*( DELTA/MX )*PA*PA
                  IF ( PC.GT.ZERO ) THEN
                     CRITNR = CRITNR + 1
                     CRN(CRITNR) = DWORK(EVRPOS+J)
                     CRD(CRITNR) = DWORK(EVQPOS+J)
                  END IF
               END IF
            END IF
         END IF
   30 CONTINUE
C
      IF ( CRITNR.EQ.0 ) THEN
C
C        No minimum is found in [0,2].
C
         IWARN = 2
         ALPHA = ONE
         RNORM = VNORM
         RETURN
      END IF
C
C     Compute the norm of R(X+ALPHA*S).
C
C     Workspace: 2*N*N.
C
      ALPHA = CRN(1)/CRD(1)
      PA    = ONE - ALPHA
C
      CALL DLACPY( UPLO, N, N, R, LDR, DWORK(SP), N )
      CALL DLASCL( UPLO, 1, 1, ONE, PA, N, N, DWORK(SP), N, INFO )
C
      IF ( LFLAG ) THEN
         PA = -ALPHA*ALPHA
      ELSE
         PA =  ALPHA*ALPHA
      END IF
      I  = 0
C
      IF ( LUPLO ) THEN
C
         DO 40 J = 1, N
            CALL DAXPY( J, PA, DWORK(I+1), 1, DWORK(SP+I), 1 )
            I = I + N
   40    CONTINUE
C
      ELSE
C
         DO 50 J = 1, N
            CALL DAXPY( N-J+1, PA, DWORK(I+1), 1, DWORK(SP+I), 1 )
            I = I + N + 1
   50    CONTINUE
C
      END IF
C
      RNORM = DLANSY( 'F-norm', UPLO, N, DWORK(SP), N, DWORK )
C
C     If two local minima are found in [0,2], choose the one for which
C     the norm of R(X+t*S) is minimal.
C
      IF ( CRITNR.EQ.2 ) THEN
         BETA = CRN(2)/CRD(2)
         PB   = ONE - BETA
C
         CALL DLACPY( UPLO, N, N, R, LDR, DWORK(SP), N )
         CALL DLASCL( UPLO, 1, 1, ONE, PB, N, N, DWORK(SP), N, INFO )
C
         IF ( LFLAG ) THEN
            PB = -BETA*BETA
         ELSE
            PB =  BETA*BETA
         END IF
         I  = 0
C
         IF ( LUPLO ) THEN
C
            DO 60 J = 1, N
               CALL DAXPY( J, PB, DWORK(I+1), 1, DWORK(SP+I), 1 )
               I = I + N
   60       CONTINUE
C
         ELSE
C
            DO 70 J = 1, N
               CALL DAXPY( N-J+1, PB, DWORK(I+1), 1, DWORK(SP+I), 1 )
               I = I + N + 1
   70       CONTINUE
C
         END IF
C
         VNORM = DLANSY( 'F-norm', UPLO, N, DWORK(SP), N, DWORK )
C
         IF ( VNORM.LT.RNORM ) THEN
            ALPHA = BETA
            RNORM = VNORM
         END IF
      END IF
C
      RETURN
C *** Last line of SG02CX ***
      END


      SUBROUTINE MB04JD( N, M, P, L, A, LDA, B, LDB, TAU, DWORK, LDWORK,
     $                   INFO )
C
C     SLICOT RELEASE 5.7.
C
C     Copyright (c) 2002-2020 NICONET e.V.
C
C     PURPOSE
C
C     To compute an LQ factorization of an n-by-m matrix A (A = L * Q),
C     having a min(n,p)-by-p zero triangle in the upper right-hand side
C     corner, as shown below, for n = 8, m = 7, and p = 2:
C
C            [ x x x x x 0 0 ]
C            [ x x x x x x 0 ]
C            [ x x x x x x x ]
C            [ x x x x x x x ]
C        A = [ x x x x x x x ],
C            [ x x x x x x x ]
C            [ x x x x x x x ]
C            [ x x x x x x x ]
C
C     and optionally apply the transformations to an l-by-m matrix B
C     (from the right). The problem structure is exploited. This
C     computation is useful, for instance, in combined measurement and
C     time update of one iteration of the time-invariant Kalman filter
C     (square root covariance filter).
C
C     ARGUMENTS
C
C     Input/Output Parameters
C
C     N       (input) INTEGER
C             The number of rows of the matrix A.  N >= 0.
C
C     M       (input) INTEGER
C             The number of columns of the matrix A.  M >= 0.
C
C     P       (input) INTEGER
C             The order of the zero triagle.  P >= 0.
C
C     L       (input) INTEGER
C             The number of rows of the matrix B.  L >= 0.
C
C     A       (input/output) DOUBLE PRECISION array, dimension (LDA,M)
C             On entry, the leading N-by-M part of this array must
C             contain the matrix A. The elements corresponding to the
C             zero MIN(N,P)-by-P upper trapezoidal/triangular part
C             (if P > 0) are not referenced.
C             On exit, the elements on and below the diagonal of this
C             array contain the N-by-MIN(N,M) lower trapezoidal matrix
C             L (L is lower triangular, if N <= M) of the LQ
C             factorization, and the relevant elements above the
C             diagonal contain the trailing components (the vectors v,
C             see Method) of the elementary reflectors used in the
C             factorization.
C
C     LDA     INTEGER
C             The leading dimension of array A.  LDA >= MAX(1,N).
C
C     B       (input/output) DOUBLE PRECISION array, dimension (LDB,M)
C             On entry, the leading L-by-M part of this array must
C             contain the matrix B.
C             On exit, the leading L-by-M part of this array contains
C             the updated matrix B.
C             If L = 0, this array is not referenced.
C
C     LDB     INTEGER
C             The leading dimension of array B.  LDB >= MAX(1,L).
C
C     TAU     (output) DOUBLE PRECISION array, dimension MIN(N,M)
C             The scalar factors of the elementary reflectors used.
C
C     Workspace
C
C     DWORK   DOUBLE PRECISION array, dimension (LDWORK)
C             On exit, if INFO = 0, DWORK(1) returns the optimal value
C             of LDWORK.
C
C     LDWORK  The length of the array DWORK.
C             LDWORK >= MAX(1,N-1,N-P,L).
C             For optimum performance LDWORK should be larger.
C
C     Error Indicator
C
C     INFO    INTEGER
C             = 0:  successful exit;
C             < 0:  if INFO = -i, the i-th argument had an illegal
C                   value.
C
C     METHOD
C
C     The routine uses min(N,M) Householder transformations exploiting
C     the zero pattern of the matrix.  A Householder matrix has the form
C
C                                     ( 1 ),
C        H  = I - tau *u *u',    u  = ( v )
C         i          i  i  i      i   (  i)
C
C     where v  is an (M-P+I-2)-vector.  The components of v  are stored
C            i                                             i
C     in the i-th row of A, beginning from the location i+1, and tau
C                                                                   i
C     is stored in TAU(i).
C
C     NUMERICAL ASPECTS
C
C     The algorithm is backward stable.
C
C     CONTRIBUTORS
C
C     V. Sima, Katholieke Univ. Leuven, Belgium, Feb. 1997.
C
C     REVISIONS
C
C     -
C
C     KEYWORDS
C
C     Elementary reflector, LQ factorization, orthogonal transformation.
C
C     ******************************************************************
C
C     .. Parameters ..
      DOUBLE PRECISION  ZERO, ONE
      PARAMETER         ( ZERO = 0.0D0, ONE = 1.0D0 )
C     .. Scalar Arguments ..
      INTEGER           INFO, L, LDA, LDB, LDWORK, M, N, P
C     .. Array Arguments ..
      DOUBLE PRECISION  A(LDA,*), B(LDB,*), DWORK(*), TAU(*)
C     .. Local Scalars ..
      INTEGER           I
      DOUBLE PRECISION  FIRST, WRKOPT
C     .. External Subroutines ..
      EXTERNAL          DGELQF, DLARF, DLARFG, DORMLQ, XERBLA
C     .. Intrinsic Functions ..
      INTRINSIC         DBLE, MAX, MIN
C     .. Executable Statements ..
C
C     Test the input scalar arguments.
C
      INFO = 0
      IF( N.LT.0 ) THEN
         INFO = -1
      ELSE IF( M.LT.0 ) THEN
         INFO = -2
      ELSE IF( P.LT.0 ) THEN
         INFO = -3
      ELSE IF( L.LT.0 ) THEN
         INFO = -4
      ELSE IF( LDA.LT.MAX( 1, N ) ) THEN
         INFO = -6
      ELSE IF( LDB.LT.MAX( 1, L ) ) THEN
         INFO = -8
      ELSE IF( LDWORK.LT.MAX( 1, N - 1, N - P, L ) ) THEN
         INFO = -11
      END IF
C
      IF ( INFO.NE.0 ) THEN
C
C        Error return.
C
         CALL XERBLA( 'MB04JD', -INFO )
         RETURN
      END IF
C
C     Quick return if possible.
C
      IF( MIN( M, N ).EQ.0 ) THEN
         DWORK(1) = ONE
         RETURN
      ELSE IF( M.LE.P+1 ) THEN
         DO 5 I = 1, MIN( N, M )
            TAU(I) = ZERO
    5    CONTINUE
         DWORK(1) = ONE
         RETURN
      END IF
C
C     Annihilate the superdiagonal elements of A and apply the
C     transformations to B, if L > 0.
C     Workspace: need MAX(N-1,L).
C
C     (Note: Comments in the code beginning "Workspace:" describe the
C     minimal amount of real workspace needed at that point in the
C     code, as well as the preferred amount for good performance.
C     NB refers to the optimal block size for the immediately
C     following subroutine, as returned by ILAENV.)
C
      DO 10 I = 1, MIN( N, P )
C
C        Exploit the structure of the I-th row of A.
C
         CALL DLARFG( M-P, A(I,I), A(I,I+1), LDA, TAU(I) )
         IF( TAU(I).NE.ZERO ) THEN
C
            FIRST = A(I,I)
            A(I,I) = ONE
C
            IF ( I.LT.N ) CALL DLARF( 'Right', N-I, M-P, A(I,I), LDA,
     $                                TAU(I), A(I+1,I), LDA, DWORK )
            IF ( L.GT.0 ) CALL DLARF( 'Right', L, M-P, A(I,I), LDA,
     $                                TAU(I), B(1,I), LDB, DWORK )
C
            A(I,I) = FIRST
         END IF
   10 CONTINUE
C
      WRKOPT = MAX( ONE, DBLE( N - 1 ), DBLE( L ) )
C
C     Fast LQ factorization of the remaining trailing submatrix, if any.
C     Workspace: need N-P;  prefer (N-P)*NB.
C
      IF( N.GT.P ) THEN
         CALL DGELQF( N-P, M-P, A(P+1,P+1), LDA, TAU(P+1), DWORK,
     $                LDWORK, INFO )
         WRKOPT = MAX( WRKOPT, DWORK(1) )
C
         IF ( L.GT.0 ) THEN
C
C           Apply the transformations to B.
C           Workspace: need L;  prefer L*NB.
C
            CALL DORMLQ( 'Right', 'Transpose', L, M-P, MIN(N,M)-P,
     $                   A(P+1,P+1), LDA, TAU(P+1), B(1,P+1), LDB,
     $                   DWORK, LDWORK, INFO )
            WRKOPT = MAX( WRKOPT, DWORK(1) )
         END IF
      END IF
C
      DWORK(1) = WRKOPT
      RETURN
C *** Last line of MB04JD ***
      END


Program main
Integer i, j, k, fmrow, fmcol, smrow, smcol
Integer, Dimension(1000, 1000) :: fm
Integer, Dimension(1000, 1000) :: sm
Integer, Dimension(1000, 1000) :: res
Character anykey
REAL T1, T2

fmrow = 1000
fmcol = 1000
smrow = 1000
smcol = 1000

Open(10, file = 'Data01.txt', status='old')
Print *, 'Reading Data01.txt'
Do i = 1, fmrow
    Do j = 1, fmcol
        Read (10, *) fm(i, j)
    End Do
End Do
Close(UNIT = 10)

Open(20, file = 'Data02.txt', status='old')

Print *, 'Reading Data02.txt'
Do i = 1, smrow
    Do j = 1, smcol
        Read (20, *) sm(i, j)
    End Do
End Do
Close(UNIT = 20)

Print *, 'Calculating fm * sm.. loop k->j->i'
CALL CPU_TIME(T1)

Do k = 1, smrow
    Do j = 1, smcol
        Do i = 1, fmrow
            res(i, j) = res(i, j) + (fm(i, k) * sm(k, j))
        End Do
    End Do
End Do

CALL CPU_TIME(T2)

Print *, 'Calculate Time : ', T2-T1, 'Second'

Print *, 'Press Any Key and Enter Key'
Read *, anykey

End Program


c~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~
c Slope calculation routine. Designed to be called from python
c
c Daniel Clewley (daniel.clewley@gmail.com) - 27/06/2013
c
c Copyright 2014 Daniel Clewley & Jane Whitcomb.
c
c Permission is hereby granted, free of charge, to any person
c obtaining a copy of this software and associated documentation
c files (the "Software"), to deal in the Software without restriction,
c including without limitation the rights to use, copy, modify,
c merge, publish, distribute, sublicense, and/or sell copies of the
c Software, and to permit persons to whom the Software is furnished
c to do so, subject to the following conditions:
c
c The above copyright notice and this permission notice shall be
c included in all copies or substantial portions of the Software.
c
c THE SOFTWARE IS PROVIDED "AS IS", WITHOUT WARRANTY OF ANY KIND,
c EXPRESS OR IMPLIED, INCLUDING BUT NOT LIMITED TO THE WARRANTIES
c OF MERCHANTABILITY, FITNESS FOR A PARTICULAR PURPOSE AND NONINFRINGEMENT.
c IN NO EVENT SHALL THE AUTHORS OR COPYRIGHT HOLDERS BE LIABLE FOR
c ANY CLAIM, DAMAGES OR OTHER LIABILITY, WHETHER IN AN ACTION OF
c CONTRACT, TORT OR OTHERWISE, ARISING FROM, OUT OF OR IN CONNECTION
c WITH THE SOFTWARE OR THE USE OR OTHER DEALINGS IN THE SOFTWARE.
c
c~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~

      subroutine slope(inBlock, xSizes, ySizes, width, height, zScale
     1    , outBlock)
c     slope routine - standard slope calculation

c     f2py will figure out width and height are the array size and set
c     automatically so these don't need to be passed in.

      implicit none

      integer x, y
      real pi
      real dx, dy, dzx, dzy
      real nx, ny, nz
      real slopeRad, slopeDeg
      integer width, height
      real zScale

c     Array of x and y sizes is 2 pixels smaller than data array (for overlap)
      real inBlock(height,width)
      real outBlock(height,width)
      real xSizes(height, width)
      real ySizes(height, width)

      pi = 3.14159265

c     Tell f2py that outBlock is the output

Cf2py intent(out) outBlock

      do x=2,width-1
        do y=2,height-1
c           Get pixel size
            dx = 2 * xSizes(y,x)
            dy = 2 * ySizes(y,x)
c            Calculate difference in elevation
            dzx = (inBlock(y,x-1) - inBlock(y,x+1))*zScale
            dzy = (inBlock(y-1,x) - inBlock(y+1,x))*zScale

c            Find normal vector to the plane
            nx = -1 * dy * dzx
            ny = -1 * dx * dzy
            nz = dx * dy

            slopeRad = acos(nz / sqrt(nx**2 + ny**2 + nz**2))
            slopeDeg = (180. / pi) * slopeRad

            outBlock(y,x) = slopeDeg
        end do

      end do

      return
      end

      subroutine slopeplane(inBlock, xSizes, ySizes, width, height,
     1       zScale, outBlock, winSize)
c     slopeplane routine - slope calculation using least squares
c     to fit a plane to elevation.

c     f2py will figure out width and height are the array size and set
c     automatically so these don't need to be passed in.

      implicit none

      external sgels
      intrinsic int, min

      integer x, y, i, j, indx
      integer winSize, winOffset
      real pi
      real dx, dy, dzx, dzy
      real nx, ny, nz
      real slopeRad, slopeDeg
      integer nRows, nCols
      integer width, height
      real zScale
      integer lwork, info

c     Array of x and y sizes is 2 pixels smaller than data array (for overlap)
      real inBlock(height,width)
      real outBlock(height,width)
      real xSizes(height, width)
      real ySizes(height, width)
      parameter (nCols = 3)
      real AMat(winSize**2,nCols)
      real zVec(winSize**2)
      real work(winSize**2*nCols*2)
      nRows = winSize**2

      winOffset=winSize/2

      pi = 3.14159265

c     Tell f2py that outBlock is the output

Cf2py intent(out) outBlock

      indx=1
      do x=winOffset,width-winOffset
        do y=winOffset,height-winOffset
c           Get pixel size
            dx = winSize * xSizes(y,x)
            dy = winSize * ySizes(y,x)

c           Calculate difference in elevation

c           Set up matrices for plane fitting

            indx = 1
            do i=(-1*winOffset),(winOffset)
                do j=(-1*winOffset),(winOffset)

                    AMat(indx,1) = (i*xSizes(y,x))
                    AMat(indx,2) = (j*ySizes(y,x))
                    AMat(indx,3) = 1

                    zVec(indx) = inBlock(y+j,x+i)*zScale

                    indx=indx+1

                end do
            end do

c           Fit plane
            dzx=1.
            dzy=1.

            lwork=-1
c           Get optimal value for work array
            call sgels('N', nRows,nCols,1,AMat,nRows,zVec,nRows,work,
     1         lwork, info)
            lwork=int(work(1))
c           Actual fitting
            call sgels('N', nRows,nCols,1,AMat,nRows,zVec,nRows,work,
     1         lwork, info)

c           Calculate dzx and dzy from coefficients of fit
            dzx = zVec(1) * dx
            dzy = zVec(2) * dy

c            Find normal vector to the plane
            nx = -1 * dy * dzx
            ny = -1 * dx * dzy
            nz = dx * dy

            slopeRad = acos(nz / sqrt(nx**2 + ny**2 + nz**2))
            slopeDeg = (180. / pi) * slopeRad

            outBlock(y,x) = slopeDeg
        end do

      end do

      return
      end


! quasirandom.f90 --
!     Generate points in a unit hypercube that are distributed
!     quasi-randomly. The algorithm is based on:
!     "The Unreasonable Effectiveness of Quasirandom Sequences" by Martin Roberts,
!     http://extremelearning.com.au/unreasonable-effectiveness-of-quasirandom-sequences/
!
!     TODO:
!     Support for points on a circle, disk, sphere or ball
!     Integration
!
module quasirandom
    implicit none

    private
    public :: quasirandom_generator

    integer, parameter :: dp = kind(1.0d0)

    ! Implementation still to be done
    integer, parameter, public :: quasi_circle = -1
    integer, parameter, public :: quasi_disk   = -2
    integer, parameter, public :: quasi_sphere = -3
    integer, parameter, public :: quasi_ball   = -4

    type quasirandom_generator
        integer :: dimin    = -1
        integer :: step     = 1
        integer :: stepsize = 1
        real(kind=dp), dimension(:), allocatable :: factor
    contains
        procedure :: init => init_quasi
        procedure :: restart => restart_quasi
        procedure :: single_next => single_next_quasi
        procedure :: double_next => double_next_quasi
        generic   :: next => single_next, double_next
    end type quasirandom_generator

contains

! init_quasi --
!     Set the dimension and the start point for the quasi-random generator
!
! Arguments:
!     dim                 Dimension of the space for which to generate the points
!     stepsize            (Optional) use a different step than 1 to select the next point
!
subroutine init_quasi( this, dimin, stepsize )
    class(quasirandom_generator)  :: this
    integer, intent(in)           :: dimin
    integer, intent(in), optional :: stepsize

    integer                       :: i, n, dim
    real(kind=dp)                 :: f

    if ( present(stepsize) ) then
        this%stepsize = stepsize
    else
        this%stepsize = 1
    endif

    if ( dimin == 0 .or. dimin < quasi_ball ) then
        write(*,*) 'Quasirandom numbers: Dimension must be positive!'
        return
    endif

    select case ( dimin )
        case( quasi_circle )
            dim = 1
        case( quasi_disk )
            dim = 2
        case( quasi_sphere )
            dim = 2
        case( quasi_ball )
            dim = 3
        case default
            dim = dimin
    end select

    this%dimin = dimin

    if ( allocated(this%factor) ) then
        deallocate( this%factor )
    endif
    allocate( this%factor(dim) )

    !
    ! Solve the equation x**n - x + 1 = 0
    !
    n = dim + 1
    f = 1.0_dp
    do i = 1,10
        f = f - (f**n - f - 1.0_dp) / (n*f**(n-1)-1.0_dp)
    enddo

    this%factor(1) = 1.0_dp / f

    do i = 2,dim
        this%factor(i) = this%factor(i-1) / f
    enddo
end subroutine init_quasi

! restart_quasi --
!     Restart the generator
!
! Arguments:
!     start               (Optional) Starting point (simply the n'th point that would be generated)
!     stepsize            (Optional) use a different step than 1 to select the next point
!
subroutine restart_quasi( this, start, stepsize )
    class(quasirandom_generator)  :: this
    integer, intent(in), optional :: start
    integer, intent(in), optional :: stepsize

    if ( present(start) ) then
        this%step = start
    else
        this%step = 1
    endif

    if ( present(stepsize) ) then
        this%stepsize = stepsize
    else
        this%stepsize = 1
    endif
end subroutine restart_quasi

! single_next_quasi --
!     Generate the next point (single-precision reals)
!
! Arguments:
!     coords              Array for holding the new coordinates
!
subroutine single_next_quasi( this, coords )
    class(quasirandom_generator)    :: this
    real, dimension(:), intent(out) :: coords

    coords = modulo( this%step * this%factor, 1.0_dp )

    if ( this%dimin < 0 ) then
        call single_transform( this%dimin, coords )
    endif

    this%step = this%step + this%stepsize

end subroutine single_next_quasi

! double_next_quasi --
!     Generate the next point (double-precision reals)
!
! Arguments:
!     coords              Array for holding the new coordinates
!
subroutine double_next_quasi( this, coords )
    class(quasirandom_generator)             :: this
    real(kind=dp), dimension(:), intent(out) :: coords

    coords = modulo( this%step * this%factor, 1.0_dp )

    if ( this%dimin < 0 ) then
        call double_transform( this%dimin, coords )
    endif

    this%step = this%step + this%stepsize

end subroutine double_next_quasi

! single_transform --
!     Transform the coordinates to the required shape
!
subroutine single_transform( type, coords )
    integer, intent(in)               :: type
    real, dimension(:), intent(inout) :: coords

    real, parameter                   :: twopi = 2.0 * acos(-1.0)
    real                              :: x, y, z, r, theta, phi

    select case( type )
        case( quasi_circle )
            x = cos( twopi * coords(1) )
            y = sin( twopi * coords(1) )
            coords = [x, y]

        case( quasi_disk )
            x = sqrt(coords(1)) * cos( twopi * coords(2) )
            y = sqrt(coords(1)) * sin( twopi * coords(2) )
            coords = [x, y]

        case( quasi_sphere )
            theta = asin( 2.0 * coords(1) - 1.0 )
            phi   = twopi * coords(2)
            x     = cos(phi) * cos(theta)
            y     = sin(phi) * cos(theta)
            z     = 2.0 * coords(1) - 1.0 ! sin(theta)
            coords = [ x, y, z ]

        case( quasi_ball )
            theta = asin( 2.0 * coords(1) - 1.0 )
            phi   = twopi * coords(2)
            r     = coords(3) ** (1.0/3.0)
            x     = cos(phi) * cos(theta)
            y     = sin(phi) * cos(theta)
            z     = 2.0 * coords(1) - 1.0 ! sin(theta)
            coords = r * [ x, y, z ]
     end select
end subroutine single_transform

! double_transform --
!     Transform the coordinates to the required shape (double precision)
!
subroutine double_transform( type, coords )
    integer, intent(in)                   :: type
    real(dp), dimension(:), intent(inout) :: coords

    real(dp), parameter                   :: twopi = 2.0_dp * acos(-1.0_dp)
    real(dp)                              :: x, y, z, r, theta, phi

    select case( type )
        case( quasi_circle )
            x = cos( twopi * coords(1) )
            y = sin( twopi * coords(1) )
            coords = [x, y]

        case( quasi_disk )
            x = sqrt(coords(1)) * cos( twopi * coords(2) )
            y = sqrt(coords(1)) * sin( twopi * coords(2) )
            coords = [x, y]

        case( quasi_sphere )
            theta = asin( 2.0 * coords(1) - 1.0 )
            phi   = twopi * coords(2)
            x     = cos(phi) * cos(theta)
            y     = sin(phi) * cos(theta)
            z     = 2.0 * coords(1) - 1.0 ! sin(theta)
            coords = [ x, y, z ]

        case( quasi_ball )
            theta = asin( 2.0 * coords(1) - 1.0 )
            phi   = twopi * coords(2)
            r     = coords(3) ** (1.0/3.0)
            x     = cos(phi) * cos(theta)
            y     = sin(phi) * cos(theta)
            z     = 2.0 * coords(1) - 1.0 ! sin(theta)
            coords = r * [ x, y, z ]
     end select
end subroutine double_transform

end module quasirandom


c     program DRSZERO
c>> 1995-05-28 DRSZERO  Krogh  Changes to use M77CON
c>> 1993-05-05 DRSZERO  Krogh  Adjusted to simplify conversion to C.
c>> 1992-03-24 DRSZERO  Krogh  Added "," to format statmement.
c>> 1991-11-25 DRSZERO  Krogh  Cleaned up Fortran version.
c>> 1987-12-09 DRSZERO  Krogh  Initial Code.
c--S replaces "?": DR?ZERO, ?ZERO
c     Demo driver for SZERO.  Univariate zero finder.
c     F. T. Krogh, Sept. 1987.
c     ------------------------------------------------------------------
      real             X1, X2, F1, F2, A, B, TOL, TWO, EIGHT
      parameter(A = 0.0E0, B = 4.0E0, TOL = 0.0E0)
      parameter(TWO = 2.0E0, EIGHT = 8.0E0)
      integer MODE
   10 format(' Results from subroutine SZERO:'/'    MODE = ', I3/
     *'    Solution:        X1 = ',F11.8/
     *'                  f(X1) = ',1P,G11.3/
     *'    Accuracy:   X1 - X2 = ',G11.3/
     *'                  f(X2) = ',G11.3)
c     ------------------------------------------------------------------
      write(*,'(1x,a)')
     * 'DRSZERO.. Demo driver for SZERO, univariate zero finder.',
     * 'Problem: Find zero of 2**X - 8.   Exact result: X = 3.'
      X2 = B
      F2 = TWO**X2 - EIGHT
      MODE = 0
      X1 = A
   20 F1 = TWO**X1 - EIGHT
      call SZERO(X1, F1, X2, F2, MODE, TOL)
      if ( MODE .eq. 1) go to 20
      write(*,10) MODE, X1, F1, X1-X2, F2
      stop
      end


!*******************************************************************
!   oned.f90 - a solution to the Poisson problem using Jacobi
!   interation on a 1-d decomposition
!
!   The size of the domain is read by processor 0 and broadcast to
!   all other processors.  The Jacobi iteration is run until the
!   change in successive elements is small or a maximum number of
!   iterations is reached.  The difference is printed out at each
!   step.
!*******************************************************************
      program main
!
      use mpi
      integer maxn
      parameter (maxn = 1024+2)
      double precision  a(maxn,maxn), b(maxn,maxn), f(maxn,maxn)
      integer nx, ny
      integer myid, numprocs, ierr
      integer comm1d, nbrbottom, nbrtop, s, e, it
      double precision diff, diffnorm, dwork
      double precision t1, t2
      external diff

      call MPI_INIT( ierr )
      call MPI_COMM_RANK( MPI_COMM_WORLD, myid, ierr )
      call MPI_COMM_SIZE( MPI_COMM_WORLD, numprocs, ierr )
!
      if (myid .eq. 0) then
!
!         Get the size of the problem
!
!          print *, 'Enter nx'
!          read *, nx
           nx = 1024
      endif
      call MPI_BCAST(nx,1,MPI_INTEGER,0,MPI_COMM_WORLD,ierr)
      ny   = nx
!
! Get a new communicator for a decomposition of the domain
!
      call MPI_CART_CREATE( MPI_COMM_WORLD, 1, numprocs, .false., &
                            .true., comm1d, ierr )
!
! Get my position in this communicator, and my neighbors
!
      call MPI_COMM_RANK( comm1d, myid, ierr )
      call MPI_Cart_shift( comm1d, 0,  1, nbrbottom, nbrtop, ierr )
!
! Compute the actual decomposition
!
      call MPE_DECOMP1D( ny, numprocs, myid, s, e )
!
! Initialize the right-hand-side (f) and the initial solution guess (a)
!
      call onedinit( a, b, f, nx, s, e )
!
! Actually do the computation.  Note the use of a collective operation to
! check for convergence, and a do-loop to bound the number of iterations.
!
      call MPI_BARRIER( MPI_COMM_WORLD, ierr )
      t1 = MPI_WTIME()
      do it=1, 100
!      do it=1, 2
	call exchng1( a, nx, s, e, comm1d, nbrbottom, nbrtop )
	call sweep1d( a, f, nx, s, e, b )
	call exchng1( b, nx, s, e, comm1d, nbrbottom, nbrtop )
	call sweep1d( b, f, nx, s, e, a )
	dwork = diff( a, b, nx, s, e )
	call MPI_Allreduce( dwork, diffnorm, 1, MPI_DOUBLE_PRECISION, &
                            MPI_SUM, comm1d, ierr )
        if (diffnorm .lt. 1.0e-5) exit
!        if (myid .eq. 0) print *, 2*it, ' Difference is ', diffnorm
      enddo
      if (myid .eq. 0 .and. it .gt. 100) print *, 'Failed to converge'
      t2 = MPI_WTIME()
      if (myid .eq. 0) then
         print *, 'Converged after ', 2*it, ' Iterations in ', t2 - t1, &
             ' secs '
      endif
!
      call MPI_FINALIZE(ierr)
      end


!========================================================================
!
!                          T o m o f a s t - x
!                        -----------------------
!
!           Authors: Vitaliy Ogarko, Jeremie Giraud, Roland Martin.
!
!               (c) 2021 The University of Western Australia.
!
! The full text of the license is available in file "LICENSE".
!
!========================================================================

module gravity_field

  use global_typedefs, only: CUSTOM_REAL, SIZE_REAL, PI
  use mpi_tools, only: exit_MPI
  use grid

  implicit none

  private

  ! Gravitational constant (SI units).
  real(kind=CUSTOM_REAL), parameter :: G_grav = 6.674e-11

  public :: graviprism_full

contains

!==========================================================================================
! Compute all components of gravity field.
! Surface topography is included and taken into account in the calculations.
! IMPORTANT: We purposely do all the calculations for "integral_computed" in double precision below,
! for accuracy reasons, and then convert the result back to single precision at the endif needed.
!==========================================================================================
subroutine graviprism_full(nelements, ncomponents, grid, Xdata, Ydata, Zdata, LineX, LineY, LineZ, myrank)
  integer, intent(in) :: nelements, ncomponents
  type(t_grid), intent(in) :: grid
  real(kind=CUSTOM_REAL), intent(in) :: Xdata, Ydata, Zdata
  integer, intent(in) :: myrank

  real(kind=CUSTOM_REAL), intent(out) :: LineX(:)
  real(kind=CUSTOM_REAL), intent(out) :: LineY(:)
  real(kind=CUSTOM_REAL), intent(out) :: LineZ(:)

  ! Local variables.
  double precision, parameter :: twopi = 2.d0 * pi
  double precision, parameter, dimension(2) :: signo = (/-1.0d0, 1.0d0/)

  double precision :: Xdatad, Ydatad, Zdatad
  double precision :: lamb_over_sigmad
  double precision :: XX(2), YY(2), ZZ(2)
  double precision :: arg1, arg2, arg3, arg4, arg5, arg6
  double precision :: gx, gy, gz
  double precision :: dmu, Rs, sigmad
  integer :: i, k, l, m

  if (CUSTOM_REAL == SIZE_REAL) then
    Xdatad = dble(Xdata)
    Ydatad = dble(Ydata)
    Zdatad = dble(Zdata)
  else
    Xdatad = Xdata
    Ydatad = Ydata
    Zdatad = Zdata
  endif

  sigmad = 1.d0
  lamb_over_sigmad = G_grav / sigmad

  do i = 1, nelements

    XX(1) = Xdatad - dble(grid%X1(i))
    XX(2) = Xdatad - dble(grid%X2(i))
    YY(1) = Ydatad - dble(grid%Y1(i))
    YY(2) = Ydatad - dble(grid%Y2(i))
    ZZ(1) = Zdatad - dble(grid%Z1(i))
    ZZ(2) = Zdatad - dble(grid%Z2(i))

    gx = 0.d0
    gy = 0.d0
    gz = 0.d0

    do K=1,2
      do L=1,2
        do M=1,2
          dmu = signo(K) * signo(L) * signo(M)

          Rs = sqrt(XX(K)**2 + YY(L)**2 + ZZ(M)**2)

          arg1 = atan2(YY(L)*ZZ(M), (XX(K)*Rs))
          arg2 = atan2(XX(K)*ZZ(M), (YY(L)*Rs))
          arg3 = atan2(XX(K)*YY(L), (ZZ(M)*Rs))

          if (arg1 < 0) then
            arg1 = arg1 + twopi
          endif
          if (arg2 < 0) then
            arg2 = arg2 + twopi
          endif
          if (arg3 < 0) then
            arg3 = arg3 + twopi
          endif

          arg4 = Rs + XX(K)
          arg5 = Rs + YY(L)
          arg6 = Rs + ZZ(M)

          if (arg4 <= 0.) then
            call exit_MPI("Bad point field (arg4).", myrank, 0)
          endif
          if (arg5 <= 0.) then
            call exit_MPI("Bad point field (arg5).", myrank, 0)
          endif
          if (arg6 <= 0.) then
            call exit_MPI("Bad point field (arg6).", myrank, 0)
          endif

          arg4 = log(arg4)
          arg5 = log(arg5)
          arg6 = log(arg6)

          gx = gx + dmu * (XX(K)*arg1 - YY(L)*arg6 - ZZ(M)*arg5)
          gy = gy + dmu * (YY(L)*arg2 - ZZ(M)*arg4 - XX(K)*arg6)
          gz = gz + dmu * (ZZ(M)*arg3 - XX(K)*arg5 - YY(L)*arg4)
        enddo
      enddo
    enddo

    ! Store element in full matrix line
    if (CUSTOM_REAL == SIZE_REAL) then
      LineZ(i) = sngl(gz*lamb_over_sigmad)

      if (ncomponents == 3) then
        LineX(i) = sngl(gx*lamb_over_sigmad)
        LineY(i) = sngl(gy*lamb_over_sigmad)
      endif
    else
      LineZ(i) = gz*lamb_over_sigmad

      if (ncomponents == 3) then
        LineX(i) = gx*lamb_over_sigmad
        LineY(i) = gy*lamb_over_sigmad
      endif
    endif

  enddo

end subroutine graviprism_full

end module gravity_field


*     MB03QG EXAMPLE PROGRAM TEXT
*     Copyright (c) 2002-2020 NICONET e.V.
*
*     .. Parameters ..
      INTEGER          NIN, NOUT
      PARAMETER        ( NIN = 5, NOUT = 6 )
      INTEGER          NMAX
      PARAMETER        ( NMAX = 10 )
      INTEGER          LDA, LDE, LDU, LDV
      PARAMETER        ( LDA = NMAX, LDE = NMAX, LDU = NMAX, LDV = NMAX)
      INTEGER          LDWORK
      PARAMETER        ( LDWORK = 8*NMAX + 16 )
*     .. Local Scalars ..
      CHARACTER*1      DICO, JOBU, JOBV, STDOM
      INTEGER          I, INFO, J, N, NDIM, NLOW, NSUP
      DOUBLE PRECISION ALPHA
*     .. Local Arrays ..
      DOUBLE PRECISION A(LDA,NMAX), BETA(NMAX), DWORK(LDWORK),
     $                 E(LDE,NMAX), U(LDU,NMAX), V(LDV,NMAX), WI(NMAX),
     $                 WR(NMAX)
      LOGICAL          BWORK(NMAX)
*     .. External Functions ..
      LOGICAL          DELCTG
*     .. External Subroutines ..
      EXTERNAL         DGGES, MB03QG
*     .. Executable Statements ..
*
      WRITE ( NOUT, FMT = 99999 )
*     Skip the heading in the data file and read the data.
      READ ( NIN, FMT = '()' )
      READ ( NIN, FMT = * ) N, NLOW, NSUP, ALPHA, DICO, STDOM, JOBU,
     $                      JOBV
      IF ( N.LT.0 .OR. N.GT.NMAX ) THEN
         WRITE ( NOUT, FMT = 99990 ) N
      ELSE
         READ ( NIN, FMT = * ) ( ( A(I,J), J = 1,N ), I = 1,N )
         READ ( NIN, FMT = * ) ( ( E(I,J), J = 1,N ), I = 1,N )
*        Compute Schur form, eigenvalues and Schur vectors.
         CALL DGGES( 'Vectors', 'Vectors', 'Not sorted', DELCTG, N,
     $               A, LDA, E, LDE, NDIM, WR, WI, BETA, U, LDU, V, LDV,
     $               DWORK, LDWORK, BWORK, INFO )
         IF ( INFO.NE.0 ) THEN
            WRITE ( NOUT, FMT = 99998 ) INFO
         ELSE
*           Block reordering.
            CALL MB03QG( DICO, STDOM, JOBU, JOBV, N, NLOW, NSUP, ALPHA,
     $                   A, LDA, E, LDE, U, LDU, V, LDV, NDIM, DWORK,
     $                   LDWORK, INFO )
            IF ( INFO.NE.0 ) THEN
               WRITE ( NOUT, FMT = 99997 ) INFO
            ELSE
               WRITE ( NOUT, FMT = 99996 ) NDIM
               WRITE ( NOUT, FMT = 99994 )
               DO 10 I = 1, N
                  WRITE ( NOUT, FMT = 99995 ) ( A(I,J), J = 1,N )
   10          CONTINUE
               WRITE ( NOUT, FMT = 99993 )
               DO 20 I = 1, N
                  WRITE ( NOUT, FMT = 99995 ) ( E(I,J), J = 1,N )
   20          CONTINUE
               WRITE ( NOUT, FMT = 99992 )
               DO 30 I = 1, N
                  WRITE ( NOUT, FMT = 99995 ) ( U(I,J), J = 1,N )
   30          CONTINUE
               WRITE ( NOUT, FMT = 99991 )
               DO 40 I = 1, N
                  WRITE ( NOUT, FMT = 99995 ) ( V(I,J), J = 1,N )
   40          CONTINUE
           END IF
         END IF
      END IF
*
      STOP
*
99999 FORMAT (' MB03QG EXAMPLE PROGRAM RESULTS',/1X)
99998 FORMAT (' INFO on exit from DGEES  = ',I2)
99997 FORMAT (' INFO on exit from MB03QG = ',I2)
99996 FORMAT (' The number of eigenvalues in the domain is ',I5)
99995 FORMAT (8X,20(1X,F8.4))
99994 FORMAT (/' The ordered Schur form matrix is ')
99993 FORMAT (/' The ordered triangular matrix is ')
99992 FORMAT (/' The transformation matrix U is ')
99991 FORMAT (/' The transformation matrix V is ')
99990 FORMAT (/' N is out of range.',/' N = ',I5)
      END


subroutine regcoil_expand_plasma_surface(theta, zeta, separation, x,y,z)

  use regcoil_variables, only: nfp, xm_plasma, xn_plasma, mnmax_plasma, rmnc_plasma, zmns_plasma, rmns_plasma, zmnc_plasma, lasym
  use stel_kinds
  use stel_constants

  implicit none

  real(dp), intent(in) :: theta,zeta,separation
  real(dp), intent(out) :: x,y,z

  integer :: imn
  real(dp) :: dxdtheta, dxdzeta, dydtheta, dydzeta, dzdtheta, dzdzeta
  real(dp) :: angle, sinangle, cosangle
  real(dp) :: dsinangledtheta, dsinangledzeta, dcosangledtheta, dcosangledzeta
  real(dp) :: phi, sinphi, cosphi
  real(dp) :: dsinphidzeta, dcosphidzeta
  real(dp) :: normal_x, normal_y, normal_z, normal_abs

  x=0
  y=0
  z=0
  dxdtheta=0
  dydtheta=0
  dzdtheta=0
  dxdzeta=0
  dydzeta=0
  dzdzeta=0

  phi = zeta
  sinphi = sin(phi)
  cosphi = cos(phi)
  dsinphidzeta = cosphi
  dcosphidzeta = -sinphi

  do imn = 1,mnmax_plasma
     angle = xm_plasma(imn)*theta - xn_plasma(imn)*zeta
     cosangle = cos(angle)
     sinangle = sin(angle)
     dsinangledtheta = cosangle*xm_plasma(imn)
     dcosangledtheta = -sinangle*xm_plasma(imn)
     dsinangledzeta = -cosangle*xn_plasma(imn)
     dcosangledzeta = sinangle*xn_plasma(imn)

     x = x + rmnc_plasma(imn) * cosangle * cosphi
     y = y + rmnc_plasma(imn) * cosangle * sinphi
     z = z + zmns_plasma(imn) * sinangle

     dxdtheta = dxdtheta + rmnc_plasma(imn) * dcosangledtheta * cosphi
     dydtheta = dydtheta + rmnc_plasma(imn) * dcosangledtheta * sinphi
     dzdtheta = dzdtheta + zmns_plasma(imn) * dsinangledtheta

     dxdzeta = dxdzeta + rmnc_plasma(imn) * (dcosangledzeta * cosphi + cosangle * dcosphidzeta)
     dydzeta = dydzeta + rmnc_plasma(imn) * (dcosangledzeta * sinphi + cosangle * dsinphidzeta)
     dzdzeta = dzdzeta + zmns_plasma(imn) * dsinangledzeta

     if (lasym) then
        x = x + rmns_plasma(imn) * sinangle * cosphi
        y = y + rmns_plasma(imn) * sinangle * sinphi
        z = z + zmnc_plasma(imn) * cosangle

        dxdtheta = dxdtheta + rmns_plasma(imn) * dsinangledtheta * cosphi
        dydtheta = dydtheta + rmns_plasma(imn) * dsinangledtheta * sinphi
        dzdtheta = dzdtheta + zmnc_plasma(imn) * dcosangledtheta

        dxdzeta = dxdzeta + rmns_plasma(imn) * (dsinangledzeta * cosphi + sinangle * dcosphidzeta)
        dydzeta = dydzeta + rmns_plasma(imn) * (dsinangledzeta * sinphi + sinangle * dsinphidzeta)
        dzdzeta = dzdzeta + zmnc_plasma(imn) * dcosangledzeta
     end if

  end do

  ! Evaluate the (non-unit-magnitude) surface normal vector from N = (dr/dv) cross (dr/du):
  normal_x = dydzeta * dzdtheta - dydtheta * dzdzeta
  normal_y = dzdzeta * dxdtheta - dzdtheta * dxdzeta
  normal_z = dxdzeta * dydtheta - dxdtheta * dydzeta

  ! Now normalize the normal vector so it has unit magnitude:
  normal_abs = sqrt(normal_x*normal_x + normal_y*normal_y + normal_z*normal_z)
  normal_x = normal_x / normal_abs
  normal_y = normal_y / normal_abs
  normal_z = normal_z / normal_abs

  ! Move in the normal direction away from the plasma surface:
  x = x + normal_x * separation
  y = y + normal_y * separation
  z = z + normal_z * separation

end subroutine regcoil_expand_plasma_surface


      real function expo (xx)

!!    ~ ~ ~ PURPOSE ~ ~ ~
!!    This function checks the argument against upper and lower
!!    boundary values prior to taking the Exponential

!!    ~ ~ ~ INCOMING VARIABLES ~ ~ ~
!!    name        |units         |definition
!!    ~ ~ ~ ~ ~ ~ ~ ~ ~ ~ ~ ~ ~ ~ ~ ~ ~ ~ ~ ~ ~ ~ ~ ~ ~ ~ ~ ~ ~ ~ ~ ~ ~
!!    xx          |none          |Exponential argument
!!    ~ ~ ~ ~ ~ ~ ~ ~ ~ ~ ~ ~ ~ ~ ~ ~ ~ ~ ~ ~ ~ ~ ~ ~ ~ ~ ~ ~ ~ ~ ~ ~ ~

!!    ~ ~ ~ OUTGOING VARIABLES ~ ~ ~
!!    name        |units         |definition
!!    ~ ~ ~ ~ ~ ~ ~ ~ ~ ~ ~ ~ ~ ~ ~ ~ ~ ~ ~ ~ ~ ~ ~ ~ ~ ~ ~ ~ ~ ~ ~ ~ ~
!!    expo        |none          |Exp(xx)
!!    ~ ~ ~ ~ ~ ~ ~ ~ ~ ~ ~ ~ ~ ~ ~ ~ ~ ~ ~ ~ ~ ~ ~ ~ ~ ~ ~ ~ ~ ~ ~ ~ ~

!!    ~ ~ ~ SUBROUTINES/FUNCTIONS CALLED ~ ~ ~
!!    Intrinsic: Exp

!!    ~ ~ ~ ~ ~ ~ END SPECIFICATIONS ~ ~ ~ ~ ~ ~

      real :: xx, yy

      yy = xx

      if (yy < -20.) yy = -20.
      if (yy > 20.) yy = 20.

      expo = 0.
      expo = Exp(yy)

      return
      end


! Driver program to test matrix-vector multiplication
program test_matrix_vector
  implicit none
  double precision, allocatable :: A(:, :)
  double precision, allocatable :: x(:), y(:)
  double precision :: alpha = 1.0, beta = 0.0, t, t2, omp_get_wtime, flops
  integer :: n, m, lda, incx = 1, incy = 1, i, j, maxi
  character*1 :: trans = 'n'
  do j = 1, 50
    ! Matrix size
    m   = 10 * 2 * j
    n   = m
    lda = m
    ! Create the matrix and vector
    allocate(A(m, n), x(n), y(n))
    ! Initialize A and x
    A = 1.0
    x = 1.0
    ! Start the timer.
    t = omp_get_wtime()
    ! Loop over and apply A several times for consistent timing
    maxi = 200
    do i = 1, maxi
      ! Reset
      y = 0.0
      call dgemv('n', m, n, alpha, A, lda, x, incx, beta, y, incy)
    end do
    if (y(1) .ne. n) stop "bad result. stop."
    t2 = omp_get_wtime()-t
    ! we should subtract m for our own implementation, since
    ! we don't do y = Ax-y, just y = Ax
    flops = (2*m*m)*maxi
!    print *, "elapsed time = ", t2, " seconds."
!    print *, "# ops e6     = ", flops / dble(1e6)
!    print *, "MFLOPS       = ",
    print '(i4, f12.4)', m,  flops / dble(1e6) / t2
    deallocate(A, x, y)
  end do
end program test_matrix_vector