program main

c*********************************************************************72
c
cc blas1_c_test() tests blas1_c().
c
c  Licensing:
c
c    This code is distributed under the MIT license.
c
c  Modified:
c
c    15 May 2006
c
c  Author:
c
c    John Burkardt
c
      implicit none

      call timestamp ( )
      write ( *, '(a)' ) ' '
      write ( *, '(a)' ) 'blas1_c_test():'
      write ( *, '(a)' ) '  FORTRAN77 version'
      write ( *, '(a)' ) '  Test blas1_c().'

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

      call test10 ( )
      call test11 ( )
      call test12 ( )
      call test13 ( )
      call test14 ( )
      call test15 ( )
      call test16 ( )
      call test17 ( )
c
c  Terminate.
c
      write ( *, '(a)' ) ' '
      write ( *, '(a)' ) 'blas1_c_test():'
      write ( *, '(a)' ) '  Normal end of execution.'
      write ( *, '(a)' ) ' '
      call timestamp ( )

      stop
      end
      subroutine test01 ( )

c*********************************************************************72
c
cc TEST01 tests CABS1.
c
c  Licensing:
c
c    This code is distributed under the MIT license.
c
c  Modified:
c
c    27 February 2006
c
c  Author:
c
c    John Burkardt
c
      implicit none

      complex c
      complex c4_uniform_01
      real c_norm
      real cabs1
      integer i
      integer seed

      seed = 123456789

      write ( *, '(a)' ) ' '
      write ( *, '(a)' ) 'TEST01'
      write ( *, '(a)' ) '  CABS1 returns the L1 norm '
      write ( *, '(a)' ) '  of a single precision complex number.'
      write ( *, '(a)' ) ' '
      write ( *, '(a)' ) '      Real      Imaginary              '
      write ( *, '(a)' ) '      Part      Part           CABS1(Z)'
      write ( *, '(a)' ) ' '

      do i = 1, 10

        c = 5.0E+00 * c4_uniform_01 ( seed )

        c_norm = cabs1 ( c )

        write ( *, '(2x,2f10.4,5x,f10.4)' ) c, c_norm

      end do

      return
      end
      subroutine test02 ( )

c*********************************************************************72
c
cc TEST02 tests CABS2.
c
c  Licensing:
c
c    This code is distributed under the MIT license.
c
c  Modified:
c
c    14 April 2006
c
c  Author:
c
c    John Burkardt
c
      implicit none

      complex c
      complex c4_uniform_01
      real c_norm
      real cabs2
      integer i
      integer seed

      seed = 123456789

      write ( *, '(a)' ) ' '
      write ( *, '(a)' ) 'TEST02'
      write ( *, '(a)' ) '  CABS2 returns the L2 norm '
      write ( *, '(a)' ) '  of a single precision complex number.'
      write ( *, '(a)' ) ' '
      write ( *, '(a)' ) '      Real      Imaginary              '
      write ( *, '(a)' ) '      Part      Part           CABS2(Z)'
      write ( *, '(a)' ) ' '

      do i = 1, 10

        c = 5.0E+00 * c4_uniform_01 ( seed )

        c_norm = cabs2 ( c )

        write ( *, '(2x,2f10.4,5x,f10.4)' ) c, c_norm

      end do

      return
      end
      subroutine test03 ( )

c*********************************************************************72
c
cc TEST03 tests CAXPY.
c
c  Licensing:
c
c    This code is distributed under the MIT license.
c
c  Modified:
c
c    27 February 2006
c
c  Author:
c
c    John Burkardt
c
      implicit none

      integer n
      parameter ( n = 5 )

      integer i
      complex s
      complex x(n)
      complex y(n)

      x(1) = (  2.0E+00, -1.0E+00 )
      x(2) = ( -4.0E+00, -2.0E+00 )
      x(3) = (  3.0E+00,  1.0E+00 )
      x(4) = (  2.0E+00,  2.0E+00 )
      x(5) = ( -1.0E+00, -1.0E+00 )

      y(1) = ( -1.0E+00,  0.0E+00 )
      y(2) = (  0.0E+00, -3.0E+00 )
      y(3) = (  4.0E+00,  0.0E+00 )
      y(4) = ( -3.0E+00,  4.0E+00 )
      y(5) = ( -2.0E+00,  0.0E+00 )

      write ( *, '(a)' ) ' '
      write ( *, '(a)' ) 'TEST03'
      write ( *, '(a)' ) '  CAXPY adds a multiple of one'
      write ( *, '(a)' ) '  single precision complex vector to another.'

      write ( *, '(a)' ) ' '
      write ( *, '(a)' ) '  X = '
      write ( *, '(a)' ) ' '
      do i = 1, n
        write ( *, '(2x,i6,2x,f6.1,2x,f6.1)' ) i, x(i)
      end do

      write ( *, '(a)' ) ' '
      write ( *, '(a)' ) '  Y = '
      write ( *, '(a)' ) ' '
      do i = 1, n
        write ( *, '(2x,i6,2x,f6.1,2x,f6.1)' ) i, y(i)
      end do

      s = ( 0.50E+00, -1.00E+00 )

      write ( *, '(a)' ) ' '
      write ( *, '(a,2g14.6)' ) '  The scalar multiplier is: ', s

      call caxpy ( n, s, x, 1, y, 1 )

      write ( *, '(a)' ) ' '
      write ( *, '(a)' ) '  A * X + Y = '
      write ( *, '(a)' ) ' '
      do i = 1, n
        write ( *, '(2x,i6,2f10.6)' ) i, y(i)
      end do

      return
      end
      subroutine test04 ( )

