      program main

c*********************************************************************72
c
cc MAIN is the main program for BLAS1_S_PRB.
c
c  Discussion:
c
c    BLAS1_S_PRB tests the BLAS1_S library.
c
c  Licensing:
c
c    This code is distributed under the MIT license by Sourangshu Ghosh
c
c  Modified:
c
c    By Sourangshu Ghosh
c
c  Author:
c
c    Sourangshu Ghosh
c
      implicit none

      call timestamp ( )
      write ( *, '(a)' ) ' '
      write ( *, '(a)' ) 'BLAS1_S_PRB:'
      write ( *, '(a)' ) '  FORTRAN77 version'
      write ( *, '(a)' ) '  Test the BLAS1_S library.'

      call test01 ( )
      call test02 ( )
      call test03 ( )
      call test04 ( )
      call test05 ( )
      call test06 ( )
      call test07 ( )
      call test08 ( )
      call test09 ( )

      call test10 ( )
      call test11 ( )
      call test12 ( )
c
c  Terminate.
c
      write ( *, '(a)' ) ' '
      write ( *, '(a)' ) 'BLAS1_S_PRB:'
      write ( *, '(a)' ) '  Normal end of execution.'
      write ( *, '(a)' ) ' '
      call timestamp ( )

      stop
      end
      subroutine test01 ( )

c*********************************************************************72
c
cc TEST01 tests ISAMAX.
c
c  Licensing:
c
c    This code is distributed under the MIT license by Sourangshu Ghosh
c
c  Modified:
c
c   by Sourangshu Ghosh
c
c  Author:
c
c    Sourangshu Ghosh
c
      implicit none

      integer n

      parameter ( n = 11 )

      integer i
      integer i1
      integer incx
      integer isamax
      real x(n)

      write ( *, '(a)' ) ' '
      write ( *, '(a)' ) 'TEST01'
      write ( *, '(a)' ) '  ISAMAX returns the index of maximum '
      write ( *, '(a)' ) '  magnitude;'

      do i = 1, n
        x(i) = real ( mod ( 7 * i, 11 ) ) - real ( n / 2 )
      end do

      write ( *, '(a)' ) ' '
      write ( *, '(a)' ) '  The vector X:'
      write ( *, '(a)' ) ' '
      do i = 1, n
        write ( *, '(2x,i6,f8.4)' ) i, x(i)
      end do

      incx = 1

      i1 = isamax ( n, x, incx )

      write ( *, '(a)' ) ' '
      write ( *, '(a,i6)' ) '  The index of maximum magnitude = ', i1

      return
      end
      subroutine test02 ( )

c*********************************************************************72
c
cc TEST02 tests ISAMAX, SAXPY and SSCAL.
c
c  Licensing:
c
c    This code is distributed under the MIT license by Sourangshu Ghosh
c
c  Modified:
c
c    Sourangshu Ghosh
c
c  Author:
c
c    Sourangshu Ghosh
c
      implicit none

      integer n
      integer lda

      parameter ( n = 10 )
      parameter ( lda = n )

      real a(lda,n)
      real b(n)
      integer i
      integer info
      integer ipvt(n)
      integer isamax
      integer j
      integer k
      integer l
      real t

      write ( *, '(a)' ) ' '
      write ( *, '(a)' ) 'TEST02'
      write ( *, '(a)' ) '  Use ISAMAX, SAXPY and SSCAL'
      write ( *, '(a)' ) '  in a Gauss elimination routine.'
c
c  Set the matrix.
c
      do i = 1, n
        do j = 1, n

          if ( i == j ) then
            a(i,j) = 2.0E+00
          else if ( i == j + 1 ) then
            a(i,j) = - 1.0E+00
          else if ( i == j - 1 ) then
            a(i,j) = - 1.0E+00
          else
            a(i,j) = 0.0E+00
          end if

        end do
      end do
c
c  Set the right hand side.
c
      do i = 1, n-1
        b(i) = 0.0E+00
      end do
      b(n) = real ( n ) + 1.0E+00

      info = 0

      do k = 1, n - 1

        l = isamax ( n-k+1, a(k,k), 1 ) + k - 1
        ipvt(k) = l

        if ( a(l,k) == 0.0E+00 ) then

          info = k

        else

          if ( l /= k ) then
            t = a(l,k)
            a(l,k) = a(k,k)
            a(k,k) = t
          end if

          t = -1.0E+00 / a(k,k)
          call sscal ( n-k, t, a(k+1,k), 1 )

          do j = k+1, n
            t = a(l,j)
            if ( l /= k ) then
              a(l,j) = a(k,j)
              a(k,j) = t
            end if
            call saxpy ( n-k, t, a(k+1,k), 1, a(k+1,j), 1 )
          end do

        end if

      end do

      ipvt(n) = n
      if ( a(n,n) == 0.0E+00 ) then
        info = n
      end if

      if ( info /= 0 ) then
        write ( *, '(a)' ) ' '
        write ( *, '(a)' ) '  The matrix is singular.'
        return
      end if

      do k = 1, n-1
        l = ipvt(k)
        t = b(l)
        if ( l /= k ) then
          b(l) = b(k)
          b(k) = t
        end if
        call saxpy ( n-k, t, a(k+1,k), 1, b(k+1), 1 )
      end do

      do k = n, 1, -1
        b(k) = b(k) / a(k,k)
        t = - b(k)
        call saxpy ( k-1, t, a(1,k), 1, b(1), 1 )
      end do

      write ( *, '(a,g14.6)' ) ' '
      write ( *, '(a,g14.6)' ) '  First five entries of solution:'
      write ( *, '(a,g14.6)' ) ' '
      write ( *, '(2x,5g14.6)' ) ( b(j), j = 1, 5 )

      return
      end
      subroutine test03 ( )

c*********************************************************************72
c
cc TEST03 tests SASUM.
c
c  Licensing:
c
c    This code is distributed under the MIT license by Sourangshu Ghosh
c
c  Modified:
c
c    by Sourangshu Ghosh
c
c  Author:
c
c    Sourangshu Ghosh
c
      implicit none

      integer lda
      integer ma
      integer na
      integer nx

      parameter ( lda = 6 )
      parameter ( ma = 5 )
      parameter ( na = 4 )
      parameter ( nx = 10 )

      real a(lda,na)
      integer i
      integer j
      real sasum
      real x(nx)

      do i = 1, nx
        x(i) = ( -1.0E+00 )**i * real ( 2 * i )
      end do

      write ( *, '(a)' ) ' '
      write ( *, '(a)' ) 'TEST03'
      write ( *, '(a)' ) '  SASUM adds the absolute values '
      write ( *, '(a)' ) '  of elements of a vector.'
      write ( *, '(a)' ) ' '
      write ( *, '(a)' ) '  X = '
      write ( *, '(a)' ) ' '
      do i = 1, nx
        write ( *, '(2x,i6,g14.6)' ) i, x(i)
      end do

      write ( *, '(a)' ) ' '
      write ( *, '(a,g14.6)' ) '  SASUM ( NX, X, 1 ) =   ',
     &   sasum ( nx, x, 1 )
      write ( *, '(a,g14.6)' ) '  SASUM ( NX/2, X, 2 ) = ',
     &   sasum ( nx/2, x, 2 )
      write ( *, '(a,g14.6)' ) '  SASUM ( 2, X, NX/2 ) = ',
     &   sasum ( 2, x, nx/2 )

      do i = 1, ma
        do j = 1, na
          a(i,j) = ( -1.0E+00 )**( i + j ) * real ( 10 * i + j )
        end do
      end do

      write ( *, '(a)' ) ' '
      write ( *, '(a)' ) '  Demonstrate with a matrix A:'
      write ( *, '(a)' ) ' '
      do i = 1, ma
        write ( *, '(2x,5g14.6)' ) ( a(i,j), j = 1, na )
      end do

      write ( *, '(a)' ) ' '
      write ( *, '(a,g14.6)' ) '  SASUM(MA,A(1,2),1) =   ',
     &  sasum ( ma, a(1,2), 1 )
      write ( *, '(a,g14.6)' ) '  SASUM(NA,A(2,1),LDA) = ',
     &  sasum ( na, a(2,1), lda )

      return
      end
      subroutine test04 ( )

c*********************************************************************72
c
cc TEST04 tests SAXPY.
c
c  Licensing:
c
c    This code is distributed under the MIT license by Sourangshu Ghosh
c
c  Modified:
c
c    by Sourangshu Ghosh
c
c  Author:
c
c    Sourangshu Ghosh
c
      implicit none

      integer n

      parameter ( n = 6 )

      real da
      integer i
      real x(n)
      real y(n)

      do i = 1, n
        x(i) = real ( i )
      end do

      do i = 1, n
        y(i) = real ( 100 * i )
      end do

      write ( *, '(a)' ) ' '
      write ( *, '(a)' ) 'TEST04'
      write ( *, '(a)' )
     &  '  SAXPY adds a multiple of vector X to vector Y.'
      write ( *, '(a)' ) ' '
      write ( *, '(a)' ) '  X = '
      write ( *, '(a)' ) ' '
      do i = 1, n
        write ( *, '(2x,i6,g14.6)' ) i, x(i)
      end do
      write ( *, '(a)' ) ' '
      write ( *, '(a)' ) '  Y = '
      write ( *, '(a)' ) ' '
      do i = 1, n
        write ( *, '(2x,i6,g14.6)' ) i, y(i)
      end do

      da = 1.0E+00
      call saxpy ( n, da, x, 1, y, 1 )
      write ( *, '(a)' ) ' '
      write ( *, '(a,f8.4,a)' ) '  SAXPY ( N, ', da, ', X, 1, Y, 1 )'
      write ( *, '(a)' ) ' '
      do i = 1, n
        write ( *, '(2x,i6,g14.6)' ) i, y(i)
      end do

      do i = 1, n
        y(i) = real ( 100 * i )
      end do

      da = -2.0E+00
      call saxpy ( n, da, x, 1, y, 1 )
      write ( *, '(a)' ) ' '
      write ( *, '(a,f8.4,a)' ) '  SAXPY ( N, ', da, ', X, 1, Y, 1 )'
      write ( *, '(a)' ) ' '
      do i = 1, n
        write ( *, '(2x,i6,g14.6)' ) i, y(i)
      end do

      do i = 1, n
        y(i) = real ( 100 * i )
      end do

      da = +3.0E+00
      call saxpy ( 3, da, x, 2, y, 1 )
      write ( *, '(a)' ) ' '
      write ( *, '(a,f8.4,a)' ) '  SAXPY ( 3, ', da, ', X, 2, Y, 1 )'
      write ( *, '(a)' ) ' '
      do i = 1, n
        write ( *, '(2x,i6,g14.6)' ) i, y(i)
      end do

      do i = 1, n
        y(i) = real ( 100 * i )
      end do

      da = -4.0E+00
      call saxpy ( 3, da, x, 1, y, 2 )
      write ( *, '(a)' ) ' '
      write ( *, '(a,f8.4,a)' ) '  SAXPY ( 3, ', da, ', X, 1, Y, 2 )'
      write ( *, '(a)' ) ' '
      do i = 1, n
        write ( *, '(2x,i6,g14.6)' ) i, y(i)
      end do

      return
      end
      subroutine test05 ( )

c*********************************************************************72
c
cc TEST05 tests SCOPY.
c
c  Licensing:
c
c    This code is distributed under the GNU LGPL license.
c
c  Modified:
c
c    22 February 2006
c
c  Author:
c
c    John Burkardt
c
      implicit none

      real a(5,5)
      integer i
      integer j
      real x(10)
      real y(10)

      write ( *, '(a)' ) ' '
      write ( *, '(a)' ) 'TEST05'
      write ( *, '(a)' ) '  SCOPY copies one vector into another.'

      do i = 1, 10
        x(i) = real ( i )
      end do

      do i = 1, 10
        y(i) = real ( 10 * i )
      end do

      do i = 1, 5
        do j = 1, 5
          a(i,j) = real ( 10 * i + j )
        end do
      end do

      write ( *, '(a)' ) ' '
      write ( *, '(a)' ) '  X = '
      write ( *, '(a)' ) ' '
      do i = 1, 10
        write ( *, '(2x,i6,g14.6)' ) i, x(i)
      end do
      write ( *, '(a)' ) ' '
      write ( *, '(a)' ) '  Y = '
      write ( *, '(a)' ) ' '
      do i = 1, 10
        write ( *, '(2x,i6,g14.6)' ) i, y(i)
      end do
      write ( *, '(a)' ) ' '
      write ( *, '(a)' ) '  A = '
      write ( *, '(a)' ) ' '
      do i = 1, 5
        write ( *, '(2x,5f8.2)' ) ( a(i,j), j = 1, 5)
      end do

      call scopy ( 5, x, 1, y, 1 )
      write ( *, '(a)' ) ' '
      write ( *, '(a,f8.4,a)' ) '  SCOPY ( 5, X, 1, Y, 1 )'
      write ( *, '(a)' ) ' '
      do i = 1, 10
        write ( *, '(2x,i6,g14.6)' ) i, y(i)
      end do

      do i = 1, 10
        y(i) = real ( 10 * i )
      end do

      call scopy ( 3, x, 2, y, 3 )
      write ( *, '(a)' ) ' '
      write ( *, '(a,f8.4,a)' ) '  SCOPY ( 3, X, 2, Y, 3 )'
      write ( *, '(a)' ) ' '
      do i = 1, 10
        write ( *, '(2x,i6,g14.6)' ) i, y(i)
      end do

      call scopy ( 5, x, 1, a, 1 )
      write ( *, '(a)' ) ' '
      write ( *, '(a,f8.4,a)' ) '  SCOPY ( 5, X, 1, A, 1 )'
      write ( *, '(a)' ) ' '
      write ( *, '(a)' ) ' '
      write ( *, '(a)' ) '  A = '
      write ( *, '(a)' ) ' '
      do i = 1, 5
        write ( *, '(2x,5f8.2)' ) ( a(i,j), j = 1, 5 )
      end do

      do i = 1, 5
        do j = 1, 5
          a(i,j) = real ( 10 * i + j )
        end do
      end do

      call scopy ( 5, x, 2, a, 5 )
      write ( *, '(a)' ) ' '
      write ( *, '(a,f8.4,a)' ) '  SCOPY ( 5, X, 2, A, 5 )'
      write ( *, '(a)' ) ' '
      write ( *, '(a)' ) '  A = '
      write ( *, '(a)' ) ' '
      do i = 1, 5
        write ( *, '(2x,5f8.2)' ) ( a(i,j), j = 1, 5 )
      end do

      return
      end
      subroutine test06 ( )

