program main

c*********************************************************************72
c
cc MAIN is the main program for BLAS1_C_PRB.
c
c  Discussion:
c
c    BLAS1_C_PRB tests the BLAS1_C library.
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

      call timestamp ( )
      write ( *, '(a)' ) ' '
      write ( *, '(a)' ) 'BLAS1_C_PRB:'
      write ( *, '(a)' ) '  FORTRAN77 version'
      write ( *, '(a)' ) '  Test the BLAS1_C 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 ( )
      call test13 ( )
      call test14 ( )
      call test15 ( )
      call test16 ( )
      call test17 ( )
c
c  Terminate.
c
      write ( *, '(a)' ) ' '
      write ( *, '(a)' ) 'BLAS1_C_PRB:'
      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 GNU LGPL 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 GNU LGPL 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 GNU LGPL 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 GNU LGPL 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 GNU LGPL 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 GNU LGPL 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 GNU LGPL license.
c
c  Modified:
c
c    01 March 2006
c
c  Author:
c
c    John Burkardt
c
      implicit none

      real cmach
      integer job

      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 GNU LGPL 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 GNU LGPL 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 GNU LGPL 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 GNU LGPL 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 GNU LGPL 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 GNU LGPL 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 GNU LGPL 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 GNU LGPL 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 GNU LGPL 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 GNU LGPL 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