c*********************************************************************72
c
cc TEST04 tests CCOPY.
c
c  Licensing:
c
c    This code is distributed under the MIT license.
c
c  Modified:
c
c    01 March 2006
c
c  Author:
c
c    John Burkardt
c
      implicit none

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

      write ( *, '(a)' ) ' '
      write ( *, '(a)' ) 'TEST04'
      write ( *, '(a)' ) '  CCOPY copies one complex vector '
      write ( *, '(a)' ) '  into another.'

      do i = 1, 10
        x(i) = cmplx ( 10 * i, i )
      end do

      do i = 1, 10
        y(i) = cmplx ( 20 * i, 2 * i )
      end do

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

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

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

      do i = 1, 10
        y(i) = cmplx ( 20 * i, 2 * i )
      end do

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

      call ccopy ( 5, x, 1, a, 1 )
      write ( *, '(a)' ) ' '
      write ( *, '(a,f8.4,a)' ) '  CCOPY ( 5, X, 1, A, 1 )'
      write ( *, '(a)' ) ' '
      write ( *, '(a)' ) ' '
      write ( *, '(a)' ) '  A = '
      write ( *, '(a)' ) ' '
      do i = 1, 5
        write ( *, '(2x,10f7.1)' ) ( a(i,j), j = 1, 5 )
      end do

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

      call ccopy ( 5, x, 2, a, 5 )
      write ( *, '(a)' ) ' '
      write ( *, '(a,f8.4,a)' ) '  CCOPY ( 5, X, 2, A, 5 )'
      write ( *, '(a)' ) ' '
      write ( *, '(a)' ) '  A = '
      write ( *, '(a)' ) ' '
      do i = 1, 5
        write ( *, '(2x,10f7.1)' ) ( a(i,j), j = 1, 5 )
      end do

      return
      end
      subroutine test05 ( )

c*********************************************************************72
c
cc TEST05 tests CDOTC.
c
c  Licensing:
c
c    This code is distributed under the MIT license.
c
c  Modified:
c
c    01 March 2006
c
c  Author:
c
c    John Burkardt
c
      implicit none

      integer n
      parameter ( n = 5 )

      complex cdotc
      integer i
      complex x(n)
      complex x_norm
      complex xy_dot
      complex y(n)

      x(1) = (  2.0E+00, -1.0E+00 )
      x(2) = ( -4.0E+00, -2.0E+00 )
      x(3) = (  3.0E+00,  1.0E+00 )
      x(4) = (  2.0E+00,  2.0E+00 )
      x(5) = ( -1.0E+00, -1.0E+00 )

      y(1) = ( -1.0E+00,  0.0E+00 )
      y(2) = (  0.0E+00, -3.0E+00 )
      y(3) = (  4.0E+00,  0.0E+00 )
      y(4) = ( -3.0E+00,  4.0E+00 )
      y(5) = ( -2.0E+00,  0.0E+00 )

      write ( *, '(a)' ) ' '
      write ( *, '(a)' ) 'TEST05'
      write ( *, '(a)' ) '  CDOTC computes the conjugated dot product'
      write ( *, '(a)' ) '  of two complex vectors.'

      write ( *, '(a)' ) ' '
      write ( *, '(a)' ) '  X = '
      write ( *, '(a)' ) ' '
      do i = 1, n
        write ( *, '(2x,i6,2x,f6.1,2x,f6.1)' ) i, x(i)
      end do

      x_norm = cdotc ( n, x, 1, x, 1 )

      write ( *, '(a)' ) ' '
      write ( *, '(a)' ) '  The square of the norm of X, computed as'
      write ( *, '(a,f10.4,2x,f10.4)' ) '  CDOTC(X,X) = ', x_norm

      xy_dot = cdotc ( n, x, 1, y, 1 )

      write ( *, '(a)' ) ' '
      write ( *, '(a)' ) '  Y = '
      write ( *, '(a)' ) ' '
      do i = 1, n
        write ( *, '(2x,i6,2x,f6.1,2x,f6.1)' ) i, y(i)
      end do

      write ( *, '(a)' ) ' '
      write ( *, '(a,f10.4,2x,f10.4)' )
     &  '  The dot product X.Y* is ', xy_dot

      return
      end
      subroutine test06 ( )