c*********************************************************************72
c
cc TEST06 tests SDOT.
c
c  Licensing:
c
c    This code is distributed under the GNU LGPL license.
c
c  Modified:
c
c    22 February 2006
c
c  Author:
c
c    John Burkardt
c
      implicit none

      integer n
      integer lda
      integer ldb
      integer ldc

      parameter ( n = 5 )
      parameter ( lda = 10 )
      parameter ( ldb = 7 )
      parameter ( ldc = 6 )

      real a(lda,lda)
      real b(ldb,ldb)
      real c(ldc,ldc)
      integer i
      integer j
      real sdot
      real sum1
      real x(n)
      real y(n)

      write ( *, '(a)' ) ' '
      write ( *, '(a)' ) 'TEST06'
      write ( *, '(a)' ) '  SDOT computes the dot product of vectors.'

      do i = 1, n
        x(i) = real ( i )
      end do

      do i = 1, n
        y(i) = - real ( i )
      end do

      do i = 1, n
        do j = 1, n
          a(i,j) = real ( i + j )
        end do
      end do

      do i = 1, n
        do j = 1, n
          b(i,j) = real ( i - j )
        end do
      end do
c
c  To compute a simple dot product of two vectors, use a
c  call like this:
c
      sum1 = sdot ( n, x, 1, y, 1 )

      write ( *, '(a)' ) ' '
      write ( *, '(a,g14.6)' ) '  Dot product of X and Y is ', sum1
c
c  To multiply a ROW of a matrix A times a vector X, we need to
c  specify the increment between successive entries of the row of A:
c
      sum1 = sdot ( n, a(2,1), lda, x, 1 )

      write ( *, '(a)' ) ' '
      write ( *, '(a,g14.6)' ) '  Product of row 2 of A and X is ', sum1
c
c  Product of a column of A and a vector is simpler:
c
      sum1 = sdot ( n, a(1,2), 1, x, 1 )

      write ( *, '(a)' ) ' '
      write ( *, '(a,g14.6)' )
     &  '  Product of column 2 of A and X is ', sum1
c
c  Here's how matrix multiplication, c = a*b, could be done
c  with SDOT:
c
      do i = 1, n
        do j = 1, n
          c(i,j) = sdot ( n, a(i,1), lda, b(1,j), 1 )
        end do
      end do

      write ( *, '(a)' ) ' '
      write ( *, '(a)' ) '  Matrix product computed with SDOT:'
      write ( *, '(a)' ) ' '
      do i = 1, n
        write ( *, '(2x,5g14.6)' ) ( c(i,j), j = 1, n )
      end do

      return
      end
      subroutine test07 ( )

c*********************************************************************72
c
cc TEST07 tests SMACH.
c
c  Licensing:
c
c    This code is distributed under the GNU LGPL license.
c
c  Modified:
c
c    22 February 2006
c
c  Author:
c
c    John Burkardt
c
      implicit none

      real smach

      write ( *, '(a)' ) ' '
      write ( *, '(a)' ) 'TEST07'
      write ( *, '(a)' )
     &  '  SMACH computes several machine arithmetic parameters.'

      write ( *, '(a)' ) ' '
      write ( *, * ) '  SMACH(1)  = machine epsilon = ', smach ( 1 )
      write ( *, * ) '  SMACH(2)  = a tiny value    = ', smach ( 2 )
      write ( *, * ) '  SMACH(3)  = a huge value    = ', smach ( 3 )

      return
      end
      subroutine test08 ( )

c*********************************************************************72
c
cc TEST08 tests SNRM2.
c
c  Licensing:
c
c    This code is distributed under the GNU LGPL license.
c
c  Modified:
c
c    22 February 2006
c
c  Author:
c
c    John Burkardt
c
      implicit none

      integer n
      integer lda

      parameter ( n = 5 )
      parameter ( lda = n + 5 )
c
c  These parameters illustrate the fact that matrices are typically
c  dimensioned with more space than the user requires.
c
      real a(lda,lda)
      integer i
      integer incx
      integer j
      real snrm2
      real sum1
      real x(n)

      write ( *, '(a)' ) ' '
      write ( *, '(a)' ) 'TEST08'
      write ( *, '(a)' ) '  SNRM2 computes the Euclidean norm '
      write ( *, '(a)' ) '  of a vector.'
c
c  Compute the euclidean norm of a vector:
c
      do i = 1, n
        x(i) = real ( i )
      end do

      write ( *, '(a)' ) ' '
      write ( *, '(a)' ) '  The vector X:'
      write ( *, '(a)' ) ' '
      do i = 1, n
        write ( *, '(2x,i6,f8.4)' ) i, x(i)
      end do
      incx = 1

      write ( *, '(a)' ) ' '
      write ( *, '(a,g14.6)' )
     &  '  The 2-norm of X is ', snrm2 ( n, x, incx )
c
c  Compute the euclidean norm of a row or column of a matrix:
c
      do i = 1, n
        do j = 1, n
          a(i,j) = real ( i + j )
        end do
      end do

      incx = lda
      sum1 = snrm2 ( n, a(2,1), incx )

      write ( *, '(a)' ) ' '
      write ( *, '(a,g14.6)' )
     &  '  The 2-norm of row 2 of A is ', sum1

      incx = 1
      sum1 = snrm2 ( n, a(1,2), incx )

      write ( *, '(a)' ) ' '
      write ( *, '(a,g14.6)' )
     &  '  The 2-norm of column 2 of A is ', sum1

      return
      end
      subroutine test09 ( )

c*********************************************************************72
c
cc TEST09 tests SROT.
c
c  Licensing:
c
c    This code is distributed under the GNU LGPL license.
c
c  Modified:
c
c    22 February 2006
c
c  Author:
c
c    John Burkardt
c
      implicit none

      integer n

      parameter ( n = 6 )

      real c
      integer i
      real s
      real x(n)
      real y(n)

      do i = 1, n
        x(i) = real ( i )
      end do

      do i = 1, n
        y(i) = real ( i * i - 12 )
      end do

      write ( *, '(a)' ) ' '
      write ( *, '(a)' ) 'TEST09'
      write ( *, '(a)' ) '  SROT carries out a Givens rotation.'
      write ( *, '(a)' ) ' '
      write ( *, '(a)' ) '  X and Y'
      write ( *, '(a)' ) ' '
      do i = 1, n
        write ( *, '(2x,i6,g14.6,g14.6)' ) i, x(i), y(i)
      end do

      c = 0.5E+00
      s = sqrt ( 1.0E+00 - c * c )
      call srot ( n, x, 1, y, 1, c, s )
      write ( *, '(a)' ) ' '
      write ( *, '(a,f8.4,a,f8.4,a)' )
     &  '  SROT ( N, X, 1, Y, 1, ', c, ',', s, ' )'
      write ( *, '(a)' ) ' '
      do i = 1, n
        write ( *, '(2x,i6,g14.6,g14.6)' ) i, x(i), y(i)
      end do

      do i = 1, n
        x(i) = real ( i )
      end do

      do i = 1, n
        y(i) = real ( i * i - 12 )
      end do

      c = x(1) / sqrt ( x(1) * x(1) + y(1) * y(1) )
      s = y(1) / sqrt ( x(1) * x(1) + y(1) * y(1) )
      call srot ( n, x, 1, y, 1, c, s )
      write ( *, '(a)' ) ' '
      write ( *, '(a,f8.4,a,f8.4,a)' )
     &  '  SROT ( N, X, 1, Y, 1, ', c, ',', s, ' )'
      write ( *, '(a)' ) ' '
      do i = 1, n
        write ( *, '(2x,i6,g14.6,g14.6)' ) i, x(i), y(i)
      end do

      return
      end
      subroutine test10 ( )

c*********************************************************************72
c
cc TEST10 tests SROTG.
c
c  Licensing:
c
c    This code is distributed under the GNU LGPL license.
c
c  Modified:
c
c    15 May 2006
c
c  Author:
c
c    John Burkardt
c
      implicit none

      integer n
      parameter ( n = 6 )

      real a
      real b
      real c
      real r
      real r4_uniform_01
      real s
      real sa
      real sb
      integer seed
      integer test
      integer test_num
      parameter ( test_num = 5 )
      real z

      write ( *, '(a)' ) ' '
      write ( *, '(a)' ) 'TEST10'
      write ( *, '(a)' ) '  SROTG generates a real Givens rotation'
      write ( *, '(a)' ) '    (  C  S ) * ( A ) = ( R )'
      write ( *, '(a)' ) '    ( -S  C )   ( B )   ( 0 )'
      write ( *, '(a)' ) ' '

      seed = 123456789

      do test = 1, test_num

        a = r4_uniform_01 ( seed )
        b = r4_uniform_01 ( seed )

        sa = a
        sb = b

        call srotg ( sa, sb, c, s )

        r = sa
        z = sb

        write ( *, '(a)' ) ' '
        write ( *, '(a,g14.6,a,g14.6)' ) '  A =  ', a,  '  B =  ', b
        write ( *, '(a,g14.6,a,g14.6)' ) '  C =  ', c,  '  S =  ', s
        write ( *, '(a,g14.6,a,g14.6)' ) '  R =  ', r,  '  Z =  ', z
        write ( *, '(a,g14.6)' ) '   C*A+S*B = ',  c * a + s * b
        write ( *, '(a,g14.6)' ) '  -S*A+C*B = ', -s * a + c * b

      end do

      return
      end
      subroutine test11 ( )

c*********************************************************************72
c
cc TEST11 tests SSCAL.
c
c  Licensing:
c
c    This code is distributed under the GNU LGPL license.
c
c  Modified:
c
c    22 February 2006
c
c  Author:
c
c    John Burkardt
c
      implicit none

      integer n

      parameter ( n = 6 )

      real da
      integer i
      real x(n)

      do i = 1, n
        x(i) = real ( i )
      end do

      write ( *, '(a)' ) ' '
      write ( *, '(a)' ) 'TEST11'
      write ( *, '(a)' ) '  SSCAL multiplies a vector by a scalar.'
      write ( *, '(a)' ) ' '
      write ( *, '(a)' ) '  X = '
      write ( *, '(a)' ) ' '
      do i = 1, n
        write ( *, '(2x,i6,g14.6)' ) i, x(i)
      end do

      da = 5.0E+00
      call sscal ( n, da, x, 1 )
      write ( *, '(a)' ) ' '
      write ( *, '(a,f8.4,a)' ) '  SSCAL ( N, ', da, ', X, 1 )'
      write ( *, '(a)' ) ' '
      do i = 1, n
        write ( *, '(2x,i6,g14.6)' ) i, x(i)
      end do

      do i = 1, n
        x(i) = real ( i )
      end do

      da = -2.0E+00
      call sscal ( 3, da, x, 2 )
      write ( *, '(a)' ) ' '
      write ( *, '(a,f8.4,a)' ) '  SSCAL ( 3, ', da, ', X, 2 )'
      write ( *, '(a)' ) ' '
      do i = 1, n
        write ( *, '(2x,i6,g14.6)' ) i, x(i)
      end do

      return
      end
      subroutine test12 ( )

c*********************************************************************72
c
cc TEST12 tests SSWAP.
c
c  Licensing:
c
c    This code is distributed under the GNU LGPL license.
c
c  Modified:
c
c    22 February 2006
c
c  Author:
c
c    John Burkardt
c
      implicit none

      integer n

      parameter ( n = 6 )

      integer i
      real x(n)
      real y(n)

      do i = 1, n
        x(i) = real ( i )
      end do

      do i = 1, n
        y(i) = real ( 100 * i )
      end do

      write ( *, '(a)' ) ' '
      write ( *, '(a)' ) 'TEST12'
      write ( *, '(a)' ) '  SSWAP swaps two vectors.'
      write ( *, '(a)' ) ' '
      write ( *, '(a)' ) '  X and Y'
      write ( *, '(a)' ) ' '
      do i = 1, n
        write ( *, '(2x,i6,g14.6,g14.6)' ) i, x(i), y(i)
      end do

      call sswap ( n, x, 1, y, 1 )
      write ( *, '(a)' ) ' '
      write ( *, '(a)' ) '  SSWAP ( N, X, 1, Y, 1 )'
      write ( *, '(a)' ) ' '
      write ( *, '(a)' ) '  X and Y'
      write ( *, '(a)' ) ' '
      do i = 1, n
        write ( *, '(2x,i6,g14.6,g14.6)' ) i, x(i), y(i)
      end do

      do i = 1, n
        x(i) = real ( i )
      end do

      do i = 1, n
        y(i) = real ( 100 * i )
      end do

      call sswap ( 3, x, 2, y, 1 )
      write ( *, '(a)' ) ' '
      write ( *, '(a,f8.4,a)' ) '  SSWAP ( 3, X, 2, Y, 1 )'
      write ( *, '(a)' ) ' '
      write ( *, '(a)' ) '  X and Y'
      write ( *, '(a)' ) ' '
      do i = 1, n
        write ( *, '(2x,i6,g14.6,g14.6)' ) i, x(i), y(i)
      end do

      return
      end


!---------------------------------------------------------------------------------------------------
! All the formulations  have been taken from the original
! article,the Span-Wagner EoS for CO2.
! The EoS has been published in J. Phys. Chem. Ref. Data, Vol.25,
! pp. 1509-1596, 1996.
!---------------------------------------------------------------------------------------------------

!--------------------------------------------------------------------------------------------------
! SUBROUTINE   deriv_expfonc
! @brief   Compute expotential fuction Psi p.1545 Table 32
! @comments All exponential fuctions and their derivatives are involved
! only in termes 40-42 of the residual parts
! @authors Yu Fang
! @date    26-10-2016
!----------------------------------------------------------------------------------------------------
SUBROUTINE   deriv_expfonc( T, v, psi40, psi41, psi42,&
                            dpsi_ddelt40, dpsi_ddelt41, dpsi_ddelt42,&
                            dpsi_dtau40, dpsi_dtau41, dpsi_dtau42,&
                            ddpsi_dddelt40, ddpsi_dddelt41, ddpsi_dddelt42,&
                            ddpsi_ddtau40, ddpsi_ddtau41, ddpsi_ddtau42,&
                            ddpsi_ddeltdtau40, ddpsi_ddeltdtau41, ddpsi_ddeltdtau42 )

     USE def_constants

     IMPLICIT NONE

!IN/OUT

     REAL(pr) :: T,v

     REAL(pr) :: psi40, psi41, psi42

     REAL(pr) :: dpsi_ddelt40, dpsi_ddelt41, dpsi_ddelt42,&
                 dpsi_dtau40, dpsi_dtau41, dpsi_dtau42

     REAL(pr) :: ddpsi_dddelt40, ddpsi_dddelt41, ddpsi_dddelt42,&
                 ddpsi_ddtau40, ddpsi_ddtau41, ddpsi_ddtau42,&
                 ddpsi_ddeltdtau40, ddpsi_ddeltdtau41,ddpsi_ddeltdtau42

!LOCAL

    REAL(pr) :: tau, delt, rho

    REAL(pr) :: deltm1,deltm1_s, taum1,taum1_s

!Preparation of  variables

    rho        = 1_pr    / v
    delt       = 1_pr    / (rho_cr*v)
    tau        = T_cr    / T
!
!
    deltm1     = delt    - 1_pr
    deltm1_s   = deltm1  * deltm1
    taum1      = tau     - 1_pr
    taum1_s    = taum1   * taum1
!
!
    psi40 = exp(- CC40 * deltm1_s - DD40 * taum1_s)
    psi41 = exp(- CC41 * deltm1_s - DD40 * taum1_s)
    psi42 = exp(- CC42 * deltm1_s - DD40 * taum1_s)
