program main c*********************************************************************72 c cc blas1_z_test() tests blas1_z(). 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 call timestamp ( ) write ( *, '(a)' ) ' ' write ( *, '(a)' ) 'blas1_z_test():' write ( *, '(a)' ) ' FORTRAN77 version' write ( *, '(a)' ) ' Test blas1_z().' 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_z_test():' write ( *, '(a)' ) ' Normal end of execution.' write ( *, '(a)' ) ' ' call timestamp ( ) stop end subroutine test01 ( ) c*********************************************************************72 c cc TEST01 tests DZASUM. 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 ) double complex a(ma,na) double precision dzasum integer i integer j double complex x(nx) a(1,1) = ( -3.0D+00, 4.0D+00 ) a(2,1) = ( 2.0D+00, 0.0D+00 ) a(3,1) = ( 3.0D+00, -4.0D+00 ) a(4,1) = ( 2.0D+00, 0.0D+00 ) a(5,1) = ( 2.0D+00, -1.0D+00 ) a(1,2) = ( -1.0D+00, 1.0D+00 ) a(2,2) = ( 0.0D+00, 5.0D+00 ) a(3,2) = ( -4.0D+00, -2.0D+00 ) a(4,2) = ( -4.0D+00, 1.0D+00 ) a(5,2) = ( -4.0D+00, -3.0D+00 ) a(1,3) = ( 0.0D+00, -2.0D+00 ) a(2,3) = ( 1.0D+00, 3.0D+00 ) a(3,3) = ( -3.0D+00, 3.0D+00 ) a(4,3) = ( -3.0D+00, 3.0D+00 ) a(5,3) = ( -1.0D+00, -2.0D+00 ) a(1,4) = ( -1.0D+00, 2.0D+00 ) a(2,4) = ( 2.0D+00, -4.0D+00 ) a(3,4) = ( 0.0D+00, -1.0D+00 ) a(4,4) = ( 0.0D+00, -1.0D+00 ) a(5,4) = ( -2.0D+00, 4.0D+00 ) x(1) = ( 2.0D+00, -1.0D+00 ) x(2) = ( -4.0D+00, -2.0D+00 ) x(3) = ( 3.0D+00, 1.0D+00 ) x(4) = ( 2.0D+00, 2.0D+00 ) x(5) = ( -1.0D+00, -1.0D+00 ) x(6) = ( -1.0D+00, 0.0D+00 ) x(7) = ( 0.0D+00, -3.0D+00 ) x(8) = ( 4.0D+00, 0.0D+00 ) write ( *, '(a)' ) ' ' write ( *, '(a)' ) 'TEST01' write ( *, '(a)' ) ' DZASUM 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)' ) & ' DZASUM ( NX, X, 1 ) = ', dzasum ( nx, x, 1 ) write ( *, '(a,g14.6)' ) & ' DZASUM ( NX/2, X, 2 ) = ', dzasum ( nx/2, x, 2 ) write ( *, '(a,g14.6)' ) & ' DZASUM ( 2, X, NX/2 ) = ', dzasum ( 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)' ) & ' DZASUM ( MA, A(1,2), 1 ) = ', dzasum ( ma, a(1,2), 1 ) write ( *, '(a,g14.6)' ) & ' DZASUM ( NA, A(2,1), MA ) = ', dzasum ( na, a(2,1), ma ) return end subroutine test02 ( ) c*********************************************************************72 c cc TEST02 tests DZNRM2. 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 ) double precision dznrm2 integer i integer incx double precision norm double complex x(n) x(1) = ( 2.0D+00, -1.0D+00 ) x(2) = ( -4.0D+00, -2.0D+00 ) x(3) = ( 3.0D+00, 1.0D+00 ) x(4) = ( 2.0D+00, 2.0D+00 ) x(5) = ( -1.0D+00, -1.0D+00 ) write ( *, '(a)' ) ' ' write ( *, '(a)' ) 'TEST02' write ( *, '(a)' ) ' DZNRM2 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 = dznrm2 ( n, x, incx ) write ( *, '(a)' ) ' ' write ( *, '(a,g14.6)' ) ' The L2 norm of X is ', norm return end subroutine test03 ( ) c*********************************************************************72 c cc TEST03 tests IZAMAX. 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 integer n parameter ( n = 5 ) integer i integer incx integer izamax double complex x(n) double precision zabs1 x(1) = ( 2.0D+00, -1.0D+00 ) x(2) = ( -4.0D+00, -2.0D+00 ) x(3) = ( 3.0D+00, 1.0D+00 ) x(4) = ( 2.0D+00, 2.0D+00 ) x(5) = ( -1.0D+00, -1.0D+00 ) write ( *, '(a)' ) ' ' write ( *, '(a)' ) 'TEST03' write ( *, '(a)' ) ' IZAMAX returns the index of maximum ' write ( *, '(a)' ) ' magnitude;' write ( *, '(a)' ) ' ' write ( *, '(a)' ) ' The entries and ZABS1 magnitudes:' write ( *, '(a)' ) ' ' do i = 1, n write ( *, '(2x,i6,2f8.4,2x,f8.4)' ) i, x(i), zabs1 ( x(i) ) end do incx = 1 i = izamax ( 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 test04 ( ) c*********************************************************************72 c cc TEST04 tests ZABS1. 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 double complex c double precision c_norm integer i integer seed double complex c8_uniform_01 double precision zabs1 seed = 123456789 write ( *, '(a)' ) ' ' write ( *, '(a)' ) 'TEST04' write ( *, '(a)' ) ' ZABS1 returns the L1 norm ' write ( *, '(a)' ) ' of a double complex number.' write ( *, '(a)' ) ' ' write ( *, '(a)' ) ' Real Imaginary ' write ( *, '(a)' ) ' Part Part ZABS1(Z)' write ( *, '(a)' ) ' ' do i = 1, 10 c = 5.0D+00 * c8_uniform_01 ( seed ) c_norm = zabs1 ( c ) write ( *, '(2x,2f10.4,5x,f10.4)' ) c, c_norm end do return end subroutine test05 ( ) c*********************************************************************72 c cc TEST05 tests ZABS2. 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 double complex c double precision c_norm integer i integer seed double complex c8_uniform_01 double precision zabs2 seed = 123456789 write ( *, '(a)' ) ' ' write ( *, '(a)' ) 'TEST05' write ( *, '(a)' ) ' ZABS2 returns the L2 norm ' write ( *, '(a)' ) ' of a double complex number.' write ( *, '(a)' ) ' ' write ( *, '(a)' ) ' Real Imaginary ' write ( *, '(a)' ) ' Part Part ZABS2(Z)' write ( *, '(a)' ) ' ' do i = 1, 10 c = 5.0D+00 * c8_uniform_01 ( seed ) c_norm = zabs2 ( c ) write ( *, '(2x,2f10.4,5x,f10.4)' ) c, c_norm end do return end subroutine test06 ( ) c*********************************************************************72 c cc TEST06 tests ZAXPY. 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 double complex s double complex x(n) double complex y(n) x(1) = ( 2.0D+00, -1.0D+00 ) x(2) = ( -4.0D+00, -2.0D+00 ) x(3) = ( 3.0D+00, 1.0D+00 ) x(4) = ( 2.0D+00, 2.0D+00 ) x(5) = ( -1.0D+00, -1.0D+00 ) y(1) = ( -1.0D+00, 0.0D+00 ) y(2) = ( 0.0D+00, -3.0D+00 ) y(3) = ( 4.0D+00, 0.0D+00 ) y(4) = ( -3.0D+00, 4.0D+00 ) y(5) = ( -2.0D+00, 0.0D+00 ) write ( *, '(a)' ) ' ' write ( *, '(a)' ) 'TEST06' write ( *, '(a)' ) ' ZAXPY adds a multiple of one ' write ( *, '(a)' ) ' double 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.50D+00, -1.00D+00 ) write ( *, '(a)' ) ' ' write ( *, '(a,2g14.6)' ) ' The scalar multiplier is: ', s call zaxpy ( 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 test07 ( ) c*********************************************************************72 c cc TEST07 tests ZCOPY. 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 double complex a(5,5) integer i integer j double complex x(10) double complex y(10) write ( *, '(a)' ) ' ' write ( *, '(a)' ) 'TEST07' write ( *, '(a)' ) ' ZCOPY copies one double 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 zcopy ( 5, x, 1, y, 1 ) write ( *, '(a)' ) ' ' write ( *, '(a,f8.4,a)' ) ' ZCOPY ( 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 zcopy ( 3, x, 2, y, 3 ) write ( *, '(a)' ) ' ' write ( *, '(a,f8.4,a)' ) ' ZCOPY ( 3, X, 2, Y, 3 )' write ( *, '(a)' ) ' ' do i = 1, 10 write ( *, '(2x,i6,2g14.6)' ) i, y(i) end do call zcopy ( 5, x, 1, a, 1 ) write ( *, '(a)' ) ' ' write ( *, '(a,f8.4,a)' ) ' ZCOPY ( 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 zcopy ( 5, x, 2, a, 5 ) write ( *, '(a)' ) ' ' write ( *, '(a,f8.4,a)' ) ' ZCOPY ( 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 test08 ( ) c*********************************************************************72 c cc TEST08 tests ZDOTC. 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 ) integer i double complex x(n) double complex x_norm double complex xy_dot double complex y(n) double complex zdotc x(1) = ( 2.0D+00, -1.0D+00 ) x(2) = ( -4.0D+00, -2.0D+00 ) x(3) = ( 3.0D+00, 1.0D+00 ) x(4) = ( 2.0D+00, 2.0D+00 ) x(5) = ( -1.0D+00, -1.0D+00 ) y(1) = ( -1.0D+00, 0.0D+00 ) y(2) = ( 0.0D+00, -3.0D+00 ) y(3) = ( 4.0D+00, 0.0D+00 ) y(4) = ( -3.0D+00, 4.0D+00 ) y(5) = ( -2.0D+00, 0.0D+00 ) write ( *, '(a)' ) ' ' write ( *, '(a)' ) 'TEST08' write ( *, '(a)' ) ' ZDOTC computes the conjugated dot product' write ( *, '(a)' ) ' of two double 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 = zdotc ( 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)' ) ' ZDOTC(X,X) = ', x_norm xy_dot = zdotc ( 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 test09 ( ) c*********************************************************************72 c cc TEST09 tests ZDOTU. 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 ) integer i double complex x_norm double complex xy_dot double complex x(n) double complex y(n) double complex zdotu x(1) = ( 2.0D+00, -1.0D+00 ) x(2) = ( -4.0D+00, -2.0D+00 ) x(3) = ( 3.0D+00, 1.0D+00 ) x(4) = ( 2.0D+00, 2.0D+00 ) x(5) = ( -1.0D+00, -1.0D+00 ) y(1) = ( -1.0D+00, 0.0D+00 ) y(2) = ( 0.0D+00, -3.0D+00 ) y(3) = ( 4.0D+00, 0.0D+00 ) y(4) = ( -3.0D+00, 4.0D+00 ) y(5) = ( -2.0D+00, 0.0D+00 ) write ( *, '(a)' ) ' ' write ( *, '(a)' ) 'TEST09' write ( *, '(a)' ) ' ZDOTU computes the unconjugated dot product' write ( *, '(a)' ) ' of two double 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 = zdotu ( 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)' ) ' ZDOTU(X,X) = ', x_norm xy_dot = zdotu ( 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 test10 ( ) c*********************************************************************72 c cc TEST10 tests ZDROT. 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 ) double precision c integer i double precision s doublecomplex x(n) doublecomplex 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)' ) 'TEST10' write ( *, '(a)' ) ' ZDROT carries out a Givens rotation' write ( *, '(a)' ) ' on a double 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.5D+00 s = sqrt ( 1.0D+00 - c * c ) call zdrot ( n, x, 1, y, 1, c, s ) write ( *, '(a)' ) ' ' write ( *, '(a,f8.4,a,f8.4,a)' ) & ' ZDROT ( 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 test11 ( ) c*********************************************************************72 c cc TEST11 tests ZDSCAL. 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 ) double precision da integer i double complex x(n) do i = 1, n x(i) = cmplx ( 10 * i, i ) end do write ( *, '(a)' ) ' ' write ( *, '(a)' ) 'TEST11' write ( *, '(a)' ) ' ZDSCAL multiplies a double precision' write ( *, '(a)' ) ' scalar times a double 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.0D+00 call zdscal ( n, da, x, 1 ) write ( *, '(a)' ) ' ' write ( *, '(a,f8.4,a)' ) ' ZDSCAL ( 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.0D+00 call zdscal ( 3, da, x, 2 ) write ( *, '(a)' ) ' ' write ( *, '(a,f8.4,a)' ) ' ZDSCAL ( 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 test12 ( ) c*********************************************************************72 c cc TEST12 tests ZMACH. 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 double precision zmach write ( *, '(a)' ) ' ' write ( *, '(a)' ) 'TEST12' write ( *, '(a)' ) ' ZMACH computes several machine-dependent' write ( *, '(a)' ) ' double complex arithmetic parameters.' write ( *, '(a)' ) ' ' write ( *, * ) ' ZMACH(1) = machine epsilon = ', zmach ( 1 ) write ( *, * ) ' ZMACH(2) = a tiny value = ', zmach ( 2 ) write ( *, * ) ' ZMACH(3) = a huge value = ', zmach ( 3 ) return end subroutine test13 ( ) c*********************************************************************72 c cc TEST13 tests ZROTG. 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 double complex a double complex b double precision c double complex r double complex s double complex sa double complex sb integer seed integer test integer test_num double complex c8_uniform_01 test_num = 5 write ( *, '(a)' ) ' ' write ( *, '(a)' ) 'TEST13' write ( *, '(a)' ) ' ZROTG 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 = c8_uniform_01 ( seed ) b = c8_uniform_01 ( seed ) sa = a sb = b call zrotg ( 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 test14 ( ) c*********************************************************************72 c cc TEST14 tests ZSCAL. 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 ) double complex da integer i double complex x(n) do i = 1, n x(i) = cmplx ( 10 * i, i ) end do write ( *, '(a)' ) ' ' write ( *, '(a)' ) 'TEST14' write ( *, '(a)' ) ' ZSCAL multiplies a double 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 = ( 5.0D+00, 0.0D+00 ) call zscal ( n, da, x, 1 ) write ( *, '(a)' ) ' ' write ( *, '(a,2f8.4,a)' ) ' ZSCAL ( 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.0D+00, 1.0D+00 ) call zscal ( 3, da, x, 2 ) write ( *, '(a)' ) ' ' write ( *, '(a,2f8.4,a)' ) ' ZSCAL ( 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 test15 ( ) c*********************************************************************72 c cc TEST15 tests ZSIGN1. 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 double complex c1 double complex c2 double complex c3 integer i integer seed double complex c8_uniform_01 double complex zsign1 seed = 123456789 write ( *, '(a)' ) ' ' write ( *, '(a)' ) 'TEST15' write ( *, '(a)' ) ' ZSIGN1 ( C1, C2 ) transfers the sign of' write ( *, '(a)' ) ' double complex C2 to the ZABS1 magnitude ' write ( *, '(a)' ) ' of C1.' write ( *, '(a)' ) ' ' write ( *, '(a)' ) & ' C1 C2 C3' write ( *, '(a,a)' ) & ' -------------------- -------------------- ', & '--------------------' write ( *, '(a)' ) ' ' do i = 1, 10 c1 = 5.0D+00 * c8_uniform_01 ( seed ) c2 = 5.0D+00 * c8_uniform_01 ( seed ) c3 = zsign1 ( c1, c2 ) write ( *, '(2x,2f10.4,2x,2f10.4,2x,2f10.4)' ) c1, c2, c3 end do return end subroutine test16 ( ) c*********************************************************************72 c cc TEST16 tests ZSIGN2. 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 double complex c1 double complex c2 double complex c3 integer i integer seed double complex c8_uniform_01 double complex zsign2 seed = 123456789 write ( *, '(a)' ) ' ' write ( *, '(a)' ) 'TEST16' write ( *, '(a)' ) ' ZSIGN2 ( C1, C2 ) transfers the sign of' write ( *, '(a)' ) ' double complex C2 to the ZABS2 magnitude ' write ( *, '(a)' ) ' of C1.' write ( *, '(a)' ) ' ' write ( *, '(a)' ) & ' C1 C2 C3' write ( *, '(a,a)' ) & ' -------------------- -------------------- ', & '--------------------' write ( *, '(a)' ) ' ' do i = 1, 10 c1 = 5.0D+00 * c8_uniform_01 ( seed ) c2 = 5.0D+00 * c8_uniform_01 ( seed ) c3 = zsign2 ( c1, c2 ) write ( *, '(2x,2f10.4,2x,2f10.4,2x,2f10.4)' ) c1, c2, c3 end do return end subroutine test17 ( ) c*********************************************************************72 c cc TEST17 tests ZSWAP. 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 double complex x(n) double 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)' ) 'TEST17' write ( *, '(a)' ) ' ZSWAP swaps two double 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 zswap ( n, x, 1, y, 1 ) write ( *, '(a)' ) ' ' write ( *, '(a)' ) ' ZSWAP ( 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 zswap ( 3, x, 2, y, 1 ) write ( *, '(a)' ) ' ' write ( *, '(a,f8.4,a)' ) ' ZSWAP ( 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 function c8_uniform_01 ( seed ) c*********************************************************************72 c cc c8_uniform_01() returns a unit double precision complex pseudorandom number. c c Discussion: 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 27 February 2006 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, double complex C8_UNIFORM_01, a pseudorandom complex value. c implicit none double precision pi parameter ( pi = 3.141592653589793D+00 ) double precision r integer k integer seed double precision theta double complex c8_uniform_01 k = seed / 127773 seed = 16807 * ( seed - k * 127773 ) - k * 2836 if ( seed .lt. 0 ) then seed = seed + 2147483647 end if r = sqrt ( dble ( seed ) * 4.656612875D-10 ) k = seed / 127773 seed = 16807 * ( seed - k * 127773 ) - k * 2836 if ( seed .lt. 0 ) then seed = seed + 2147483647 end if theta = 2.0D+00 * pi * ( dble ( seed ) * 4.656612875D-10 ) c8_uniform_01 = r * dcmplx ( cos ( theta ), sin ( theta ) ) return end function zabs1 ( z ) c*********************************************************************72 c cc zabs1() returns the L1 norm of a double 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 ZABS1 ( 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 01 March 2006 c c Author: c c John Burkardt c c Reference: c c Jack Dongarra, Jim Bunch, Cleve Moler, Pete Stewart, c LINPACK User's Guide, c SIAM, 1979, c ISBN13: 978-0-898711-72-1, c 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, double complex Z, the number whose norm is desired. c c Output, double precision ZABS1, the L1 norm of Z. c implicit none double complex z double precision zabs1 zabs1 = abs ( dble ( z ) ) + abs ( dimag ( z ) ) return end function zabs2 ( z ) c*********************************************************************72 c cc zabs2() returns the L2 norm of a double 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 ZABS2 ( 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 Author: c c John Burkardt c c Reference: c c Jack Dongarra, Cleve Moler, Jim Bunch, Pete Stewart, c LINPACK User's Guide, c SIAM, 1979. 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, double complex Z, the number whose norm is desired. c c Output, double precision ZABS2, the L2 norm of Z. c implicit none double precision zabs2 double complex z zabs2 = sqrt ( ( dble ( z ) )**2 + ( dimag ( z ) )**2 ) return end function zmach ( job ) c*********************************************************************72 c cc zmach() computes double complex floating point arithmetic constants. 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 08 July 2007 c c Author: c c This version by John Burkardt c c Reference: c c Jack Dongarra, Jim Bunch, Cleve Moler, Pete Stewart, c LINPACK User's Guide, c SIAM, 1979, c ISBN13: 978-0-898711-72-1, c 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, indicates the desired quantity. c 1: EPS c 2: TINY c 3: HUGE c c Output, double precision ZMACH, the value of the desired quantity. c implicit none double precision eps double precision huge integer job double precision s double precision tiny double precision zmach eps = 1.0d0 10 continue eps = eps / 2.0d0 s = 1.0d0 + eps if ( 1.0d0 .lt. s ) then go to 10 end if eps = 2.0d0 * eps s = 1.0d0 20 continue tiny = s s = s / 16.0d0 if ( s * 1.0d0 .ne. 0.0d0 ) then go to 20 end if tiny = tiny / eps s = dble ( ( 1.0d0, 0.0d0 ) / dcmplx ( tiny, 0.0d0 ) ) if ( s .ne. 1.0d0 / tiny ) then tiny = dsqrt ( tiny ) end if huge = 1.0d0 / tiny if ( job .eq. 1 ) then zmach = eps else if ( job .eq. 2 ) then zmach = tiny else if ( job .eq. 3 ) then zmach = huge end if return end function zsign1 ( z1, z2 ) c*********************************************************************72 c cc zsign1() is a double precision complex transfer-of-sign function. c c Licensing: c c This code is distributed under the MIT license. c c Modified: c c 14 May 2004 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, double complex Z1, Z2, the arguments. c c Output, double complex ZSIGN1, a complex value, with the c magnitude of Z1, and the argument of Z2. c implicit none double complex z1 double complex z2 double precision zabs1 double complex zsign1 if ( zabs1 ( z2 ) == 0.0D+00 ) then zsign1 = ( 0.0D+00, 0.0D+00 ) else zsign1 = zabs1 ( z1 ) * ( z2 / zabs1 ( z2 ) ) end if return end function zsign2 ( z1, z2 ) c*********************************************************************72 c cc zsign2() is a double precision complex transfer-of-sign function. c c Discussion: c c The L2 norm is used. c c Licensing: c c This code is distributed under the MIT license. c c Modified: c c 19 March 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, double complex Z1, Z2, the arguments. c c Output, double complex ZSIGN2, a complex value, with the magnitude of c Z1, and the argument of Z2. c implicit none double complex z1 double complex z2 double precision zabs2 double complex zsign2 if ( zabs2 ( z2 ) == 0.0D+00 ) then zsign2 = ( 0.0D+00, 0.0D+00 ) else zsign2 = zabs2 ( z1 ) * ( z2 / zabs2 ( 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