c*********************************************************************72
c
cc TEST06 tests CDOTU.
c
c  Licensing:
c
c    This code is distributed under the MIT license.
c
c  Modified:
c
c    01 March 2006
c
c  Author:
c
c    John Burkardt
c
      implicit none

      integer n
      parameter ( n = 5 )

      complex cdotu
      integer i
      complex x_norm
      complex xy_dot
      complex x(n)
      complex y(n)

      x(1) = (  2.0E+00, -1.0E+00 )
      x(2) = ( -4.0E+00, -2.0E+00 )
      x(3) = (  3.0E+00,  1.0E+00 )
      x(4) = (  2.0E+00,  2.0E+00 )
      x(5) = ( -1.0E+00, -1.0E+00 )

      y(1) = ( -1.0E+00,  0.0E+00 )
      y(2) = (  0.0E+00, -3.0E+00 )
      y(3) = (  4.0E+00,  0.0E+00 )
      y(4) = ( -3.0E+00,  4.0E+00 )
      y(5) = ( -2.0E+00,  0.0E+00 )

      write ( *, '(a)' ) ' '
      write ( *, '(a)' ) 'TEST06'
      write ( *, '(a)' ) '  CDOTU computes the unconjugated dot product'
      write ( *, '(a)' ) '  of two complex vectors.'

      write ( *, '(a)' ) ' '
      write ( *, '(a)' ) '  X = '
      write ( *, '(a)' ) ' '
      do i = 1, n
        write ( *, '(2x,i6,2x,f6.1,2x,f6.1)' ) i, x(i)
      end do

      x_norm = cdotu ( n, x, 1, x, 1 )

      write ( *, '(a)' ) ' '
      write ( *, '(a)' ) '  The unconjugated dot product ( X dot X )'
      write ( *, '(a)' )
     &  '  (which is NOT the square of the norm of X!):'
      write ( *, '(a,f10.4,2x,f10.4)' ) '  CDOTU(X,X) = ', x_norm

      xy_dot = cdotu ( n, x, 1, y, 1 )

      write ( *, '(a)' ) ' '
      write ( *, '(a)' ) '  Y = '
      write ( *, '(a)' ) ' '
      do i = 1, n
        write ( *, '(2x,i6,2x,f6.1,2x,f6.1)' ) i, y(i)
      end do

      write ( *, '(a)' ) ' '
      write ( *, '(a,f10.4,2x,f10.4)' )
     &  '  The dot product ( X dot Y ) is ', xy_dot

      return
      end
      subroutine test07 ( )

c*********************************************************************72
c
cc TEST07 tests CMACH.
c
c  Licensing:
c
c    This code is distributed under the MIT license.
c
c  Modified:
c
c    01 March 2006
c
c  Author:
c
c    John Burkardt
c
      implicit none

      real cmach

      write ( *, '(a)' ) ' '
      write ( *, '(a)' ) 'TEST07'
      write ( *, '(a)' ) '  CMACH computes several machine-dependent'
      write ( *, '(a)' ) '  complex arithmetic parameters.'

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

      return
      end
      subroutine test08 ( )

c*********************************************************************72
c
cc TEST08 tests CROTG.
c
c  Licensing:
c
c    This code is distributed under the MIT license.
c
c  Modified:
c
c    15 May 2006
c
c  Author:
c
c    John Burkardt
c
      implicit none

      complex a
      complex b
      real c
      complex c4_uniform_01
      complex r
      complex s
      complex sa
      complex sb
      integer seed
      integer test
      integer test_num

      test_num = 5

      write ( *, '(a)' ) ' '
      write ( *, '(a)' ) 'TEST08'
      write ( *, '(a)' ) '  CROTG generates a complex Givens rotation'
      write ( *, '(a)' ) '    (  C  S ) * ( A ) = ( R )'
      write ( *, '(a)' ) '    ( -S  C )   ( B )   ( 0 )'
      write ( *, '(a)' ) ' '

      seed = 123456789

      do test = 1, test_num

        a = c4_uniform_01 ( seed )
        b = c4_uniform_01 ( seed )

        sa = a
        sb = b

        call crotg ( sa, sb, c, s )

        r = sa

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

      end do

      return
      end
      subroutine test09 ( )