!
!
!-----------------------------------------------------------------------------------------------------------
!Compute derivatives of psi 40-42
!-----------------------------------------------------------------------------------------------------------

    dpsi_ddelt40 = - 2_pr * CC40 * deltm1 * psi40

    dpsi_ddelt41 = - 2_pr * CC41 * deltm1 * psi41

    dpsi_ddelt42 = - 2_pr * CC42 * deltm1 * psi42
!
!
    dpsi_dtau40  = - 2_pr * DD40 * taum1 * psi40

    dpsi_dtau41  = - 2_pr * DD40 * taum1 * psi41

    dpsi_dtau42  = - 2_pr * DD40 * taum1 * psi42
!
!
    ddpsi_dddelt40 = (2_pr * CC40 * deltm1_s - 1_pr) * 2_pr * CC40 * psi40

    ddpsi_dddelt41 = (2_pr * CC41 * deltm1_s - 1_pr) * 2_pr * CC41 * psi41

    ddpsi_dddelt42 = (2_pr * CC42 * deltm1_s - 1_pr) * 2_pr * CC42 * psi42
!
!
    ddpsi_ddtau40 = (2_pr * DD40 * taum1_s - 1_pr) * 2_pr * DD40 * psi40

    ddpsi_ddtau41 = (2_pr * DD40 * taum1_s - 1_pr) * 2_pr * DD40 * psi41

    ddpsi_ddtau42 = (2_pr * DD40 * taum1_s - 1_pr) * 2_pr * DD40 * psi42
!
!
    ddpsi_ddeltdtau40 = 4_pr * CC40 * DD40 * deltm1 * taum1 * psi40

    ddpsi_ddeltdtau41 = 4_pr * CC41 * DD40 * deltm1 * taum1 * psi41

    ddpsi_ddeltdtau42 = 4_pr * CC42 * DD40 * deltm1 * taum1 * psi42
!
!
END SUBROUTINE deriv_expfonc


C Copyright(C) 1999-2020 National Technology & Engineering Solutions
C of Sandia, LLC (NTESS).  Under the terms of Contract DE-NA0003525 with
C NTESS, the U.S. Government retains certain rights in this software.
C
C See packages/seacas/LICENSE for details

C=======================================================================
      SUBROUTINE GAUSSF (IS3DIM, NLNKF, LINKF1, XN, YN, ZN,
     &   XGAUSS, YGAUSS, ZGAUSS)
C=======================================================================

C   --*** GAUSSF *** (DETOUR) Calculate gauss point for a face
C   --   Written by Amy Gilkey - revised 10/20/87
C   --
C   --GAUSSF calculates the 4 element gauss points given the coordinates
C   --of the 4 nodes.
C   --
C   --Parameters:
C   --   IS3DIM - IN - true iff 3D versus 2D
C   --   NLNKF - IN - the number of nodes per face; must be 4
C   --   LINKF1 - IN - the connectivity for the face
C   --   XN, YN, ZN - IN - the nodal coordinates
C   --   XGAUSS, YGAUSS, ZGAUSS - OUT - the gauss point coordinates

      PARAMETER (S = .577350269189626)

      LOGICAL IS3DIM
      INTEGER LINKF1(NLNKF)
      REAL XN(*), YN(*), ZN(*)
      REAL XGAUSS(4), YGAUSS(4), ZGAUSS(4)

      REAL WT(4,4)
      LOGICAL FIRST
      SAVE FIRST, WT
C      --FIRST - true iff first time in routine
C      --WT - the gauss point constants

      DATA FIRST /.TRUE./

      IF (FIRST) THEN
         FIRST = .FALSE.

C      --Determine gauss point constants

         DO 100 N = 1, 4
            IF (N .EQ. 1) THEN
               SI = -S
               TI = -S
            ELSE IF (N .EQ. 2) THEN
               SI = +S
               TI = -S
            ELSE IF (N .EQ. 3) THEN
               SI = +S
               TI = +S
            ELSE IF (N .EQ. 4) THEN
               SI = -S
               TI = +S
            END IF
            WT(1,N) = .25 * (1-SI) * (1-TI)
            WT(2,N) = .25 * (1+SI) * (1-TI)
            WT(3,N) = .25 * (1+SI) * (1+TI)
            WT(4,N) = .25 * (1-SI) * (1+TI)
  100    CONTINUE
      END IF

C   --Determine gauss point coordinates

      DO 110 N = 1, 4
         XGAUSS(N) = WT(1,N)*XN(LINKF1(1)) + WT(2,N)*XN(LINKF1(2))
     &      + WT(3,N)*XN(LINKF1(3)) + WT(4,N)*XN(LINKF1(4))
         YGAUSS(N) = WT(1,N)*YN(LINKF1(1)) + WT(2,N)*YN(LINKF1(2))
     &      + WT(3,N)*YN(LINKF1(3)) + WT(4,N)*YN(LINKF1(4))
         IF (IS3DIM) THEN
            ZGAUSS(N) = WT(1,N)*ZN(LINKF1(1)) + WT(2,N)*ZN(LINKF1(2))
     &         + WT(3,N)*ZN(LINKF1(3)) + WT(4,N)*ZN(LINKF1(4))
         END IF
  110 CONTINUE

      RETURN
      END


      program tipcalc
      implicit none
      double precision :: a, b, y, z

      write(*,'("Enter subtotal:")')
      read (*,*) a
      write(*,'("Enter tip percentage:")')
      read (*,*) b
      y=a*(b/100)
      z=y+a
      write(*,'("Tip: ", f12.2)')  y
      write(*,'("Total:", f12.2)')  z
      stop
      end


program tsunami

  ! Tsunami simulator
  !
  ! Solves the non-linear 1-d shallow water equation:
  !
  !     du/dt + u du/dx + g dh/dx = 0
  !     dh/dt + d(hu)/dx = 0
  !
  ! This version is parallelized.

  use iso_fortran_env, only: int32, real32
  use mod_diff, only: diff => diff_centered
  use mod_parallel, only: tile_indices, tile_neighbors

  implicit none

  integer(int32) :: i, n

  integer(int32), parameter :: grid_size = 100 ! grid size in x
  integer(int32), parameter :: num_time_steps = 5000 ! number of time steps

  real(real32), parameter :: dt = 0.02 ! time step [s]
  real(real32), parameter :: dx = 1 ! grid spacing [m]
  real(real32), parameter :: g = 9.8 ! gravitational acceleration [m/s]

  real(real32), allocatable :: h(:)[:], u(:)[:]
  real(real32), allocatable :: gather(:)[:]
  real(real32), allocatable :: hmean(:)

  integer(int32), parameter :: ipos = 25
  real(real32), parameter :: decay = 0.02

  integer(int32) :: indices(2), neighbors(2)
  integer(int32) :: left, right
  integer(int32) :: is, ie ! global start and end indices
  integer(int32) :: ils, ile ! local start and end computational indices
  integer(int32) :: ims, ime ! local start and end memory indices
  integer(int32) :: tile_size

  if (mod(grid_size, num_images()) > 0) then
    error stop 'Error: grid_size must be divisible by number of images'
  end if

  neighbors = tile_neighbors()
  left = neighbors(1)
  right = neighbors(2)

  indices = tile_indices(grid_size)
  is = indices(1)
  ie = indices(2)

  tile_size = grid_size / num_images()
  ils = 1
  ile = tile_size
  ims = ils - 1
  ime = ile + 1

  allocate(h(ims:ime)[*])
  allocate(u(ims:ime)[*])
  allocate(hmean(ims:ime))

  allocate(gather(grid_size)[*])

  ! initialize a gaussian blob centered at i = 25
  do i = is - 1, ie + 1
    h(i-is+1) = exp(-decay * (i - ipos)**2)
  end do

  ! set initial velocity and mean water depth
  u = 0
  hmean = 10

  ! gather to image 1 and write current state to screen
  gather(is:ie)[1] = h(ils:ile)
  sync all
  if (this_image() == 1) print *, 0, gather

  time_loop: do n = 1, num_time_steps

    ! update halo for h
    h(ime)[left] = h(ils)
    h(ims)[right] = h(ile)
    sync all

    ! compute u at next time step
    u = u - (u * diff(u) + g * diff(h)) / dx * dt

    sync all

    ! update halo for u
    u(ime)[left] = u(ils)
    u(ims)[right] = u(ile)
    sync all

    ! compute h at next time step
    h = h - diff(u * (hmean + h)) / dx * dt

    ! gather to image 1 and write current state to screen
    gather(is:ie)[1] = h(ils:ile)
    sync all
    if (this_image() == 1) print *, n, gather

  end do time_loop

end program tsunami


      K = N/2
      MEDIAN = FINDELEMENT(K + 1,A,N)
      IF (MOD(N,2).EQ.0) MEDIAN = (FINDELEMENT(K,A,N) + MEDIAN)/2


module solvers
   implicit none
   integer, parameter :: wp = selected_real_kind(15,307)
   real(wp), parameter :: pi = 3.141592653d0
   real(wp), parameter :: nu = 0.005d0
   real(wp), parameter :: CFL = 0.3d0
   integer, parameter :: nx = 400
   real(wp), allocatable :: ts(:)
   real(wp) :: dx, dt, C, dxi, dtp, dta

 contains
   !> @brief initialize the distribution
   subroutine initialize(x,u)
     real(wp), dimension(0:nx+1), intent(out) :: x, u
     real(wp) :: nn
     integer :: i, N

     dx = 1d0/real(nx - 1)
     dxi = 1d0/dx
     x(1) = 0d0; x(0) = x(1) - dx
     do i=2,nx+1
        x(i) = x(i-1) + dx
     enddo

     do i=0,nx+1
        u(i) = sin(pi*x(i))
     enddo

     dt = CFL*dx*dx
     print *,"Parameters:"
     print *,"   dx:",dx
     print *,"   dt:",dt
     print *,"  cfl:",dt/dx/dx

! compute STS substeps
     dtp = dt
     dta = CFL*dx

     nn = FindRoot(1d0, dtp, dta)
     N = int(nn) + 1
     allocate(ts(N))
     dtp = CorrectTimeStep(N, dta)
     CALL ComputeSubSteps(dtp, ts)
   end subroutine initialize

   !> @brief Compute Crank-Nicolson step
   subroutine crank(t,x,u)
     real(wp), intent(in) :: t
     real(wp), dimension(0:nx+1), intent(in) :: x
     real(wp), dimension(0:nx+1), intent(inout) :: u
     real(wp), dimension(1:nx) :: a, b, c, d, un
     real(wp) :: r
     integer :: i

     r = dta*dxi*dxi;
     do i=1,nx
        a(i) = -r/2d0
        b(i) = 1d0 + r
        c(i) = -r/2d0
        d(i) = u(i)*(1d0 - r) + (0.5d0*r)*(u(i+1) + u(i-1))
     enddo

     call tridiag(a,b,c,d,un)
     u(1:nx) = un(1:nx)
     call bc(t+dta,x,u)

   end subroutine crank

   !> @brief Tridiagonal matrix solver algorithm
   subroutine tridiag(a,b,c,d,un)
      real(wp), dimension(1:nx), intent(in) :: a,b,c,d
      real(wp), dimension(1:nx), intent(out) :: un
      real(wp), dimension(1:nx)  :: dp, cp
      real(wp) :: m
      integer :: i
! initialize c' and d'
      cp(1) = c(1)/b(1)
      dp(1) = d(1)/b(1)
! upwards sweep
      do i=2,nx
         m = b(i) - cp(i-1)*a(i)
         cp(i) = c(i)/m
         dp(i) = (d(i) - dp(i-1)*a(i))/m
      enddo
! downwards sweep
      un(nx) = dp(nx)
      do i=nx-1,1,-1
         un(i) = dp(i) - cp(i)*un(i+1)
      enddo
   end subroutine tridiag

   !> @brief Compute heat equation using super time-stepping algorithm
   subroutine super(t,x,u)
     real(wp), intent(in) :: t
     real(wp), dimension(0:nx+1), intent(in) :: x
     real(wp), dimension(0:nx+1), intent(inout) :: u
     real(wp), dimension(0:nx+1) :: un, up, phi
     real(wp) :: tau, r, tstep
     integer :: i, m

     tstep = t
     phi = 0d0; un = u
     do m=1,N
        tau = ts(m)
        r = tau*dxi
        tstep = tstep + tau
! compute grad(u) using backwards difference
        do i=1,nx+1
           phi(i) = (up(i) - up(i-1))*dxi
        enddo
! compute u(n+1) using forwards difference
!   - this is effectively a Lax-Wendroff method for parabolic methods
        do i=1,nx
           un(i) = un(i) + r*(phi(i+1) - phi(i))
        enddo
        call bc(tstep,x,un)
     enddo
     u(1:150) = un(1:150)
   end subroutine super

   !> @brief Determines optimal number of STS substeps
   function FindRoot(x0, dtr, dta) result(NS)
     real(wp), intent(in) :: x0, dtr, dta
     real(wp) :: NS, a, b, c, N1, rt_nu

     NS = x0 + 1d0
     N1 = x0
     rt_nu = sqrt(nu)
     do while(abs(NS - N1) >= 1d-5)
        NS = N1
        a = (1d0 - rt_nu)/(1d0 + rt_nu)
        b = a**(2d0*NS)
        c = (1d0 - b)/(1d0 + b)
        N1 = NS + (dta - dtr*NS/(2d0*rt_nu)*c)/(dtr/(2d0*rt_nu)*(c - 2d0*NS*b*log(a)*(1d0+c)/(1d0+b)))
     enddo
   end function FindRoot

   !> @brief Corrects the parabolic time step for use in STS method
   pure function CorrectTimeStep(n0, dta) result(dtr)
     integer, intent(in) :: n0
     real(wp), intent(in) :: dta
     real(wp) :: a, b, c, dtr, rt_nu

     rt_nu = sqrt(nu)
     a = (1d0 - rt_nu)/(1d0 + rt_nu)
     b = a**(2*n0)
     c = (1d0 - b)/(1d0 + b)
     dtr = dta*2d0*rt_nu/(n0*c)
   end function CorrectTimeStep

   !> @brief Determines the substeps for STS method
   subroutine ComputeSubSteps(dtex, tau)
     real(wp), intent(in) :: dtex
     real(wp), intent(out) :: tau(:)
     real(wp) :: s
     integer :: j

     s = real(size(tau))
     do j=1,size(tau)
        tau(j) = dtex / ((-1d0 + nu)*cos(((2d0*j - 1d0)*pi)/(2d0*s))  +  1d0  +  nu);
     enddo
   end subroutine ComputeSubSteps

   !> @brief Adjusts the boundary conditions
   subroutine bc(t,x,u)
     real(wp), intent(in) :: t
     real(wp), dimension(0:nx+1), intent(in) :: x
     real(wp), dimension(0:nx+1), intent(inout) :: u

     u(0) = sin(pi*x(0))*exp(-pi*pi*t)
     u(nx+1) = sin(pi*x(nx+1))*exp(-pi*pi*t)
   end subroutine

end module solvers


C
C	$Id: rgbyiq.f,v 1.7 2008-07-27 00:16:54 haley Exp $
C
C                Copyright (C)  2000
C        University Corporation for Atmospheric Research
C                All Rights Reserved
C
C The use of this Software is governed by a License Agreement.
C
      SUBROUTINE RGBYIQ ( R, G, B, Y, I, Q )
C
C_BEGIN PROLOGUE RGBYIQ
C
C_PURPOSE
C    This subroutine converts a color specification given as
C    Red, Green, and Blue intensity values to a color specification
C    in the YIQ color space.
C
C_DESCRIPTION
C    This subroutine converts color values given in the
C    Red, Green, Blue (RGB) color space to color values
C    in the YIQ color space.  The input Red, Green,
C    and Blue values are intensities in the range [0.,1.] .
C
C_ARGUMENTS
C
C R       (INPUT,SINGLE,VARIABLE)  A real variable in the range
C         [0.,1.] which represents the red intensity component
C         of the input point in RGB color space.
C
C G       (INPUT,SINGLE,VARIABLE)  A real variable in the range
C         [0.,1.] which represents the green intensity component
C         of the input point in RGB color space.
C
C B       (INPUT,SINGLE,VARIABLE)  A real variable in the range
C         [0.,1.] which represents the blue intensity component
C         of the input point in RGB color space.
C
C Y       (OUTPUT,SINGLE,VARIABLE)  A real variable in the range
C         [0.,1.] .  Y is the color component of a television
C         signal which is shown on black-and-white televisions;
C         Y minimizes the effect of two colors appearing different
C         to the human eye but mapping to similar monochrome
C         intensities.
C
C I       (OUTPUT,SINGLE,VARIABLE)  A real variable in the range
C         [-.6,.6] .  I attains its maximum when the input triple
C         is (1.,0.,0.); I attains its minimum when the input triple
C         is (0.,1.,1.) .
C
C Q       (OUTPUT,SINGLE,VARIABLE)  A real variable in the range
C         [-.52,.52].  Q attains its maximum when the input triple
C         is (1.,0.,1.); Q attains its minimum when the input triple
C         is (0.,1.,0.).
C
C_I/O
C    (NONE)
C
C_ROUTINES CALLED
C    (NONE)
C
C_COMMON BLOCKS
C    (NONE)
C
C_MAXIMUM GKS LEVEL
C    (NONE)
C
C_LANGUAGE
C    FORTRAN
C
C_REVISION DATE
C    880511 (YYMMDD)
C
C_HISTORY
C    This subroutine was originally coded and prepared for the
C    NCAR Graphics package by Fred Clare based on algorithms
C    in Foley and van Dam (see REFERENCES below).
C
C_REFERENCES
C    Foley, James D. and van Dam, Andries,"Fundamentals of Interactive
C    Computer Graphics",Addison-Wesley Publishing Company, 1982.
C
C_EXAMPLES
C    Example 1 --  Full white to YIQ.
C          SUBROUTINE TYIQ1
C          REAL    Y,I,Q,EPS
C          PARAMETER (EPS=0.01)
C          CALL RGBYIQ(1.,1.,1.,Y,I,Q)
C          IF ( (ABS(Y-1.) .GT. EPS) .OR. (ABS(I) .GT. EPS) .OR.
C         *     (ABS(Q) .GT. EPS) ) THEN
C            IUN = I1MACH(4)
C            WRITE(IUN,10)
C          ENDIF
C          RETURN
C       10 FORMAT(' TYIQ1 returned incorrect values')
C          END
C
C_END PROLOGUE RGBYIQ
C
      REAL R,G,B,Y,I,Q
C
C_FIRST EXECUTABLE STATEMENT RGBYIQ
      Y = 0.2988922*R +  0.5870147*G + 0.1140931*B
      I = 0.5960695*R -  0.2743087*G - 0.3217608*B
      Q = 0.2113775*R -  0.5229881*G + 0.3116106*B
C
      RETURN
      END


      SUBROUTINE slAV2M (AXVEC, RMAT)
*+
*     - - - - -
*      A V 2 M
*     - - - - -
*
*  Form the rotation matrix corresponding to a given axial vector.
*
*  (single precision)
*
*  A rotation matrix describes a rotation about some arbitrary axis,
*  called the Euler axis.  The "axial vector" supplied to this routine
*  has the same direction as the Euler axis, and its magnitude is the
*  amount of rotation in radians.
*
*  Given:
*    AXVEC  r(3)     axial vector (radians)
*
*  Returned:
*    RMAT   r(3,3)   rotation matrix
*
*  If AXVEC is null, the unit matrix is returned.
*
*  The reference frame rotates clockwise as seen looking along
*  the axial vector from the origin.
*
*  Last revision:   26 November 2005
*
*  Copyright P.T.Wallace.  All rights reserved.
*
*  License:
*    This program is free software; you can redistribute it and/or modify
*    it under the terms of the GNU General Public License as published by
*    the Free Software Foundation; either version 2 of the License, or
*    (at your option) any later version.
*
*    This program is distributed in the hope that it will be useful,
*    but WITHOUT ANY WARRANTY; without even the implied warranty of
*    MERCHANTABILITY or FITNESS FOR A PARTICULAR PURPOSE.  See the
*    GNU General Public License for more details.
*
*    You should have received a copy of the GNU General Public License
*    along with this program (see SLA_CONDITIONS); if not, write to the
*    Free Software Foundation, Inc., 51 Franklin Street, Fifth Floor,
*    Boston, MA  02110-1301  USA
*
*  Copyright (C) 1995 Association of Universities for Research in Astronomy Inc.
*-

      IMPLICIT NONE

      REAL AXVEC(3),RMAT(3,3)

      REAL X,Y,Z,PHI,S,C,W

*  Rotation angle - magnitude of axial vector - and functions
      X = AXVEC(1)
      Y = AXVEC(2)
      Z = AXVEC(3)
      PHI = SQRT(X*X+Y*Y+Z*Z)
      S = SIN(PHI)
      C = COS(PHI)
      W = 1.0-C

*  Euler axis - direction of axial vector (perhaps null)
      IF (PHI.NE.0.0) THEN
         X = X/PHI
         Y = Y/PHI
         Z = Z/PHI
      END IF

*  Compute the rotation matrix
      RMAT(1,1) = X*X*W+C
      RMAT(1,2) = X*Y*W+Z*S
      RMAT(1,3) = X*Z*W-Y*S
      RMAT(2,1) = X*Y*W-Z*S
      RMAT(2,2) = Y*Y*W+C
      RMAT(2,3) = Y*Z*W+X*S
      RMAT(3,1) = X*Z*W+Y*S
      RMAT(3,2) = Y*Z*W-X*S
      RMAT(3,3) = Z*Z*W+C

      END


!===============================================================================
!
! Module:
!
! so32su2        By Meng Wu
!
! Find one of the U(2) matrix corresponding to a O(3) rotation
!
! ==============================================

#include "f_defs.h"

module so32su2_m
  use global_m

  implicit none
  private
  public :: so32su2

contains

  subroutine so32su2(Rmatrix, umatrix)
    real(DP), dimension(3,3) :: Rmatrix ! cartesian coordinates
    ! LatVec(1:3,1:3) is the lattice vectors in cartesian coordinates
    ! LatVec(1:3,i) is the i-th lattice vector
    ! umatrix(1:2,1:2) is the U(2) matrix corresponding to the Rmatrix O(3) rotation
    complex(DPC), dimension(2,2), intent(out) :: umatrix
    ! eps10 is a small number
    real(DP), parameter :: eps10 = 1.0D-10
    ! imaginary unit, (0+1j)
    complex(DPC), parameter :: ii=(0,1)
    real(DP) :: alpha, beta, gamma
    real(DP), parameter :: Pi = 3.14159265358979323846
    real(DP) :: sinbeta, Rdet
    ! for proper rotation: ifprop = .true.
    ! for improper rotation: ifprop = .false.
    logical :: ifprop = .true.

    ! ------------------------------------
    ! Calculate determinant of Rmatrix(i,j)
    Rdet = Rmatrix(1,1)*(Rmatrix(2,2)*Rmatrix(3,3) - Rmatrix(3,2)*Rmatrix(2,3)) &
         + Rmatrix(1,2)*(Rmatrix(3,1)*Rmatrix(2,3) - Rmatrix(2,1)*Rmatrix(3,3))  &
         + Rmatrix(1,3)*(Rmatrix(2,1)*Rmatrix(3,2) - Rmatrix(3,1)*Rmatrix(2,2))

    if (abs(Rdet-1.0) < eps10) then
       ! 'Proper rotation'
       ifprop = .true.

    elseif (abs(Rdet+1.0) < eps10) then
       ! 'Improper rotation'
       ifprop = .false.
       Rmatrix = - Rmatrix
    else
       write(*,*) 'Error in so32su2()!!!'
       call EXIT(1)
    endif

    if (abs(Rmatrix(3,3)-1.0) < eps10) then
       beta = 0
       gamma = 0
       alpha = atan2(Rmatrix(2,1),Rmatrix(1,1))
    elseif (abs(Rmatrix(3,3)+1.0) < eps10) THEN
       beta = Pi;
       gamma = 0;
       alpha = - atan2(Rmatrix(1,2),Rmatrix(2,2))
    else
       sinbeta=sqrt(1-Rmatrix(3,3)*Rmatrix(3,3));
       beta=atan2(sinbeta,Rmatrix(3,3));
       alpha=atan2(Rmatrix(2,3)/sinbeta,Rmatrix(1,3)/sinbeta);
       gamma=atan2(Rmatrix(3,2)/sinbeta,-Rmatrix(3,1)/sinbeta);
    endif

    umatrix(1,1) = exp(-ii*(alpha+gamma)/2.0)*cos(beta/2.0)
    umatrix(1,2) = -exp(-ii*(alpha-gamma)/2.0)*sin(beta/2.0)
    umatrix(2,1) = exp(ii*(alpha-gamma)/2.0)*sin(beta/2.0)
    umatrix(2,2) = exp(ii*(alpha+gamma)/2.0)*cos(beta/2.0)

    ! if we have improper rotation, we need to multiply the umatrix by {{i,0},{i,0}}
    if (ifprop .eqv. .false.) then
       ! we have I [spinor] = \pm spinor
       ! take +1 as prefactor will not change the value of matrix elements
       ! umatrix = ii*umatrix
       umatrix = umatrix
    endif

  end subroutine so32su2

end module so32su2_m


      SUBROUTINE SB03MW( LTRAN, LUPPER, T, LDT, B, LDB, SCALE, X, LDX,
     $                   XNORM, INFO )
C
C     SLICOT RELEASE 5.7.
C
C     Copyright (c) 2002-2020 NICONET e.V.
C
C     PURPOSE
C
C     To solve for the 2-by-2 symmetric matrix X in
C
C            op(T)'*X + X*op(T) = SCALE*B,
C
C     where T is 2-by-2, B is symmetric 2-by-2, and op(T) = T or T',
C     where T' denotes the transpose of T.
C
C     ARGUMENTS
C
C     Mode Parameters
C
C     LTRAN   LOGICAL
C             Specifies the form of op(T) to be used, as follows:
C             = .FALSE.:  op(T) = T,
C             = .TRUE. :  op(T) = T'.
C
C     LUPPER  LOGICAL
C             Specifies which triangle of the matrix B is used, and
C             which triangle of the matrix X is computed, as follows:
C             = .TRUE. :  The upper triangular part;
C             = .FALSE.:  The lower triangular part.
C
C     Input/Output Parameters
C
C     T       (input) DOUBLE PRECISION array, dimension (LDT,2)
C             The leading 2-by-2 part of this array must contain the
C             matrix T.
C
C     LDT     INTEGER
C             The leading dimension of array T.  LDT >= 2.
C
C     B       (input) DOUBLE PRECISION array, dimension (LDB,2)
C             On entry with LUPPER = .TRUE., the leading 2-by-2 upper
C             triangular part of this array must contain the upper
C             triangular part of the symmetric matrix B and the strictly
C             lower triangular part of B is not referenced.
C             On entry with LUPPER = .FALSE., the leading 2-by-2 lower
C             triangular part of this array must contain the lower
C             triangular part of the symmetric matrix B and the strictly
C             upper triangular part of B is not referenced.
C
C     LDB     INTEGER
C             The leading dimension of array B.  LDB >= 2.
C
C     SCALE   (output) DOUBLE PRECISION
C             The scale factor. SCALE is chosen less than or equal to 1
C             to prevent the solution overflowing.
C
C     X       (output) DOUBLE PRECISION array, dimension (LDX,2)
C             On exit with LUPPER = .TRUE., the leading 2-by-2 upper
C             triangular part of this array contains the upper
C             triangular part of the symmetric solution matrix X and the
C             strictly lower triangular part of X is not referenced.
C             On exit with LUPPER = .FALSE., the leading 2-by-2 lower
C             triangular part of this array contains the lower
C             triangular part of the symmetric solution matrix X and the
C             strictly upper triangular part of X is not referenced.
C             Note that X may be identified with B in the calling
C             statement.
C
C     LDX     INTEGER
C             The leading dimension of array X.  LDX >= 2.
C
C     XNORM   (output) DOUBLE PRECISION
C             The infinity-norm of the solution.
C
C     Error Indicator
C
C     INFO    INTEGER
C             = 0:  successful exit;
C             = 1:  if T and -T have too close eigenvalues, so T
C                   is perturbed to get a nonsingular equation.
C
C             NOTE: In the interests of speed, this routine does not
C                   check the inputs for errors.
C
C     METHOD
C
C     The equivalent linear algebraic system of equations is formed and
C     solved using Gaussian elimination with complete pivoting.
C
C     REFERENCES
C
C     [1] Anderson, E., Bai, Z., Bischof, C., Demmel, J., Dongarra, J.,
C         Du Croz, J., Greenbaum, A., Hammarling, S., McKenney, A.,
C         Ostrouchov, S., and Sorensen, D.
C         LAPACK Users' Guide: Second Edition.
C         SIAM, Philadelphia, 1995.
C
C     NUMERICAL ASPECTS
C
C     The algorithm is stable and reliable, since Gaussian elimination
C     with complete pivoting is used.
C
C     CONTRIBUTOR
C
C     Release 3.0: V. Sima, Katholieke Univ. Leuven, Belgium, May 1997.
C     Based on DLALY2 by P. Petkov, Tech. University of Sofia, September
C     1993.
C
C     REVISIONS
C
C     -
C
C     KEYWORDS
C
C     Continuous-time system, Lyapunov equation, matrix algebra.
C
C     ******************************************************************
C
C     .. Parameters ..
      DOUBLE PRECISION   ZERO, ONE, TWO, FOUR
      PARAMETER          ( ZERO = 0.0D+0, ONE = 1.0D+0, TWO = 2.0D+0,
     $                     FOUR = 4.0D+0 )
C     ..
C     .. Scalar Arguments ..
      LOGICAL            LTRAN, LUPPER
      INTEGER            INFO, LDB, LDT, LDX
      DOUBLE PRECISION   SCALE, XNORM