c*********************************************************************72
c
cc TEST09 tests CSCAL.
c
c  Licensing:
c
c    This code is distributed under the MIT license.
c
c  Modified:
c
c    02 March 2006
c
c  Author:
c
c    John Burkardt
c
      implicit none

      integer n
      parameter ( n = 6 )

      complex da
      integer i
      complex x(n)

      do i = 1, n
        x(i) = cmplx ( 10 * i, i )
      end do

      write ( *, '(a)' ) ' '
      write ( *, '(a)' ) 'TEST09'
      write ( *, '(a)' ) '  CSCAL multiplies a complex scalar '
      write ( *, '(a)' ) '  times a vector.'

      write ( *, '(a)' ) ' '
      write ( *, '(a)' ) '  X = '
      write ( *, '(a)' ) ' '
      do i = 1, n
        write ( *, '(2x,i6,2x,f6.1,2x,f6.1)' ) i, x(i)
      end do

      da = cmplx ( 5.0E+00, 0.0E+00 )
      call cscal ( n, da, x, 1 )
      write ( *, '(a)' ) ' '
      write ( *, '(a,2f8.4,a)' ) '  CSCAL ( N, (', da, '), X, 1 )'
      write ( *, '(a)' ) ' '
      do i = 1, n
        write ( *, '(2x,i6,2x,f6.1,2x,f6.1)' ) i, x(i)
      end do

      do i = 1, n
        x(i) = cmplx ( 10 * i, i )
      end do

      da = cmplx ( -2.0E+00, 1.0E+00 )
      call cscal ( 3, da, x, 2 )
      write ( *, '(a)' ) ' '
      write ( *, '(a,2f8.4,a)' ) '  CSCAL ( 3, (', da, '), X, 2 )'
      write ( *, '(a)' ) ' '
      do i = 1, n
        write ( *, '(2x,i6,2x,f6.1,2x,f6.1)' ) i, x(i)
      end do

      return
      end
      subroutine test10 ( )

c*********************************************************************72
c
cc TEST10 tests CSIGN1.
c
c  Licensing:
c
c    This code is distributed under the MIT license.
c
c  Modified:
c
c    02 March 2006
c
c  Author:
c
c    John Burkardt
c
      implicit none

      complex c1
      complex c2
      complex c3
      complex c4_uniform_01
      complex csign1
      integer i
      integer seed

      seed = 123456789

      write ( *, '(a)' ) ' '
      write ( *, '(a)' ) 'TEST10'
      write ( *, '(a)' ) '  CSIGN1 ( C1, C2 ) transfers the sign of'
      write ( *, '(a)' ) '  complex C2 to the CABS1 magnitude of C1.'
      write ( *, '(a)' ) ' '
      write ( *, '(a)' )
     &  '           C1                    C2                    C3'
      write ( *, '(a,a)' )
     &  '  --------------------  --------------------  ',
     &  '--------------------'
      write ( *, '(a)' ) ' '

      do i = 1, 10

        c1 = 5.0E+00 * c4_uniform_01 ( seed )
        c2 = 5.0E+00 * c4_uniform_01 ( seed )
        c3 = csign1 ( c1, c2 )

        write ( *, '(2x,2f10.4,2x,2f10.4,2x,2f10.4)' ) c1, c2, c3

      end do

      return
      end
      subroutine test11 ( )

c*********************************************************************72
c
cc TEST11 tests CSIGN2.
c
c  Licensing:
c
c    This code is distributed under the MIT license.
c
c  Modified:
c
c    02 March 2006
c
c  Author:
c
c    John Burkardt
c
      implicit none

      complex c1
      complex c2
      complex c3
      complex c4_uniform_01
      complex csign2
      integer i
      integer seed

      seed = 123456789

      write ( *, '(a)' ) ' '
      write ( *, '(a)' ) 'TEST11'
      write ( *, '(a)' ) '  CSIGN2 ( C1, C2 ) transfers the sign of'
      write ( *, '(a)' ) '  complex C2 to the CABS2 magnitude of C1.'
      write ( *, '(a)' ) ' '
      write ( *, '(a)' )
     &  '           C1                    C2                    C3'
      write ( *, '(a,a)' )
     &  '  --------------------  --------------------  ',
     &  '--------------------'
      write ( *, '(a)' ) ' '

      do i = 1, 10

        c1 = 5.0E+00 * c4_uniform_01 ( seed )
        c2 = 5.0E+00 * c4_uniform_01 ( seed )
        c3 = csign2 ( c1, c2 )

        write ( *, '(2x,2f10.4,2x,2f10.4,2x,2f10.4)' ) c1, c2, c3

      end do

      return
      end
      subroutine test12 ( )

c*********************************************************************72
c
cc TEST12 tests CSROT.
c
c  Licensing:
c
c    This code is distributed under the MIT license.
c
c  Modified:
c
c    01 March 2006
c
c  Author:
c
c    John Burkardt
c
      implicit none

      integer n
      parameter ( n = 6 )

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

      do i = 1, n
        x(i) = cmplx ( 10 * i, i )
      end do

      do i = 1, n
        y(i) = cmplx ( 20 * i, 2 * i )
      end do

      write ( *, '(a)' ) ' '
      write ( *, '(a)' ) 'TEST12'
      write ( *, '(a)' ) '  CSROT carries out a Givens rotation'
      write ( *, '(a)' ) '  on a complex vector.'
      write ( *, '(a)' ) ' '
      write ( *, '(a)' ) '  X and Y'
      write ( *, '(a)' ) ' '
      do i = 1, n
        write ( *, '(2x,i6,2x,2f10.1,2x,2f10.1)' ) i, x(i), y(i)
      end do

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

      return
      end
      subroutine test13 ( )