C     ..
C     .. Array Arguments ..
      DOUBLE PRECISION   B( LDB, * ), T( LDT, * ), X( LDX, * )
C     ..
C     .. Local Scalars ..
      INTEGER            I, IP, IPSV, J, JP, JPSV, K
      DOUBLE PRECISION   EPS, SMIN, SMLNUM, TEMP, XMAX
C     ..
C     .. Local Arrays ..
      INTEGER            JPIV( 3 )
      DOUBLE PRECISION   BTMP( 3 ), T9( 3, 3 ), TMP( 3 )
C     ..
C     .. External Functions ..
      DOUBLE PRECISION   DLAMCH
      EXTERNAL           DLAMCH
C     ..
C     .. External Subroutines ..
      EXTERNAL           DSWAP
C     ..
C     .. Intrinsic Functions ..
      INTRINSIC          ABS, MAX
C     ..
C     .. Executable Statements ..
C
C     Do not check the input parameters for errors
C
      INFO = 0
C
C     Set constants to control overflow
C
      EPS = DLAMCH( 'P' )
      SMLNUM = DLAMCH( 'S' ) / EPS
C
C     Solve equivalent 3-by-3 system using complete pivoting.
C     Set pivots less than SMIN to SMIN.
C
      SMIN = MAX( MAX( ABS( T( 1, 1 ) ), ABS( T( 1, 2 ) ),
     $                 ABS( T( 2, 1 ) ), ABS( T( 2, 2 ) ) )*EPS,
     $            SMLNUM )
      T9( 1, 3 ) = ZERO
      T9( 3, 1 ) = ZERO
      T9( 1, 1 ) = T( 1, 1 )
      T9( 2, 2 ) = T( 1, 1 ) + T( 2, 2 )
      T9( 3, 3 ) = T( 2, 2 )
      IF( LTRAN ) THEN
         T9( 1, 2 ) = T( 1, 2 )
         T9( 2, 1 ) = T( 2, 1 )
         T9( 2, 3 ) = T( 1, 2 )
         T9( 3, 2 ) = T( 2, 1 )
      ELSE
         T9( 1, 2 ) = T( 2, 1 )
         T9( 2, 1 ) = T( 1, 2 )
         T9( 2, 3 ) = T( 2, 1 )
         T9( 3, 2 ) = T( 1, 2 )
      END IF
      BTMP( 1 ) = B( 1, 1 )/TWO
      IF ( LUPPER ) THEN
         BTMP( 2 ) = B( 1, 2 )
      ELSE
         BTMP( 2 ) = B( 2, 1 )
      END IF
      BTMP( 3 ) = B( 2, 2 )/TWO
C
C     Perform elimination
C
      DO 50 I = 1, 2
         XMAX = ZERO
C
         DO 20 IP = I, 3
C
            DO 10 JP = I, 3
               IF( ABS( T9( IP, JP ) ).GE.XMAX ) THEN
                  XMAX = ABS( T9( IP, JP ) )
                  IPSV = IP
                  JPSV = JP
               END IF
   10       CONTINUE
C
   20    CONTINUE
C
         IF( IPSV.NE.I ) THEN
            CALL DSWAP( 3, T9( IPSV, 1 ), 3, T9( I, 1 ), 3 )
            TEMP = BTMP( I )
            BTMP( I ) = BTMP( IPSV )
            BTMP( IPSV ) = TEMP
         END IF
         IF( JPSV.NE.I )
     $      CALL DSWAP( 3, T9( 1, JPSV ), 1, T9( 1, I ), 1 )
         JPIV( I ) = JPSV
         IF( ABS( T9( I, I ) ).LT.SMIN ) THEN
            INFO = 1
            T9( I, I ) = SMIN
         END IF
C
         DO 40 J = I + 1, 3
            T9( J, I ) = T9( J, I ) / T9( I, I )
            BTMP( J ) = BTMP( J ) - T9( J, I )*BTMP( I )
C
            DO 30 K = I + 1, 3
               T9( J, K ) = T9( J, K ) - T9( J, I )*T9( I, K )
   30       CONTINUE
C
   40    CONTINUE
C
   50 CONTINUE
C
      IF( ABS( T9( 3, 3 ) ).LT.SMIN )
     $   T9( 3, 3 ) = SMIN
      SCALE = ONE
      IF( ( FOUR*SMLNUM )*ABS( BTMP( 1 ) ).GT.ABS( T9( 1, 1 ) ) .OR.
     $    ( FOUR*SMLNUM )*ABS( BTMP( 2 ) ).GT.ABS( T9( 2, 2 ) ) .OR.
     $    ( FOUR*SMLNUM )*ABS( BTMP( 3 ) ).GT.ABS( T9( 3, 3 ) ) ) THEN
         SCALE = ( ONE / FOUR ) / MAX( ABS( BTMP( 1 ) ),
     $               ABS( BTMP( 2 ) ), ABS( BTMP( 3 ) ) )
         BTMP( 1 ) = BTMP( 1 )*SCALE
         BTMP( 2 ) = BTMP( 2 )*SCALE
         BTMP( 3 ) = BTMP( 3 )*SCALE
      END IF
C
      DO 70 I = 1, 3
         K = 4 - I
         TEMP = ONE / T9( K, K )
         TMP( K ) = BTMP( K )*TEMP
C
         DO 60 J = K + 1, 3
            TMP( K ) = TMP( K ) - ( TEMP*T9( K, J ) )*TMP( J )
  60     CONTINUE
C
  70  CONTINUE
C
      DO 80 I = 1, 2
         IF( JPIV( 3-I ).NE.3-I ) THEN
            TEMP = TMP( 3-I )
            TMP( 3-I ) = TMP( JPIV( 3-I ) )
            TMP( JPIV( 3-I ) ) = TEMP
         END IF
  80  CONTINUE
C
      X( 1, 1 ) = TMP( 1 )
      IF ( LUPPER ) THEN
         X( 1, 2 ) = TMP( 2 )
      ELSE
         X( 2, 1 ) = TMP( 2 )
      END IF
      X( 2, 2 ) = TMP( 3 )
      XNORM = MAX( ABS( TMP( 1 ) ) + ABS( TMP( 2 ) ),
     $             ABS( TMP( 2 ) ) + ABS( TMP( 3 ) ) )
C
      RETURN
C *** Last line of SB03MW ***
      END


module linalg
  use types, only: dp
  use lapack, only: dsyevd, dsygvd, ilaenv, zgetri, zgetrf, zheevd, &
       dgeev, zgeev, zhegvd, dgesv, zgesv, dgetrf, dgetri, dgelsy, zgelsy, &
       dgesvd, zgesvd
  use utils, only: stop_error
  use constants, only: i_
  implicit none
  private
  public eig, eigvals, eigh, inv, solve, eye, det, lstsq, diag, trace, &
       svdvals, svd

  ! eigenvalue/-vector problem for general matrices:
  interface eig
     module procedure deig
     module procedure zeig
  end interface eig

  ! eigenvalue/-vector problem for real symmetric/complex hermitian matrices:
  interface eigh
     module procedure deigh_generalized
     module procedure deigh_simple
     module procedure zeigh_generalized
     module procedure zeigh_simple
  end interface eigh

  ! eigenvalues for general matrices:
  interface eigvals
     module procedure deigvals
     module procedure zeigvals
  end interface eigvals

  ! matrix inversion for real/complex matrices:
  interface inv
     module procedure dinv
     module procedure zinv
  end interface inv

  ! solution to linear systems of equation with real/complex coefficients:
  interface solve
     module procedure dsolve
     module procedure zsolve
  end interface solve

  ! determinants of real/complex square matrices:
  interface det
     module procedure ddet
     module procedure zdet
  end interface det

  ! least square solutions the real/complex systems of equations of possibly non-square shape:
  interface lstsq
     module procedure dlstsq
     module procedure zlstsq
  end interface lstsq

  ! construction of square matrices from the diagonal elements:
  interface diag
     module procedure ddiag
     module procedure zdiag
  end interface diag

  ! trace of real/complex matrices:
  interface trace
     module procedure dtrace
     module procedure ztrace
  end interface trace

  ! singular values of real/complex matrices:
  interface svdvals
     module procedure dsvdvals
     module procedure zsvdvals
  end interface svdvals

  ! singular value decomposition of real/complex matrices:
  interface svd
     module procedure dsvd
     module procedure zsvd
  end interface svd

  ! assert shape of matrices:
  interface assert_shape
     module procedure dassert_shape
     module procedure zassert_shape
  end interface assert_shape