c*********************************************************************72
c
cc TEST13 tests CSSCAL.
c
c  Licensing:
c
c    This code is distributed under the MIT license.
c
c  Modified:
c
c    02 March 2006
c
c  Author:
c
c    John Burkardt
c
      implicit none

      integer n
      parameter ( n = 6 )

      real da
      integer i
      complex x(n)

      do i = 1, n
        x(i) = cmplx ( 10 * i, i )
      end do

      write ( *, '(a)' ) ' '
      write ( *, '(a)' ) 'TEST13'
      write ( *, '(a)' ) '  CSSCAL multiplies a real scalar '
      write ( *, '(a)' ) '  times a complex vector.'

      write ( *, '(a)' ) ' '
      write ( *, '(a)' ) '  X = '
      write ( *, '(a)' ) ' '
      do i = 1, n
        write ( *, '(2x,i6,2x,f6.1,2x,f6.1)' ) i, x(i)
      end do

      da = 5.0E+00
      call csscal ( n, da, x, 1 )
      write ( *, '(a)' ) ' '
      write ( *, '(a,f8.4,a)' ) '  CSSCAL ( N, ', da, ', X, 1 )'
      write ( *, '(a)' ) ' '
      do i = 1, n
        write ( *, '(2x,i6,2x,f6.1,2x,f6.1)' ) i, x(i)
      end do

      do i = 1, n
        x(i) = cmplx ( 10 * i, i )
      end do

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

      return
      end
      subroutine test14 ( )

c*********************************************************************72
c
cc TEST14 tests CSWAP.
c
c  Licensing:
c
c    This code is distributed under the MIT license.
c
c  Modified:
c
c    02 March 2006
c
c  Author:
c
c    John Burkardt
c
      implicit none

      integer n
      parameter ( n = 5 )

      integer i
      complex x(n)
      complex y(n)

      do i = 1, n
        x(i) = cmplx ( 10 * i, i )
      end do

      do i = 1, n
        y(i) = cmplx ( 20 * i, 2 * i )
      end do

      write ( *, '(a)' ) ' '
      write ( *, '(a)' ) 'TEST14'
      write ( *, '(a)' ) '  CSWAP swaps two complex vectors.'
      write ( *, '(a)' ) ' '
      write ( *, '(a)' ) '  X and Y'
      write ( *, '(a)' ) ' '
      do i = 1, n
        write ( *, '(2x,i6,2x,2f7.1,2x,2f7.1)' ) i, x(i), y(i)
      end do

      call cswap ( n, x, 1, y, 1 )
      write ( *, '(a)' ) ' '
      write ( *, '(a)' ) '  CSWAP ( N, X, 1, Y, 1 )'
      write ( *, '(a)' ) ' '
      write ( *, '(a)' ) '  X and Y'
      write ( *, '(a)' ) ' '
      do i = 1, n
        write ( *, '(2x,i6,2x,2f7.1,2x,2f7.1)' ) i, x(i), y(i)
      end do

      do i = 1, n
        x(i) = cmplx ( 10 * i, i )
      end do

      do i = 1, n
        y(i) = cmplx ( 20 * i, 2 * i )
      end do

      call cswap ( 3, x, 2, y, 1 )
      write ( *, '(a)' ) ' '
      write ( *, '(a,f8.4,a)' ) '  CSWAP ( 3, X, 2, Y, 1 )'
      write ( *, '(a)' ) ' '
      write ( *, '(a)' ) '  X and Y'
      write ( *, '(a)' ) ' '
      do i = 1, n
        write ( *, '(2x,i6,2x,2f7.1,2x,2f7.1)' ) i, x(i), y(i)
      end do

      return
      end
      subroutine test15 ( )

c*********************************************************************72
c
cc TEST15 tests ICAMAX.
c
c  Licensing:
c
c    This code is distributed under the MIT license.
c
c  Modified:
c
c    14 April 2006
c
c  Author:
c
c    John Burkardt
c
      implicit none

      integer n

      parameter ( n = 5 )

      real cabs1
      integer i
      integer icamax
      integer incx
      complex x(n)

      x(1) = (  2.0E+00, -1.0E+00 )
      x(2) = ( -4.0E+00, -2.0E+00 )
      x(3) = (  3.0E+00,  1.0E+00 )
      x(4) = (  2.0E+00,  2.0E+00 )
      x(5) = ( -1.0E+00, -1.0E+00 )

      write ( *, '(a)' ) ' '
      write ( *, '(a)' ) 'TEST15'
      write ( *, '(a)' ) '  ICAMAX returns the index of maximum '
      write ( *, '(a)' ) '  magnitude;'

      write ( *, '(a)' ) ' '
      write ( *, '(a)' ) '  The entries and CABS1 magnitudes:'
      write ( *, '(a)' ) ' '
      do i = 1, n
        write ( *, '(2x,i6,2f8.4,2x,f8.4)' ) i, x(i), cabs1 ( x(i) )
      end do

      incx = 1

      i = icamax ( n, x, incx )

      write ( *, '(a)' ) ' '
      write ( *, '(a,i6)' ) '  The index of maximum magnitude = ', i
      write ( *, '(a)' ) ' '
      write ( *, '(a)' ) '  Note that this is a 1-based index.'
      write ( *, '(a)' ) '  Note that the L1 norm is used.'

      return
      end
      subroutine test16 ( )

c*********************************************************************72
c
cc TEST16 tests SCASUM.
c
c  Licensing:
c
c    This code is distributed under the MIT license.
c
c  Modified:
c
c    14 April 2006
c
c  Author:
c
c    John Burkardt
c
      implicit none

      integer ma
      integer na
      integer nx

      parameter ( ma = 5 )
      parameter ( na = 4 )
      parameter ( nx = 8 )

      complex a(ma,na)
      integer i
      integer j
      real scasum
      complex x(nx)

      a(1,1) = ( -3.0E+00,  4.0E+00 )
      a(2,1) = (  2.0E+00,  0.0E+00 )
      a(3,1) = (  3.0E+00, -4.0E+00 )
      a(4,1) = (  2.0E+00,  0.0E+00 )
      a(5,1) = (  2.0E+00, -1.0E+00 )
      a(1,2) = ( -1.0E+00,  1.0E+00 )
      a(2,2) = (  0.0E+00,  5.0E+00 )
      a(3,2) = ( -4.0E+00, -2.0E+00 )
      a(4,2) = ( -4.0E+00,  1.0E+00 )
      a(5,2) = ( -4.0E+00, -3.0E+00 )
      a(1,3) = (  0.0E+00, -2.0E+00 )
      a(2,3) = (  1.0E+00,  3.0E+00 )
      a(3,3) = ( -3.0E+00,  3.0E+00 )
      a(4,3) = ( -3.0E+00,  3.0E+00 )
      a(5,3) = ( -1.0E+00, -2.0E+00 )
      a(1,4) = ( -1.0E+00,  2.0E+00 )
      a(2,4) = (  2.0E+00, -4.0E+00 )
      a(3,4) = (  0.0E+00, -1.0E+00 )
      a(4,4) = (  0.0E+00, -1.0E+00 )
      a(5,4) = ( -2.0E+00,  4.0E+00 )

      x(1) = (  2.0E+00, -1.0E+00 )
      x(2) = ( -4.0E+00, -2.0E+00 )
      x(3) = (  3.0E+00,  1.0E+00 )
      x(4) = (  2.0E+00,  2.0E+00 )
      x(5) = ( -1.0E+00, -1.0E+00 )
      x(6) = ( -1.0E+00,  0.0E+00 )
      x(7) = (  0.0E+00, -3.0E+00 )
      x(8) = (  4.0E+00,  0.0E+00 )

      write ( *, '(a)' ) ' '
      write ( *, '(a)' ) 'TEST16'
      write ( *, '(a)' ) '  SCASUM adds the absolute values of'
      write ( *, '(a)' ) '  elements of a complex vector.'
      write ( *, '(a)' ) ' '
      write ( *, '(a)' ) '  X = '
      write ( *, '(a)' ) ' '
      do i = 1, nx
        write ( *, '(2x,i6,2x,f6.1,2x,f6.1)' ) i, x(i)
      end do

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

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

      write ( *, '(a)' ) ' '
      write ( *, '(a,g14.6)' )
     &  '  SCASUM ( MA, A(1,2), 1 )   = ', scasum ( ma, a(1,2), 1 )
      write ( *, '(a,g14.6)' )
     &  '  SCASUM ( NA, A(2,1), MA ) = ', scasum ( na, a(2,1), ma )

      return
      end
      subroutine test17 ( )

c*********************************************************************72
c
cc TEST17 tests SCNRM2.
c
c  Licensing:
c
c    This code is distributed under the MIT license.
c
c  Modified:
c
c    14 April 2006
c
c  Author:
c
c    John Burkardt
c
      implicit none

      integer n
      parameter ( n = 5 )

      integer i
      integer incx
      real norm
      real scnrm2
      complex x(n)

      x(1) = (  2.0E+00, -1.0E+00 )
      x(2) = ( -4.0E+00, -2.0E+00 )
      x(3) = (  3.0E+00,  1.0E+00 )
      x(4) = (  2.0E+00,  2.0E+00 )
      x(5) = ( -1.0E+00, -1.0E+00 )

      write ( *, '(a)' ) ' '
      write ( *, '(a)' ) 'TEST17'
      write ( *, '(a)' ) '  SCNRM2 returns the Euclidean norm'
      write ( *, '(a)' ) '  of a complex vector.'

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

      incx = 1
      norm = scnrm2 ( n, x, incx )

      write ( *, '(a)' ) ' '
      write ( *, '(a,g14.6)'    ) '  The L2 norm of X is ', norm

      return
      end
      function c4_uniform_01 ( seed )