contains

  ! TODO: add optional switch for left or right eigenvectors in deig() and zeig()?
  subroutine deig(A, lam, c)
    real(dp), intent(in) :: A(:, :)  ! matrix for eigenvalue compuation
    complex(dp), intent(out) :: lam(:)  ! eigenvalues: A c = lam c
    complex(dp), intent(out) :: c(:, :)  ! eigenvectors: A c = lam c; c(i,j) = ith component of jth vec.
    ! LAPACK variables for DGEEV:
    real(dp), allocatable ::  At(:,:), vl(:,: ), vr(:,:), wi(:), work(:), wr(:)
    integer :: info, lda, ldvl, ldvr, lwork, n, i

    lda = size(A(:,1))
    n = size(A(1,:))
    call assert_shape(A, [n, n], "solve", "A")
    call assert_shape(c, [n, n], "solve", "c")
    ldvl = n
    ldvr = n
    lwork = 8*n  ! TODO: can this size be optimized? query first?
    allocate(At(lda,n), wr(n), wi(n), vl(ldvl,n), vr(ldvr,n), work(lwork))
    At = A

    call dgeev('N', 'V', n, At, lda, wr, wi, vl, ldvl, vr, ldvr, &
         work, lwork, info)
    if(info /= 0) then
       print *, "dgeev returned info = ", info
       if (info < 0) then
          print *, "the", -info, "-th argument had an illegal value"
       else
          print *, "the QR algorithm failed to compute all the"
          print *, "eigenvalues, and no eigenvectors have been computed;"
          print *, "elements ", info+1, ":", n, "of WR and WI contain eigenvalues which"
          print *, "have converged."
       end if
       call stop_error('eig: dgeev error')
    end if

    lam = wr + i_*wi
    ! as DGEEV has a rather complicated way of returning the eigenvectors,
    ! it is necessary to build the complex array of eigenvectors from
    ! two real arrays:
    do i = 1,n
       if(wi(i) > 0.0) then  ! first of two conjugate eigenvalues
          c(:, i) = vr(:, i) + i_*vr(:, i+1)
       elseif(wi(i) < 0.0_dp) then  ! second of two conjugate eigenvalues
          c(:, i) = vr(:, i-1) - i_*vr(:, i)
       else
          c(:, i) = vr(:, i)
       end if
    end do
  end subroutine deig

  subroutine zeig(A, lam, c)
    complex(dp), intent(in) :: A(:, :)  ! matrix to solve eigenproblem for
    complex(dp), intent(out) :: lam(:)  ! eigenvalues: A c = lam c
    complex(dp), intent(out) :: c(:,:)  ! eigenvectors: A c = lam c; c(i,j) = ith component of jth vec.
    ! LAPACK variables:
    integer :: info, lda, ldvl, ldvr, lwork, n, lrwork
    real(dp), allocatable :: rwork(:)
    complex(dp), allocatable :: vl(:,:), vr(:,:), work(:)

    lda = size(A(:,1))
    n = size(A(1,:))
    call assert_shape(A, [n, n], "solve", "A")
    call assert_shape(c, [n, n], "solve", "c")
    ldvl = n
    ldvr = n
    lwork = 8*n  ! TODO: can this size be optimized? query first?
    lrwork = 2*n
    allocate(vl(ldvl,n), vr(ldvr,n), work(lwork), rwork(lrwork))
    c = A
    call zgeev('N', 'V', n, c, lda, lam, vl, ldvl, vr, ldvr, work, &
         lwork, rwork, info)
    if(info /= 0) then
       print *, "zgeev returned info = ", info
       if(info < 0) then
          print *, "the ",-info, "-th argument had an illegal value."
       else
          print *, "the QR algorithm failed to compute all the"
          print *, "eigenvalues, and no eigenvectors have been computed;"
          print *, "elements and ", info+1, ":", n, " of W contain eigenvalues which have"
          print *, "converged."
       end if
       call stop_error('eig: zgeev error')
    end if
    c = vr
  end subroutine zeig

  function deigvals(A) result(lam)
    real(dp), intent(in) :: A(:, :)  ! matrix for eigenvalue compuation
    complex(dp), allocatable :: lam(:)  ! eigenvalues: A c = lam c
    ! LAPACK variables for DGEEV:
    real(dp), allocatable ::  At(:,:), vl(:,: ), vr(:,:), wi(:), work(:), wr(:)
    integer :: info, lda, ldvl, ldvr, lwork, n

    lda = size(A(:,1))
    n = size(A(1,:))
    call assert_shape(A, [n, n], "solve", "A")
    ldvl = n
    ldvr = n
    lwork = 8*n  ! TODO: can this size be optimized? query first?
    allocate(At(lda,n), wr(n), wi(n), vl(ldvl,n), vr(ldvr,n), work(lwork), lam(n))
    At = A

    call dgeev('N', 'N', n, At, lda, wr, wi, vl, ldvl, vr, ldvr, &
         work, lwork, info)
    if(info /= 0) then
       print *, "dgeev returned info = ", info
       if (info < 0) then
          print *, "the", -info, "-th argument had an illegal value"
       else
          print *, "the QR algorithm failed to compute all the"
          print *, "eigenvalues, and no eigenvectors have been computed;"
          print *, "elements ", info+1, ":", n, "of WR and WI contain eigenvalues which"
          print *, "have converged."
       end if
       call stop_error('eigvals: dgeev error')
    end if

    lam = wr + i_*wi
  end function deigvals

  function zeigvals(A) result(lam)
    complex(dp), intent(in) :: A(:, :)  ! matrix to solve eigenproblem for
    complex(dp), allocatable :: lam(:)  ! eigenvalues: A c = lam c
    ! LAPACK variables:
    integer :: info, lda, ldvl, ldvr, lwork, n, lrwork
    real(dp), allocatable :: rwork(:)
    complex(dp), allocatable :: At(:,:), vl(:,:), vr(:,:), work(:)

    lda = size(A(:,1))
    n = size(A(1,:))
    call assert_shape(A, [n, n], "solve", "A")
    ldvl = n
    ldvr = n
    lwork = 8*n  ! TODO: can this size be optimized? query first?
    lrwork = 2*n
    allocate(At(lda,n), vl(ldvl,n), vr(ldvr,n), work(lwork), rwork(lrwork), lam(n))
    At = A
    call zgeev('N', 'N', n, At, lda, lam, vl, ldvl, vr, ldvr, work, &
         lwork, rwork, info)
    if(info /= 0) then
       print *, "zgeev returned info = ", info
       if(info < 0) then
          print *, "the ",-info, "-th argument had an illegal value."
       else
          print *, "the QR algorithm failed to compute all the"
          print *, "eigenvalues, and no eigenvectors have been computed;"
          print *, "elements and ", info+1, ":", n, " of W contain eigenvalues which have"
          print *, "converged."
       end if
       call stop_error('eig: zgeev error')
    end if
  end function zeigvals

  subroutine deigh_generalized(Am, Bm, lam, c)
    ! solves generalized eigen value problem for all eigenvalues and eigenvectors
    ! Am must by symmetric, Bm symmetric positive definite.
    ! Only the lower triangular part of Am and Bm is used.
    real(dp), intent(in) :: Am(:,:)   ! LHS matrix: Am c = lam Bm c
    real(dp), intent(in) :: Bm(:,:)   ! RHS matrix: Am c = lam Bm c
    real(dp), intent(out) :: lam(:)   ! eigenvalues: Am c = lam Bm c
    real(dp), intent(out) :: c(:,:)   ! eigenvectors: Am c = lam Bm c; c(i,j) = ith component of jth vec.
    integer :: n
    ! lapack variables
    integer :: lwork, liwork, info
    integer, allocatable :: iwork(:)
    real(dp), allocatable :: Bmt(:,:), work(:)

    ! solve
    n = size(Am,1)
    call assert_shape(Am, [n, n], "eigh", "Am")
    call assert_shape(Bm, [n, n], "eigh", "B")
    call assert_shape(c, [n, n], "eigh", "c")
    lwork = 1 + 6*n + 2*n**2
    liwork = 3 + 5*n
    allocate(Bmt(n,n), work(lwork), iwork(liwork))
    c = Am; Bmt = Bm  ! Bmt temporaries overwritten by dsygvd
    call dsygvd(1,'V','L',n,c,n,Bmt,n,lam,work,lwork,iwork,liwork,info)
    if (info /= 0) then
       print *, "dsygvd returned info =", info
       if (info < 0) then
          print *, "the", -info, "-th argument had an illegal value"
       else if (info <= n) then
          print *, "the algorithm failed to compute an eigenvalue while working"
          print *, "on the submatrix lying in rows and columns", 1.0_dp*info/(n+1)
          print *, "through", mod(info, n+1)
       else
          print *, "The leading minor of order ", info-n, &
               "of B is not positive definite. The factorization of B could ", &
               "not be completed and no eigenvalues or eigenvectors were computed."
       end if
       call stop_error('eigh: dsygvd error')
    end if
  end subroutine deigh_generalized

  subroutine deigh_simple(Am, lam, c)
    ! solves eigen value problem for all eigenvalues and eigenvectors
    ! Am must by symmetric
    ! Only the lower triangular part of Am is used.
    real(dp), intent(in) :: Am(:,:)   ! LHS matrix: Am c = lam c
    real(dp), intent(out) :: lam(:)   ! eigenvalues: Am c = lam c
    real(dp), intent(out) :: c(:,:)   ! eigenvectors: Am c = lam c; c(i,j) = ith component of jth vec.
    integer :: n
    ! lapack variables
    integer :: lwork, liwork, info
    integer, allocatable :: iwork(:)
    real(dp), allocatable :: work(:)

    ! solve
    n = size(Am,1)
    call assert_shape(Am, [n, n], "eigh", "Am")
    call assert_shape(c, [n, n], "eigh", "c")
    lwork = 1 + 6*n + 2*n**2
    liwork = 3 + 5*n
    allocate(work(lwork), iwork(liwork))
    c = Am
    call dsyevd('V','L',n,c,n,lam,work,lwork,iwork,liwork,info)
    if (info /= 0) then
       print *, "dsyevd returned info =", info
       if (info < 0) then
          print *, "the", -info, "-th argument had an illegal value"
       else
          print *, "the algorithm failed to compute an eigenvalue while working"
          print *, "on the submatrix lying in rows and columns", 1.0_dp*info/(n+1)
          print *, "through", mod(info, n+1)
       end if
       call stop_error('eigh: dsyevd error')
    end if
  end subroutine deigh_simple

  subroutine zeigh_generalized(Am, Bm, lam, c)
    ! solves generalized eigen value problem for all eigenvalues and eigenvectors
    ! Am must by hermitian, Bm hermitian positive definite.
    ! Only the lower triangular part of Am and Bm is used.
    complex(dp), intent(in) :: Am(:,:)   ! LHS matrix: Am c = lam Bm c
    complex(dp), intent(in) :: Bm(:,:)   ! RHS matrix: Am c = lam Bm c
    real(dp), intent(out) :: lam(:)      ! eigenvalues: Am c = lam Bm c
    complex(dp), intent(out) :: c(:,:)   ! eigenvectors: Am c = lam Bm c; c(i,j) = ith component of jth vec.
    ! lapack variables
    integer :: info, liwork, lrwork, lwork, n
    integer, allocatable :: iwork(:)
    real(dp), allocatable :: rwork(:)
    complex(dp), allocatable :: Bmt(:,:), work(:)

    ! solve
    n = size(Am,1)
    call assert_shape(Am, [n, n], "eigh", "Am")
    call assert_shape(Bm, [n, n], "eigh", "Bm")
    call assert_shape(c, [n, n], "eigh", "c")
    lwork = 2*n + n**2
    lrwork = 1 + 5*N + 2*n**2
    liwork = 3 + 5*n
    allocate(Bmt(n,n), work(lwork), rwork(lrwork), iwork(liwork))
    c = Am; Bmt = Bm  ! Bmt temporary overwritten by zhegvd
    call zhegvd(1,'V','L',n,c,n,Bmt,n,lam,work,lwork,rwork,lrwork,iwork,liwork,info)
    if (info /= 0) then
       print *, "zhegvd returned info =", info
       if (info < 0) then
          print *, "the", -info, "-th argument had an illegal value"
       else if (info <= n) then
          print *, "the algorithm failed to compute an eigenvalue while working"
          print *, "on the submatrix lying in rows and columns", 1.0_dp*info/(n+1)
          print *, "through", mod(info, n+1)
       else
          print *, "The leading minor of order ", info-n, &
               "of B is not positive definite. The factorization of B could ", &
               "not be completed and no eigenvalues or eigenvectors were computed."
       end if
       call stop_error('eigh: zhegvd error')
    end if
  end subroutine zeigh_generalized

  subroutine zeigh_simple(Am, lam, c)
    ! solves eigen value problem for all eigenvalues and eigenvectors
    ! Am must by symmetric
    ! Only the lower triangular part of Am is used.
    complex(dp), intent(in) :: Am(:,:)   ! LHS matrix: Am c = lam c
    real(dp), intent(out) :: lam(:)   ! eigenvalues: Am c = lam c
    complex(dp), intent(out) :: c(:,:)   ! eigenvectors: Am c = lam c; c(i,j) = ith component of jth vec.
    ! LAPACK variables:
    integer :: info, lda, liwork, lrwork, lwork, n
    integer, allocatable :: iwork(:)
    real(dp), allocatable :: rwork(:)
    complex(dp), allocatable :: work(:)

    ! use LAPACK's zheevd routine
    n = size(Am, 1)
    call assert_shape(Am, [n, n], "eigh", "Am")
    call assert_shape(c, [n, n], "eigh", "c")
    lda = max(1, n)
    lwork = 2*n + n**2
    lrwork = 1 + 5*n + 2*n**2
    liwork = 3 + 5*n
    allocate(work(lwork), rwork(lrwork), iwork(liwork))
    c = Am
    call zheevd("V", "L", n, c, lda, lam, work, lwork, rwork, lrwork, &
         iwork, liwork, info)
    if (info /= 0) then
       print *, "zheevd returned info =", info
       if (info < 0) then
          print *, "the", -info, "-th argument had an illegal value"
       else
          print *, "the algorithm failed to compute an eigenvalue while working"
          print *, "through the submatrix lying in rows and columns through"
          print *, info/(n+1), " through ", mod(info, n+1)
       end if
       call stop_error('eigh: zheevd error')
    end if
  end subroutine zeigh_simple

  function dinv(Am) result(Bm)
    real(dp), intent(in) :: Am(:,:)  ! matrix to be inverted
    real(dp) :: Bm(size(Am, 1), size(Am, 2))   ! Bm = inv(Am)
    real(dp), allocatable :: Amt(:,:), work(:)  ! temporary work arrays

    ! LAPACK variables:
    integer ::  info, lda, n, lwork, nb
    integer, allocatable :: ipiv(:)

    ! use LAPACK's dgetrf and dgetri
    n = size(Am(1, :))
    call assert_shape(Am, [n, n], "inv", "Am")
    lda = n
    nb = ilaenv(1, 'DGETRI', "UN", n, -1, -1, -1)  ! TODO: check UN param
    lwork = n*nb
    if (nb < 1) nb = max(1, n)
    allocate(Amt(n,n), work(lwork), ipiv(n))
    Amt = Am
    call dgetrf(n, n, Amt, lda, ipiv, info)
    if(info /= 0) then
       print *, "dgetrf returned info =", info
       if (info < 0) then
          print *, "the", -info, "-th argument had an illegal value"
       else
          print *, "U(", info, ",", info, ") is exactly zero; The factorization"
          print *, "has been completed, but the factor U is exactly"
          print *, "singular, and division by zero will occur if it is used"
          print *, "to solve a system of equations."
       end if
       call stop_error('inv: dgetrf error')
    end if

    call dgetri(n, Amt, n, ipiv, work, lwork, info)
    if (info /= 0) then
       print *, "dgetri returned info =", info
       if (info < 0) then
          print *, "the", -info, "-th argument had an illegal value"
       else
          print *, "U(", info, ",", info, ") is exactly zero; the matrix is"
          print *, "singular and its inverse could not be computed."
       end if
       call stop_error('inv: dgetri error')
    end if
    Bm = Amt

  end function dinv

  function zinv(Am) result(Bm)
    ! Inverts the general complex matrix Am
    complex(dp), intent(in) :: Am(:,:)   ! Matrix to be inverted
    complex(dp) :: Bm(size(Am, 1), size(Am, 2))   ! Bm = inv(Am)
    integer :: n, nb
    ! lapack variables
    integer :: lwork, info
    complex(dp), allocatable:: Amt(:,:), work(:)
    integer, allocatable:: ipiv(:)

    n = size(Am, 1)
    call assert_shape(Am, [n, n], "inv", "Am")
    nb = ilaenv(1, 'ZGETRI', "UN", n, -1, -1, -1)  ! TODO: check UN param
    if (nb < 1) nb = max(1, n)
    lwork = n*nb
    allocate(Amt(n,n), ipiv(n), work(lwork))
    Amt = Am
    call zgetrf(n, n, Amt, n, ipiv, info)
    if (info /= 0) then
       print *, "zgetrf returned info =", info
       if (info < 0) then
          print *, "the", -info, "-th argument had an illegal value"
       else
          print *, "U(", info, ",", info, ") is exactly zero; The factorization"
          print *, "has been completed, but the factor U is exactly"
          print *, "singular, and division by zero will occur if it is used"
          print *, "to solve a system of equations."
       end if
       call stop_error('inv: zgetrf error')
    end if
    call zgetri(n, Amt, n, ipiv, work, lwork, info)
    if (info /= 0) then
       print *, "zgetri returned info =", info
       if (info < 0) then
          print *, "the", -info, "-th argument had an illegal value"
       else
          print *, "U(", info, ",", info, ") is exactly zero; the matrix is"
          print *, "singular and its inverse could not be computed."
       end if
       call stop_error('inv: zgetri error')
    end if
    Bm = Amt
  end function zinv

  function dsolve(A, b) result(x)
    ! solves a system of equations A x = b with one right hand side
    real(dp), intent(in) :: A(:,:)  ! coefficient matrix A
    real(dp), intent(in) :: b(:)  ! right-hand-side A x = b
    real(dp), allocatable :: x(:)
    ! LAPACK variables:
    real(dp), allocatable :: At(:,:), bt(:,:)
    integer :: n, info, lda
    integer, allocatable :: ipiv(:)

    n = size(A(1,:))
    lda = size(A(:, 1))  ! TODO: remove lda (which is = n!)
    call assert_shape(A, [n, n], "solve", "A")
    allocate(At(lda,n), bt(n,1), ipiv(n), x(n))
    At = A
    bt(:,1) = b(:)
    call dgesv(n, 1, At, lda, ipiv, bt, n, info)
    if(info /= 0) then
       print *, "dgesv returned info =", info
       if (info < 0) then
          print *, "the", -info, "-th argument had an illegal value"
       else
          print *, "U(", info, ",", info, ") is exactly zero; The factorization"
          print *, "has been completed, but the factor U is exactly"
          print *, "singular, so the solution could not be computed."
       end if
       call stop_error('inv: dgesv error')
    endif
    x = bt(:,1)
  end function dsolve

  function zsolve(A, b) result(x)
    ! solves a system of equations A x = b with one right hand side
    complex(dp), intent(in) :: A(:,:)  ! coefficient matrix A
    complex(dp), intent(in) :: b(:)  ! right-hand-side A x = b
    complex(dp), allocatable :: x(:)
    ! LAPACK variables:
    complex(dp), allocatable :: At(:,:), bt(:,:)
    integer :: n, info, lda
    integer, allocatable :: ipiv(:)

    n = size(A(1,:))
    lda = size(A(:, 1))  ! TODO: remove lda here, too
    call assert_shape(A, [n, n], "solve", "A")
    allocate(At(lda,n), bt(n,1), ipiv(n), x(n))
    At = A
    bt(:,1) = b(:)
    call zgesv(n, 1, At, lda, ipiv, bt, n, info)
    if(info /= 0) then
       print *, "zgesv returned info =", info
       if (info < 0) then
          print *, "the", -info, "-th argument had an illegal value"
       else
          print *, "U(", info, ",", info, ") is exactly zero; The factorization"
          print *, "has been completed, but the factor U is exactly"
          print *, "singular, so the solution could not be computed."
       end if
       call stop_error('inv: zgesv error')
    endif
    x = bt(:,1)
  end function zsolve

  function eye(n) result(A)
    ! Returns the identity matrix of size n x n and type real.
    integer, intent(in) :: n
    real(dp) :: A(n, n)
    integer :: i

    A = 0
    do i = 1, n
       A(i, i) = 1
    end do
  end function eye

  function ddet(A) result(x)
    ! compute the determinant of a real matrix using an LU factorization
    real(dp), intent(in) :: A(:, :)
    real(dp) :: x
    integer :: i
    ! LAPACK variables:
    integer :: info, n
    integer, allocatable :: ipiv(:)
    real(dp), allocatable :: At(:,:)

    n = size(A(1,:))
    call assert_shape(A, [n, n], "det", "A")
    allocate(At(n,n), ipiv(n))
    At = A
    call dgetrf(n, n, At, n, ipiv, info)
    if(info /= 0) then
       print *, "dgetrf returned info =", info
       if (info < 0) then
          print *, "the", -info, "-th argument had an illegal value"
       else
          print *, "U(", info, ",", info, ") is exactly zero; The factorization"
          print *, "has been completed, but the factor U is exactly"
          print *, "singular, and division by zero will occur if it is used"
          print *, "to solve a system of equations."
       end if
       call stop_error('det: dgetrf error')
    end if

    ! At now contains the LU of the factorization A = PLU
    ! as L has unit diagonal entries, the determinant can be computed
    ! from the product of U's diagonal entries. Additional sign changes
    ! stemming from the permutations P have to be taken into account as well.
    x = 1.0_dp
    do i = 1,n
       if(ipiv(i) /= i) then  ! additional sign change
          x = -x*At(i,i)
       else
          x = x*At(i,i)
       endif
    end do
  end function ddet

  function zdet(A) result(x)
    ! compute the determinant of a real matrix using an LU factorization
    complex(dp), intent(in) :: A(:, :)
    complex(dp) :: x
    integer :: i
    ! LAPACK variables:
    integer :: info, n
    integer, allocatable :: ipiv(:)
    complex(dp), allocatable :: At(:,:)

    n = size(A(1,:))
    call assert_shape(A, [n, n], "det", "A")
    allocate(At(n,n), ipiv(n))
    At = A
    call zgetrf(n, n, At, n, ipiv, info)
    if(info /= 0) then
       print *, "zgetrf returned info =", info
       if (info < 0) then
          print *, "the", -info, "-th argument had an illegal value"
       else
          print *, "U(", info, ",", info, ") is exactly zero; The factorization"
          print *, "has been completed, but the factor U is exactly"
          print *, "singular, and division by zero will occur if it is used"
          print *, "to solve a system of equations."
       end if
       call stop_error('inv: zgetrf error')
    end if

    ! for details on the computation, compare the comment in ddet().
    x = 1.0_dp + 0*i_
    do i = 1,n
       if(ipiv(i) /= i) then  ! additional sign change
          x = -x*At(i,i)
       else
          x = x*At(i,i)
       endif
    end do
  end function zdet

  function dlstsq(A, b) result(x)
    ! compute least square solution to A x = b for real A, b
    real(dp), intent(in) :: A(:,:), b(:)
    real(dp), allocatable :: x(:)
    ! LAPACK variables:
    integer :: info, ldb, lwork, m, n, rank
    real(dp) :: rcond
    real(dp), allocatable :: work(:), At(:,:), Bt(:,:)
    integer, allocatable :: jpvt(:)

    m = size(A(:,1)) ! = lda
    n = size(A(1,:))
    ldb = size(b)
    allocate(x(n), At(m,n), Bt(ldb,1), jpvt(n), work(1))
    call dgelsy(m, n, 1, At, m, Bt, ldb, jpvt, rcond, rank, work, &
         -1, info)  ! query optimal workspace size
    lwork = int(real(work(1)))
    deallocate(work)
    allocate(work(lwork))  ! allocate with ideal size
    rcond = 0.0_dp
    jpvt(:) = 0
    Bt(:,1) = b(:)  ! only one right-hand side
    At(:,:) = A(:,:)
    call dgelsy(m, n, 1, At, m, Bt, ldb, jpvt, rcond, rank, work, &
         lwork, info)
    if(info /= 0) then
       print *, "dgelsy returned info = ", info
       print *, "the ", -info, "-th argument had an illegal value"
       call stop_error('lstsq: dgelsy error')
    endif
    x(:) = Bt(1:n,1)
  end function dlstsq

  function zlstsq(A, b) result(x)
    ! compute least square solution to A x = b for complex A, b
    complex(dp), intent(in) :: A(:,:), b(:)
    complex(dp), allocatable :: x(:)
    ! LAPACK variables:
    integer :: info, ldb, lwork, m, n, rank
    real(dp) :: rcond
    complex(dp), allocatable :: At(:,:), Bt(:,:), work(:)
    real(dp), allocatable :: rwork(:)
    integer, allocatable :: jpvt(:)

    m = size(A(:,1)) ! = lda
    n = size(A(1,:))
    ldb = size(b)
    allocate(x(n), At(m,n), Bt(ldb,1), jpvt(n), work(1), rwork(2*n))
    call zgelsy(m, n, 1, At, m, Bt, ldb, jpvt, rcond, rank, work, &
         -1, rwork, info)  ! query optimal workspace size
    lwork = int(real(work(1)))
    deallocate(work)
    allocate(work(lwork))  ! allocate with ideal size
    rcond = 0.0_dp
    jpvt(:) = 0
    Bt(:,1) = b(:)  ! only one right-hand side
    At(:,:) = A(:,:)
    call zgelsy(m, n, 1, At, m, Bt, ldb, jpvt, rcond, rank, work, &
         lwork, rwork, info)
    if(info /= 0) then
       print *, "zgelsy returned info = ", info
       print *, "the ", -info, "-th argument had an illegal value"
       call stop_error('lstsq: zgelsy error')
    endif
    x(:) = Bt(1:n,1)
  end function zlstsq

  ! TODO: can assumed types help in Xdiag() and Xtrace()?
  ! TODO: add optional axis parameter in both xdiag() functions
  function ddiag(x) result(A)
    ! construct real matrix from diagonal elements
    real(dp), intent(in) :: x(:)
    real(dp), allocatable :: A(:,:)
    integer :: i, n

    n = size(x)
    allocate(A(n,n))
    A(:,:) = 0.0_dp
    forall(i=1:n) A(i,i) = x(i)
  end function ddiag

  function zdiag(x) result(A)
    ! construct complex matrix from diagonal elements
    complex(dp), intent(in) :: x(:)
    complex(dp), allocatable :: A(:,:)
    integer :: i, n

    n = size(x)
    allocate(A(n,n))
    A(:,:) = 0*i_
    forall(i=1:n) A(i,i) = x(i)
  end function zdiag

  ! TODO: add optional axis parameter in both xtrace() functions
  function dtrace(A) result(t)
    ! return trace along the main diagonal
    real(dp), intent(in) :: A(:,:)
    real(dp) :: t
    integer :: i

    t = 0.0_dp
    do i = 1,minval(shape(A))
       t = t + A(i,i)
    end do
  end function dtrace

  function ztrace(A) result(t)
    ! return trace along the main diagonal
    complex(dp), intent(in) :: A(:,:)
    complex(dp) :: t
    integer :: i

    t = 0*i_
    do i = 1,minval(shape(A))
       t = t + A(i,i)
    end do
  end function ztrace

  function dsvdvals(A) result(s)
    ! compute singular values s_i of a real m x n matrix A
    real(dp), intent(in) :: A(:,:)
    real(dp), allocatable :: s(:)
    ! LAPACK related:
    integer :: info, lwork, m, n
    real(dp), allocatable :: work(:), At(:,:)
    real(dp) :: u(1,1), vt(1,1)  ! not used if only s is to be computed

    m = size(A(:,1))  ! = lda
    n = size(A(1,:))
    allocate(At(m,n), s(min(m,n)))
    At(:,:) = A(:, :)  ! A is overwritten in dgesvd

    ! query optimal lwork and allocate workspace:
    allocate(work(1))
    call dgesvd('N', 'N', m, n, At, m, s, u, 1, vt, 1, work, -1, info)
    lwork = int(real(work(1)))
    deallocate(work)
    allocate(work(lwork))

    call dgesvd('N', 'N', m, n, At, m, s, u, 1, vt, 1, work, lwork, info)
    if(info /= 0) then
       print *, "dgesvd returned info = ", info
       if(info < 0) then
          print *, "the ", -info, "-th argument had an illegal value"
       else
          print *, "DBDSQR did not converge, there are ", info
          print *, "superdiagonals of an intermediate bidiagonal form B"
          print *, "did not converge to zero. See the description of WORK"
          print *, "in DGESVD's man page for details."
       endif
       call stop_error('svdvals: dgesvd error')
    endif
  end function dsvdvals

  function zsvdvals(A) result(s)
    ! compute singular values s_i of a real m x n matrix A
    complex(dp), intent(in) :: A(:,:)
    real(dp), allocatable :: s(:)
    ! LAPACK related:
    integer :: info, lwork, m, n, lrwork
    complex(dp), allocatable :: work(:), At(:,:)
    real(dp), allocatable :: rwork(:)
    complex(dp) :: u(1,1), vt(1,1)  ! not used if only s is to be computed

    m = size(A(:,1))  ! = lda
    n = size(A(1,:))
    lrwork = 5*min(m,n)
    allocate(At(m,n), s(min(m,n)), rwork(lrwork))
    At(:,:) = A(:,:)  ! A is overwritten in zgesvd!

    ! query optimal lwork and allocate workspace:
    allocate(work(1))
    call zgesvd('N', 'N', m, n, At, m, s, u, 1, vt, 1, work, -1, rwork, info)
    lwork = int(real(work(1)))
    deallocate(work)
    allocate(work(lwork))

    call zgesvd('N', 'N', m, n, At, m, s, u, 1, vt, 1, work, lwork, rwork, info)
    if(info /= 0) then
       print *, "zgesvd returned info = ", info
       if(info < 0) then
          print *, "the ", -info, "-th argument had an illegal value"
       else
          print *, "ZBDSQR did not converge, there are ", info
          print *, "superdiagonals of an intermediate bidiagonal form B"
          print *, "did not converge to zero. See the description of RWORK"
          print *, "in ZGESVD's man page for details."
       endif
       call stop_error('svdvals: zgesvd error')
    endif
  end function zsvdvals

  subroutine dsvd(A, s, U, Vtransp)
    ! compute the singular value decomposition A = U sigma Vtransp of a
    ! real m x n matrix A
    ! U is m x m
    ! Vtransp is n x n
    ! s has size min(m, n) --> sigma matrix is (n x m) with sigma_ii = s_i
    real(dp), intent(in) :: A(:,:)
    real(dp), intent(out) :: s(:), U(:,:), Vtransp(:,:)
    ! LAPACK related:
    integer :: info, lwork, m, n, ldu
    real(dp), allocatable :: work(:), At(:,:)

    ! TODO: check shapes here and in other routines?

    m = size(A(:,1))  ! = lda
    n = size(A(1,:))
    ldu = m
    allocate(At(m,n))
    At(:,:) = A(:,:)  ! use a temporary as dgesvd destroys its input

    call assert_shape(U, [m, m], "svd", "U")
    call assert_shape(Vtransp, [n, n], "svd", "Vtransp")

    ! query optimal lwork and allocate workspace:
    allocate(work(1))
    call dgesvd('A', 'A', m, n, At, m, s, U, ldu, Vtransp, n, work, -1, info)
    lwork = int(real(work(1)))
    deallocate(work)
    allocate(work(lwork))

    call dgesvd('A', 'A', m, n, At, m, s, U, ldu, Vtransp, n, work, lwork, info)
    if(info /= 0) then
       print *, "dgesvd returned info = ", info
       if(info < 0) then
          print *, "the ", -info, "-th argument had an illegal value"
       else
          print *, "DBDSQR did not converge, there are ", info
          print *, "superdiagonals of an intermediate bidiagonal form B"
          print *, "did not converge to zero. See the description of WORK"
          print *, "in DGESVD's man page for details."
       endif
       call stop_error('svd: dgesvd error')
    endif
  end subroutine dsvd

  subroutine zsvd(A, s, U, Vtransp)
    ! compute the singular value decomposition A = U sigma V^H of a
    ! complex m x m matrix A
    ! U is m x min(m, n)
    ! Vtransp is n x n
    ! sigma is m x n with with sigma_ii = s_i
    ! note that this routine returns V^H, not V!
    complex(dp), intent(in) :: A(:,:)
    real(dp), intent(out) :: s(:)
    complex(dp), intent(out) :: U(:,:), Vtransp(:,:)
    ! LAPACK related:
    integer :: info, lwork, m, n, ldu, lrwork
    real(dp), allocatable :: rwork(:)
    complex(dp), allocatable :: work(:), At(:,:)

    ! TODO: check shapes here and in other routines?

    m = size(A(:,1))  ! = lda
    n = size(A(1,:))
    ldu = m
    lrwork = 5*min(m,n)
    allocate(rwork(lrwork), At(m,n))
    At(:,:) = A(:,:)  ! use a temporary as zgesvd destroys its input

    call assert_shape(U, [m, m], "svd", "U")
    call assert_shape(Vtransp, [n, n], "svd", "Vtransp")

    ! query optimal lwork and allocate workspace:
    allocate(work(1))
    call zgesvd('A', 'A', m, n, At, m, s, U, ldu, Vtransp, n, work, -1,&
         rwork, info)
    lwork = int(real(work(1)))
    deallocate(work)
    allocate(work(lwork))

    call zgesvd('A', 'A', m, n, At, m, s, U, ldu, Vtransp, n, work, &
         lwork, rwork, info)
    if(info /= 0) then
       print *, "zgesvd returned info = ", info
       if(info < 0) then
          print *, "the ", -info, "-th argument had an illegal value"
       else
          print *, "ZBDSQR did not converge, there are ", info
          print *, "superdiagonals of an intermediate bidiagonal form B"
          print *, "did not converge to zero. See the description of WORK"
          print *, "in DGESVD's man page for details."
       endif
       call stop_error('svd: zgesvd error')
    endif
  end subroutine zsvd

  subroutine dassert_shape(A, shap, routine, matname)
    ! make sure a given real matrix has a given shape
    real(dp), intent(in) :: A(:,:)
    integer, intent(in) :: shap(:)
    character(len=*) :: routine, matname

    if(any(shape(A) /= shap)) then
       print *, "In routine " // routine // " matrix " // matname // " has illegal shape ", shape(A)
       print *, "Shape should be ", shap
       call stop_error("Aborting due to illegal matrix operation")
    end if
  end subroutine dassert_shape

  subroutine zassert_shape(A, shap, routine, matname)
    ! make sure a given real matrix has a given shape
    complex(dp), intent(in) :: A(:,:)
    integer, intent(in) :: shap(:)
    character(len=*) :: routine, matname

    if(any(shape(A) /= shap)) then
       print *, "In routine " // routine // " matrix " // matname // " has illegal shape ", shape(A)
       print *, "Shape should be ", shap
       call stop_error("Aborting due to illegal matrix operation")
    end if
  end subroutine zassert_shape