c*********************************************************************72
c
cc c4_uniform_01() returns a unit pseudorandom C4.
c
c  Discussion:
c
c    A C4 is a complex value.
c
c    The angle should be uniformly distributed between 0 and 2 * PI,
c    the square root of the radius uniformly distributed between 0 and 1.
c
c    This results in a uniform distribution of values in the unit circle.
c
c  Licensing:
c
c    This code is distributed under the MIT license. 
c
c  Modified:
c
c    13 December 2008
c
c  Author:
c
c    John Burkardt
c
c  Parameters:
c
c    Input/output, integer SEED, the "seed" value, which should NOT be 0.
c    On output, SEED has been updated.
c
c    Output, complex Z_UNIFORM_01, a pseudorandom complex value.
c
      implicit none
      complex c4_uniform_01
      integer k
      real r
      real r4_pi
      parameter ( r4_pi = 3.141592653589793E+00 )
      integer seed
      real theta

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

      k = seed / 127773

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

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

      r = sqrt ( real ( seed ) * 4.656612875E-10 )

      k = seed / 127773

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

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

      theta = 2.0E+00 * r4_pi * ( real ( seed ) * 4.656612875E-10 )

      c4_uniform_01 = r * cmplx ( cos ( theta ), sin ( theta ) )

      return
      end
      function cabs1 ( z )

c*********************************************************************72
c
cc cabs1() returns the L1 norm of a single precision complex number.
c
c  Discussion:
c
c    The L1 norm of a complex number is the sum of the absolute values
c    of the real and imaginary components.
c
c    CABS1 ( Z ) = abs ( real ( Z ) ) + abs ( imaginary ( Z ) )
c
c  Licensing:
c
c    This code is distributed under the MIT license.
c
c  Modified:
c
c    22 May 2002
c
c  Reference:
c
c    Jack Dongarra, Jim Bunch, Cleve Moler, Pete Stewart,
c    LINPACK User's Guide,
c    SIAM, 1979,
c    ISBN13: 978-0-898711-72-1,
c    LC: QA214.L56.
c
c    Charles Lawson, Richard Hanson, David Kincaid, Fred Krogh,
c    Basic Linear Algebra Subprograms for FORTRAN usage,
c    ACM Transactions on Mathematical Software,
c    Volume 5, Number 3, pages 308-323, 1979.
c
c  Parameters:
c
c    Input, complex Z, the number whose norm is desired.
c
c    Output, real CABS1, the L1 norm of Z.
c
      implicit none

      real cabs1
      complex z

      cabs1 = abs ( real ( z ) ) + abs ( aimag ( z ) )

      return
      end
      function cabs2 ( z )

c*********************************************************************72
c
cc cabs2() returns the L2 norm of a single precision complex number.
c
c  Discussion:
c
c    The L2 norm of a complex number is the square root of the sum of the 
c    squares of the real and imaginary components.
c
c    CABS2 ( Z ) = sqrt ( ( real ( Z ) )**2 + ( imaginary ( Z ) )**2 )
c
c  Licensing:
c
c    This code is distributed under the MIT license.
c
c  Modified:
c
c    14 April 2006
c
c  Reference:
c
c    Jack Dongarra, Jim Bunch, Cleve Moler, Pete Stewart,
c    LINPACK User's Guide,
c    SIAM, 1979,
c    ISBN13: 978-0-898711-72-1,
c    LC: QA214.L56.
c
c    Charles Lawson, Richard Hanson, David Kincaid, Fred Krogh,
c    Basic Linear Algebra Subprograms for FORTRAN usage,
c    ACM Transactions on Mathematical Software,
c    Volume 5, Number 3, pages 308-323, 1979.
c
c  Parameters:
c
c    Input, complex Z, the number whose norm is desired.
c
c    Output, real CABS2, the L2 norm of Z.
c
      implicit none

      real cabs2
      complex z

      cabs2 = sqrt ( ( real ( z ) )**2 + ( aimag ( z ) )**2 )

      return
      end
      function cmach ( job )

c*********************************************************************72
c
cc cmach() computes single precision complex machine parameters.
c
c  Discussion:
c
c    Assume the computer has
c
c      B = base of arithmetic;
c      T = number of base B digits;
c      L = smallest possible exponent;
c      U = largest possible exponent;
c
c    then
c
c      EPS = B^(1-T)
c      TINY = 100.0 * B^(-L+T)
c      HUGE = 0.01 * B^(U-T)
c
c    If complex division is done by
c
c      1 / (X+i*Y) = (X-i*Y) / (X^2+Y^2)
c
c    then
c
c      TINY = sqrt ( TINY )
c      HUGE = sqrt ( HUGE )
c
c  Licensing:
c
c    This code is distributed under the MIT license.
c
c  Modified:
c
c    03 April 2014
c
c  Reference:
c
c    Jack Dongarra, Jim Bunch, Cleve Moler, Pete Stewart,
c    LINPACK User's Guide,
c    SIAM, 1979,
c    ISBN13: 978-0-898711-72-1,
c    LC: QA214.L56.
c
c    Charles Lawson, Richard Hanson, David Kincaid, Fred Krogh,
c    Basic Linear Algebra Subprograms for FORTRAN usage,
c    ACM Transactions on Mathematical Software,
c    Volume 5, Number 3, pages 308-323, 1979.
c
c  Parameters:
c
c    Input, integer JOB:
c    1, EPS is desired;
c    2, TINY is desired;
c    3, HUGE is desired.
c
c    Output, real CMACH, the requested value.
c
      implicit none

      real cmach
      real eps
      real huge
      integer job
      real s
      real tiny

      eps = 1.0E+00

   10 continue

      eps = eps / 2.0E+00
      s = 1.0E+00 + eps
      if ( 1.0E+00 .lt. s ) then
        go to 10
      end if
      eps = 2.0E+00 * eps
      cmach =eps
      if ( job .eq. 1 ) then
        return
      end if

      s = 1.0E+00

   20 continue

      tiny = s
      s = s/16.0E+00
      if (s*1.0E+00 .ne. 0.0E+00) go to 20
      tiny = (tiny/eps)*100.0E+00
      s = real((1.0E+00,0.0E+00)/cmplx(tiny,0.0E+00))
      if (s .ne. 1.0E+00/tiny) tiny = sqrt(tiny)
      huge = 1.0E+00/tiny

      if ( job .eq. 1 ) then
        cmach = eps
      else if ( job .eq. 2 ) then
        cmach = tiny
      else if ( job .eq. 3 ) then
        cmach = huge
      end if

      return
      end
      function csign1 ( z1, z2 )

c*********************************************************************72
c
cc CSIGN1() is a single precision complex transfer-of-sign function.
c
c  Discussion:
c
c    The L1 norm is used.
c
c  Modified:
c
c    14 May 2004
c
c  Parameters:
c
c    Input, complex Z1, Z2, the arguments.
c
c    Output, complex CSIGN1,  a complex value, with the magnitude of
c    Z1, and the argument of Z2.
c
      implicit none

      real cabs1
      complex csign1
      complex z1
      complex z2

      if ( cabs1 ( z2 ) == 0.0E+00 ) then
        csign1 = ( 0.0E+00, 0.0E+00 )
      else
        csign1 = cabs1 ( z1 ) * ( z2 / cabs1 ( z2 ) )
      end if

      return
      end
      function csign2 ( z1, z2 )

c*********************************************************************72
c
cc CSIGN2() is a single precision complex transfer-of-sign function.
c
c  Discussion:
c
c    The L2 norm is used.
c
c  Modified:
c
c    19 March 2006
c
c  Parameters:
c
c    Input, complex Z1, Z2, the arguments.
c
c    Output, complex CSIGN2,  a complex value, with the magnitude of
c    Z1, and the argument of Z2.
c
      implicit none

      real cabs2
      complex csign2
      complex z1
      complex z2

      if ( cabs2 ( z2 ) == 0.0E+00 ) then
        csign2 = ( 0.0E+00, 0.0E+00 )
      else
        csign2 = cabs2 ( z1 ) * ( z2 / cabs2 ( z2 ) )
      end if

      return
      end
      subroutine timestamp ( )

c*********************************************************************72
c
cc timestamp() prints the YMDHMS date as a timestamp.
c
c  Licensing:
c
c    This code is distributed under the MIT license.
c
c  Modified:
c
c    12 June 2014
c
c  Author:
c
c    John Burkardt
c
      implicit none

      character * ( 8 ) ampm
      integer d
      character * ( 8 ) date
      integer h
      integer m
      integer mm
      character * ( 9 ) month(12)
      integer n
      integer s
      character * ( 10 ) time
      integer y

      save month

      data month /
     &  'January  ', 'February ', 'March    ', 'April    ', 
     &  'May      ', 'June     ', 'July     ', 'August   ', 
     &  'September', 'October  ', 'November ', 'December ' /

      call date_and_time ( date, time )

      read ( date, '(i4,i2,i2)' ) y, m, d
      read ( time, '(i2,i2,i2,1x,i3)' ) h, n, s, mm

      if ( h .lt. 12 ) then
        ampm = 'AM'
      else if ( h .eq. 12 ) then
        if ( n .eq. 0 .and. s .eq. 0 ) then
          ampm = 'Noon'
        else
          ampm = 'PM'
        end if
      else
        h = h - 12
        if ( h .lt. 12 ) then
          ampm = 'PM'
        else if ( h .eq. 12 ) then
          if ( n .eq. 0 .and. s .eq. 0 ) then
            ampm = 'Midnight'
          else
            ampm = 'AM'
          end if
        end if
      end if

      write ( *, 
     &  '(i2,1x,a,1x,i4,2x,i2,a1,i2.2,a1,i2.2,a1,i3.3,1x,a)' ) 
     &  d, trim ( month(m) ), y, h, ':', n, ':', s, '.', mm, 
     &  trim ( ampm )

      return
      end