end module linalg


module constants
  real, parameter :: pi=3.1415926
  real, parameter :: twopi=2.*pi
  real, parameter :: rad=pi/180.
  real, parameter :: ftm=12./39.37
  real, parameter :: mtf=1/ftm
  real, parameter :: rpm=60./twopi
  ! ft/s^2
  real, parameter :: g=32.179
  real, parameter :: circ=9.125
  ! radius of ball in ft
  real, parameter :: radius=circ/twopi/12
  real, parameter :: const0=5.283e-3
  real, parameter :: rho0=1.175
end module constants

module specs
  integer, parameter :: nterms=8
  integer, parameter :: nstep=1000
end module specs

subroutine trajectory(cd0,cddot,cdspin,w0,theta0,tau0,rhodata,vdata,thetadata,vwind,spin_rpm,sfact,cdi,distance,tof)

  use constants, only : pi,twopi,rad,ftm,mtf,rpm,const0,rho0,g,radius
  use specs, only : nterms, nstep;

  ! Need to eventually enable 'implicit none'
  !implicit none

  ! Original version by Alan Nathan
  ! Modifcations by Chris Long

  real, intent(in) :: cd0
  real, intent(in) :: cddot
  real, intent(in) :: cdspin
  real, intent(in) :: w0
  real, intent(in) :: theta0
  real, intent(in) :: tau0
  real, intent(in) :: rhodata
  real, intent(in) :: vdata
  real, intent(in) :: thetadata
  real, intent(in) :: vwind
  real, intent(out) :: spin_rpm
  real, intent(out) :: sfact
  real, intent(out) :: cdi
  real, intent(out) :: distance
  real, intent(out) :: tof

  interface rkdumb
     subroutine rkdumb(xx,y,vstart,nvar,x1,x2,nstep,cd0,cddot,cdspin,w0,theta0,tau0,v0,theta,rho,const,vwx,vwy,ctht,stht,cphi,sphi)
       real, dimension(:), intent(out) :: xx
       real, dimension(:,:), intent(out) :: y
       real, dimension(:), intent(in) :: vstart
       integer, intent(in) :: nvar
       real, intent(in) :: x1
       real, intent(out) :: x2
       integer, intent(in) :: nstep
       real, intent(in) :: cd0
       real, intent(in) :: cddot
       real, intent(in) :: cdspin
       real, intent(in) :: w0
       real, intent(in) :: theta0
       real, intent(in) :: tau0
       ! in mph,det,kg/m^3,mph,mph
       real, intent(in) :: v0
       real, intent(in) :: theta
       real, intent(in) :: rho
       real, intent(in) :: const
       real, intent(in) :: vwx
       real, intent(in) :: vwy

       real, intent(in) :: ctht
       real, intent(in) :: stht
       real, intent(in) :: cphi
       real, intent(in) :: sphi
     end subroutine rkdumb
  end interface rkdumb

  interface dist
     subroutine dist(t,x,range,time)
       real, dimension(:), intent(in) :: t
       real, dimension(:,:), intent(in) :: x
       real, intent(out) :: range
       real, intent(out) :: time
     end subroutine dist
  end interface dist

  !real :: rhodata,vdata,thetadata,vwind

  real, dimension(nstep) :: t
  real, dimension(nterms,nstep) :: x

  real :: xstart(nterms)

  ! no wind
  vwx=0.
  vwy=0.

  ! index i:
  !   1,2,3 ==> xi,yi,zi
  !   4,5,6 ==> vx,vy,vz
  !   7,8 ==> r*wb,r*ws

  ! wb=backspin rate
  ! ws=sidespin rate

  ! note on the right-handed coordinate:
  !   z is vertical with positive upward
  !   y is catcher-pitcher line
  !   x points to catcher's right

  ! NOTE:  This current version is 2D, so that x=vx=ws=0
  ! It is easy to reinstate these to make it full 3D

  ! Maximum allowed hangtime in seconds
  tmax=10.0

  rho=rhodata
  const=const0*(rho/rho0)
  v0=vdata
  theta=thetadata
  vwy=vwind*1.467
  vwx=0.
  xstart(1)=0.
  xstart(2)=2.
  xstart(3)=3.
  xstart(4)=0.
  ctht=cos(theta*rad)
  stht=sin(theta*rad)
  xstart(5)=(v0*1.467)*ctht
  xstart(6)=(v0*1.467)*stht
  cphi=1.
  sphi=0.
  spin=(w0/rpm)*(v0/100.)*(theta-theta0)/(27.5-theta0)
  xstart(7)=radius*spin
  xstart(8)=0.

  ! spin rate=w0 at v0=100. and theta=27.5 and 0 at theta=aparm(5)

  ! integrate to get trajectory, then distance

  call rkdumb(t,x,xstart,nterms,0.,tmax,nstep,cd0,cddot,cdspin,w0,theta0,tau0,v0,theta,rho,const,vwx,vwy,ctht,stht,cphi,sphi)

  call dist(t,x,range,time)

  sfact=xstart(7)/(1.467*v0)
  cdi=cd0*(1.+cddot*(100.-v0))*(1.+cdspin*sfact**2)

  spin_rpm=spin*rpm
  distance=range
  tof=time

end subroutine trajectory

subroutine derivs(t,x,dxdt,cd0,cddot,cdspin,w0,theta0,tau0,v0,theta,rho,const,vwx,vwy,ctht,stht,cphi,sphi)

  use constants

  ! Given the values of t and x, returns derivatives dxdt=dv/dt

  dimension x(8),dxdt(8)
  real drag,lift

  ! 1,2,4 ==> x,y,z
  ! 4,5,6 ==> vx,vy,vz
  ! 7,8 ==> r*wb,r*ws

  ! NOTE:  this is 2D problem, so x(1),dxdt(1) are both fixed at 0

  ! vwx,wwy are x,y components of wind speed

  ! components of radius*spin

  rwb=x(7)
  rws=x(8)
  romega=sqrt(rwb**2+rws**2)

  ! speed of ball
  vt=sqrt((x(4)-vwx)**2+(x(5)-vwy)**2+x(6)**2)

  ! spin factor
  sfact=romega/vt

  ! note that spin is pure backspin (i.e, rws=0)

  cd=cd0*(1.+cddot*(100.-v0))*(1.+cdspin*sfact**2)
  ! Cross prescription
  cl=sfact/(2.32*sfact+0.4)
  !print*,cd,cl,sfact,g,x(7),vt
  !pause

  ! actually drag/(m*vt)
  drag=const*cd*vt
  ! actually lift/(m*vt)
  lift=const*cl*vt

  ! components of spin
  ! NOTE:  For 2D, ws=0; cphi=1; sphi=0; this means wy=yz=0 and wx=wb

  wx1=rwb
  wy1=-rws*stht
  wz=rws*ctht
  wx=wx1*cphi+wy1*sphi
  wy=-wx1*sphi+wy1*cphi

  ! the preceding five statement assure the the spin vector is normal
  ! to the initial velocity vector

  !=0 for 2D
  liftx=lift*(wy*x(6)-wz*(x(5)-vwy))/romega
  lifty=lift*(wz*(x(4)-vwx)-wx*x(6))/romega
  liftz=lift*(wx*(x(5)-vwy)-wy*(x(4)-vwx))/romega
  !=0 for 2D
  dxdt(1)=x(4)
  dxdt(2)=x(5)
  dxdt(3)=x(6)
  !=0 for 2D
  dxdt(4)=-drag*(x(4)-vwx)+liftx
  dxdt(5)=-drag*(x(5)-vwy)+lifty
  dxdt(6)=-drag*x(6)+liftz-g
  !no spin-down
  dxdt(7)=0.
  !no spin-down
  dxdt(8)=0.

  return
end subroutine derivs

subroutine rk4(y,dydx,n,x,h,yout,cd0,cddot,cdspin,w0,theta0,tau0,v0,theta,rho,const,vwx,vwy,ctht,stht,cphi,sphi)

  use specs, only : nterms

  ! Given values for N variables y and their derivatives DYDX known
  ! at X, use the fourth-order Runge-Kutta method to advance the
  ! solution over an interval H and return the incremented variables
  ! as YOUT, which need not be a distinct array from Y.  The user
  ! supplies the subroutine DERIVS(X,Y,DYDX) which returns the
  ! derivatives DYDX at X

  ! Routine taken from Numerical Recipes, 15.1, p. 553

  ! set to the maximum number of functions

  real, intent(in), dimension(:) :: y
  real, intent(in), dimension(:) :: dydx
  integer, intent(in) :: n
  real, intent(in) :: x
  real, intent(in) :: h
  real, intent(out), dimension(:) :: yout
  real, intent(in) :: cd0
  real, intent(in) :: cddot
  real, intent(in) :: cdspin
  real, intent(in) :: w0
  real, intent(in) :: theta0
  real, intent(in) :: tau0
  real, intent(in) :: v0
  real, intent(in) :: theta
  real, intent(in) :: rho
  real, intent(in) :: const
  real, intent(in) :: vwx
  real, intent(in) :: vwy
  real, intent(in) :: ctht
  real, intent(in) :: stht
  real, intent(in) :: cphi
  real, intent(in) :: sphi

  !parameter (nmax=10)
  !dimension y(n),dydx(n),yout(n),yt(nmax),dyt(nmax),dym(nmax)
  dimension yt(nterms),dyt(nterms),dym(nterms)

  hh=h*0.5
  h6=h/6.
  xh=x+hh

  ! first step
  do i=1,n
     yt(i)=y(i)+hh*dydx(i)
  end do
  ! second step
  call derivs(xh,yt,dyt,cd0,cddot,cdspin,w0,theta0,tau0,v0,theta,rho,const,vwx,vwy,ctht,stht,cphi,sphi)
  do i=1,n
     yt(i)=y(i)+hh*dyt(i)
  end do
  ! third step
  call derivs(xh,yt,dym,cd0,cddot,cdspin,w0,theta0,tau0,v0,theta,rho,const,vwx,vwy,ctht,stht,cphi,sphi)
  do i=1,n
     yt(i)=y(i)+h*dym(i)
     dym(i)=dyt(i)+dym(i)
  end do
  ! fourth step
  call derivs(x+h,yt,dyt,cd0,cddot,cdspin,w0,theta0,tau0,v0,theta,rho,const,vwx,vwy,ctht,stht,cphi,sphi)
  do i=1,n
     yout(i)=y(i)+h6*(dydx(i)+dyt(i)+2.*dym(i))
  end do
  return
end subroutine rk4

subroutine rkdumb(xx,y,vstart,nvar,x1,x2,nstep,cd0,cddot,cdspin,w0,theta0,tau0,v0,theta,rho,const,vwx,vwy,ctht,stht,cphi,sphi)

  use specs, only : nterms

  ! Starting from initial values VSTART for NVAR functions, known at
  ! X1, use fourth-order Runge-Kutta to advance nstep equal increments
  ! to X2.  The user supplied subroutine DERIVS(X,V,DVDX) evaluates
  ! derivatives.  Results are stored in the common block PATH.  Be sure
  ! to dimension the common block appropriately

  ! Routine taken from Numerical Recipes, 15.1, p. 554

  interface rk4
     subroutine rk4(y,dydx,n,x,h,yout,cd0,cddot,cdspin,w0,theta0,tau0,v0,theta,rho,const,vwx,vwy,ctht,stht,cphi,sphi)
       real, intent(in), dimension(:) :: y
       real, intent(in), dimension(:) :: dydx
       integer, intent(in) :: n
       real, intent(in) :: x
       real, intent(in) :: h
       real, intent(out), dimension(:) :: yout
       real, intent(in) :: cd0
       real, intent(in) :: cddot
       real, intent(in) :: cdspin
       real, intent(in) :: w0
       real, intent(in) :: theta0
       real, intent(in) :: tau0
       ! in mph,det,kg/m^3,mph,mph
       real, intent(in) :: v0
       real, intent(in) :: theta
       real, intent(in) :: rho
       real, intent(in) :: const
       real, intent(in) :: vwx
       real, intent(in) :: vwy
       real, intent(in) :: ctht
       real, intent(in) :: stht
       real, intent(in) :: cphi
       real, intent(in) :: sphi
     end subroutine rk4
  end interface rk4

  real, dimension(:), intent(out) :: xx
  real, dimension(:,:), intent(out) :: y
  real, dimension(:), intent(in) :: vstart
  integer, intent(in) :: nvar
  real, intent(in) :: x1
  real, intent(out) :: x2
  integer, intent(in) :: nstep
  real, intent(in) :: cd0
  real, intent(in) :: cddot
  real, intent(in) :: cdspin
  real, intent(in) :: w0
  real, intent(in) :: theta0
  real, intent(in) :: tau0
  real, intent(in) :: v0
  real, intent(in) :: theta
  real, intent(in) :: rho
  real, intent(in) :: const
  real, intent(in) :: vwx
  real, intent(in) :: vwy
  real, intent(in) :: ctht
  real, intent(in) :: stht
  real, intent(in) :: cphi
  real, intent(in) :: sphi

  dimension v(nvar),dv(nvar)

  ! load starting values
  do i=1,nvar
     v(i)=vstart(i)
     y(i,1)=v(i)
  end do
  xx(1)=x1
  x=x1
  h=(x2-x1)/nstep

  ! take nstep steps
  do k=1,nstep-1
     call derivs(x,v,dv,cd0,cddot,cdspin,w0,theta0,tau0,v0,theta,rho,const,vwx,vwy,ctht,stht,cphi,sphi)
     call rk4(v,dv,nvar,x,h,v,cd0,cddot,cdspin,w0,theta0,tau0,v0,theta,rho,const,vwx,vwy,ctht,stht,cphi,sphi)

     ! Commented out - replace with error code
     !if (x+h.eq.x)pause 'Stepsize not significant in RKDUMB'
     x=x+h
     !store intermediate steps
     xx(k+1)=x
     do i=1,nvar
        y(i,k+1)=v(i)
     end do

  end do
  return
end subroutine rkdumb

subroutine dist(t,x,range,time)

  use constants

  real, dimension(:), intent(in) :: t
  real, dimension(:,:), intent(in) :: x
  real, intent(out) :: range
  real, intent(out) :: time

  integer :: nstep
  nstep=size(t)

  ! Fortran does not have repeat-until
  do i=1,nstep
     if(x(3,i).le.0..and.i.gt.1) exit
  end do

  ! linear interpolation to get range
  frac=x(3,i-1)/(x(3,i-1)-x(3,i))
  d1=sqrt(x(2,i-1)**2+x(1,i-1)**2)
  d2=sqrt(x(2,i)**2+x(1,i)**2)
  range=d1+frac*(d2-d1)
  time=t(i)
  return
end subroutine dist

program main
  cd0=0.4103
  cddot=0.0044
  cdspin=0.2043
  w0=2069.4111
  theta0=7.2023
  tau0=25.0000
  rhodata=1.19
  vdata=91.0
  thetadata=27.5
  vwind=2.0
  call trajectory(cd0,cddot,cdspin,w0,theta0,tau0,rhodata,vdata,thetadata,vwind,spin_rpm,sfact,cdi,distance,tof)
  write(*,*) spin_rpm,sfact,cdi,distance,tof
end program main


SUBROUTINE eta_linear_bottom(H,k,x,int_kx,omega,time,eta,etax,etaxx,etat)
!
USE Precision
USE Constants
IMPLICIT NONE
REAL(KIND=long), INTENT(IN)  :: H,k,x,omega,time,int_kx
REAL(KIND=long), INTENT(OUT) :: eta,etax
REAL(KIND=long), INTENT(OUT) :: etaxx,etat
! REAL(KIND=long), OPTIONAL :: y,etay,etayy !Boundary fitted ?
! Local variables
REAL(KIND=long) :: kx, half_H, sinkx
!
kx=int_kx-omega*time
half_H = H*half
sinkx = sin(kx)
!
eta   =  half_H*cos(kx)
etax  = -half_H*k*sinkx
etat  =  omega*half_H*sinkx
etaxx = -eta*(k)**2

END SUBROUTINE eta_linear_bottom