program main c*********************************************************************72 c cc test_matrix_test() tests test_matrix(). c c Licensing: c c This code is distributed under the MIT license. c c Modified: c c 15 March 2015 c c Author: c c John Burkardt c implicit none call timestamp ( ) write ( *, '(a)' ) ' ' write ( *, '(a)' ) 'test_matrix_test():' write ( *, '(a)' ) ' Fortran77 version' write ( *, '(a)' ) ' Test test_matrix().' c c Utilities. c call bvec_next_grlex_test ( ) call legendre_zeros_test ( ) call mertens_test ( ) call moebius_test ( ) call r8mat_is_eigen_left_test ( ) call r8mat_is_eigen_right_test ( ) call r8mat_is_llt_test ( ) call r8mat_is_null_left_test ( ) call r8mat_is_null_right_test ( ) call r8mat_is_solution_test ( ) call r8mat_norm_fro_test ( ) c c Important things. c call test_condition ( ) call test_determinant ( ) call test_eigen_left ( ) call test_eigen_right ( ) call test_inverse ( ) call test_llt ( ) call test_null_left ( ) call test_null_right ( ) call test_plu ( ) call test_solution ( ) call test_type ( ) c c Terminate. c write ( *, '(a)' ) ' ' write ( *, '(a)' ) 'test_matrix_test():' write ( *, '(a)' ) ' Normal end of execution.' write ( *, '(a)' ) ' ' call timestamp ( ) stop end subroutine bvec_next_grlex_test ( ) c*********************************************************************72 c cc bvec_next_grlex_test() tests bvec_next_grlex(). c c Licensing: c c This code is distributed under the MIT license. c c Modified: c c 13 March 2015 c c Author: c c John Burkardt c implicit none integer n parameter ( n = 4 ) integer b(n) integer i integer j write ( *, '(a)' ) ' ' write ( *, '(a)' ) 'BVEC_NEXT_GRLEX_TEST' write ( *, '(a)' ) & ' BVEC_NEXT_GRLEX computes binary vectors in GRLEX order.' write ( *, '(a)' ) '' b(1:n) = 0 do i = 0, 16 write ( *, '(2x,i2,a)', advance = 'no' ) i, ': ' do j = 1, n write ( *, '(i1)', advance = 'no' ) b(j) end do write ( *, '(a)' ) '' call bvec_next_grlex ( n, b ) end do return end subroutine legendre_zeros_test ( ) c*********************************************************************72 c cc legendre_zeros_test() tests legendre_zeros(). c c Licensing: c c This code is distributed under the MIT license. c c Modified: c c 17 February 2015 c c Author: c c John Burkardt c implicit none integer n_max parameter ( n_max = 7 ) double precision l(n_max) integer n write ( *, '(a)' ) '' write ( *, '(a)' ) 'LEGENDRE_ZEROS_TEST:' write ( *, '(a)' ) ' LEGENDRE_ZEROS computes the zeros of the' write ( *, '(a)' ) ' N-th Legendre polynomial.' do n = 1, 7 call legendre_zeros ( n, l ) call r8vec_print ( n, l, ' Legendre zeros' ) end do return end subroutine mertens_test ( ) c*********************************************************************72 c cc MERTENS_TEST tests MERTENS. c c Licensing: c c This code is distributed under the MIT license. c c Modified: c c 22 March 2009 c c Author: c c John Burkardt c implicit none integer c integer c2 integer mertens integer n integer n_data write ( *, '(a)' ) ' ' write ( *, '(a)' ) 'MERTENS_TEST' write ( *, '(a)' ) ' MERTENS computes the Mertens function.' write ( *, '(a)' ) ' ' write ( *, '(a)' ) ' N Exact MERTENS(N)' write ( *, '(a)' ) ' ' n_data = 0 10 continue call mertens_values ( n_data, n, c ) if ( n_data .eq. 0 ) then go to 20 end if c2 = mertens ( n ) write ( *, '(2x,i8,2x,i10,2x,i10)' ) n, c, c2 go to 10 20 continue return end subroutine moebius_test ( ) c*********************************************************************72 c cc MOEBIUS_TEST tests MOEBIUS. c c Licensing: c c This code is distributed under the MIT license. c c Modified: c c 22 March 2009 c c Author: c c John Burkardt c implicit none integer c integer c2 integer n integer n_data write ( *, '(a)' ) ' ' write ( *, '(a)' ) 'MOEBIUS_TEST' write ( *, '(a)' ) ' MOEBIUS computes the Moebius function.' write ( *, '(a)' ) ' ' write ( *, '(a)' ) ' N Exact MOEBIUS(N)' write ( *, '(a)' ) ' ' n_data = 0 10 continue call moebius_values ( n_data, n, c ) if ( n_data .eq. 0 ) then go to 20 end if call moebius ( n, c2 ) write ( *, '(2x,i8,2x,i10,2x,i10)' ) n, c, c2 go to 10 20 continue return end subroutine r8mat_is_eigen_left_test ( ) c*********************************************************************72 c cc R8MAT_IS_EIGEN_LEFT_TEST tests R8MAT_IS_EIGEN_LEFT. c c Licensing: c c This code is distributed under the MIT license. c c Modified: c c 13 March 2015 c c Author: c c John Burkardt c implicit none integer n parameter ( n = 4 ) integer k parameter ( k = 4 ) c c This is the CARRY ( 4.0, 4 ) matrix. c double precision a(n,n) double precision lam(n) double precision value double precision x(n,k) save a save lam save x data a / & 0.13671875D+00, 0.05859375D+00, & 0.01953125D+00, 0.00390625D+00, & 0.60546875D+00, 0.52734375D+00, & 0.39453125D+00, 0.25390625D+00, & 0.25390625D+00, 0.39453125D+00, & 0.52734375D+00, 0.60546875D+00, & 0.00390625D+00, 0.01953125D+00, & 0.05859375D+00, 0.13671875D+00 / data lam / & 1.000000000000000D+00, & 0.250000000000000D+00, & 0.062500000000000D+00, & 0.015625000000000D+00 / data x / & 1.0D+00, 11.0D+00, 11.0D+00, 1.0D+00, & 1.0D+00, 3.0D+00, -3.0D+00, -1.0D+00, & 1.0D+00, -1.0D+00, -1.0D+00, 1.0D+00, & 1.0D+00, -3.0D+00, 3.0D+00, -1.0D+00 / write ( *, '(a)' ) '' write ( *, '(a)' ) 'R8MAT_IS_EIGEN_LEFT_TEST:' write ( *, '(a)' ) & ' R8MAT_IS_EIGEN_LEFT tests the error in the left eigensystem' write ( *, '(a)' ) ' A'' * X - X * LAMBDA = 0' call r8mat_print ( n, n, a, ' Matrix A:' ) call r8mat_print ( n, k, x, ' Eigenmatrix X:' ) call r8vec_print ( n, lam, ' Eigenvalues LAM:' ) call r8mat_is_eigen_left ( n, k, a, x, lam, value ) write ( *, '(a)' ) '' write ( *, '(a,g14.6)' ) & ' Frobenius norm of A''*X-X*LAMBDA is ', value write ( *, '(a)' ) '' write ( *, '(a)' ) 'R8MAT_IS_EIGEN_LEFT_TEST' write ( *, '(a)' ) ' Normal end of execution.' return end subroutine r8mat_is_eigen_right_test ( ) c*********************************************************************72 c cc R8MAT_IS_EIGEN_RIGHT_TEST tests R8MAT_IS_EIGEN_RIGHT. c c Licensing: c c This code is distributed under the MIT license. c c Modified: c c 13 March 2015 c c Author: c c John Burkardt c implicit none integer n parameter ( n = 4 ) integer k parameter ( k = 4 ) c c This is the CARRY ( 4.0, 4 ) matrix. c double precision a(n,n) double precision lam(n) double precision value double precision x(n,k) save a save lam save x data a / & 0.13671875D+00, 0.05859375D+00, & 0.01953125D+00, 0.00390625D+00, & 0.60546875D+00, 0.52734375D+00, & 0.39453125D+00, 0.25390625D+00, & 0.25390625D+00, 0.39453125D+00, & 0.52734375D+00, 0.60546875D+00, & 0.00390625D+00, 0.01953125D+00, & 0.05859375D+00, 0.13671875D+00 / data lam / & 1.000000000000000D+00, & 0.250000000000000D+00, & 0.062500000000000D+00, & 0.015625000000000D+00 / data x / & 1.0D+00, 1.0D+00, 1.0D+00, 1.0D+00, & 6.0D+00, 2.0D+00, -2.0D+00, -6.0D+00, & 11.0D+00, -1.0D+00, -1.0D+00, 11.0D+00, & 6.0D+00, -2.0D+00, 2.0D+00, -6.0D+00 / write ( *, '(a)' ) '' write ( *, '(a)' ) 'R8MAT_IS_EIGEN_RIGHT_TEST:' write ( *, '(a)' ) & ' R8MAT_IS_EIGEN_RIGHT tests error in the right eigensystem' write ( *, '(a)' ) ' A * X - X * LAMBDA = 0' call r8mat_print ( n, n, a, ' Matrix A:' ) call r8mat_print ( n, k, x, ' Eigenmatrix X:' ) call r8vec_print ( n, lam, ' Eigenvalues LAM:' ) call r8mat_is_eigen_right ( n, k, a, x, lam, value ) write ( *, '(a)' ) '' write ( *, '(a,g14.6)' ) & ' Frobenius norm of A*X-X*LAMBDA is ', value write ( *, '(a)' ) '' write ( *, '(a)' ) 'R8MAT_IS_EIGEN_RIGHT_TEST' write ( *, '(a)' ) ' Normal end of execution.' return end subroutine r8mat_is_llt_test ( ) c*********************************************************************72 c cc R8MAT_IS_LLT_TEST tests R8MAT_IS_LLT. c c Licensing: c c This code is distributed under the MIT license. c c Modified: c c 15 March 2015 c c Author: c c John Burkardt c implicit none integer m parameter ( m = 4 ) integer n parameter ( n = 4 ) double precision a(4,4) double precision enorm double precision l(4,4) save a save l data a / & 2.0D+00, 1.0D+00, 0.0D+00, 0.0D+00, & 1.0D+00, 2.0D+00, 1.0D+00, 0.0D+00, & 0.0D+00, 1.0D+00, 2.0D+00, 1.0D+00, & 0.0D+00, 0.0D+00, 1.0D+00, 2.0D+00 / data l / & 1.414213562373095D+00, 0.707106781186547D+00, & 0.0D+00, 0.0D+00, & 0.0D+00, 1.224744871391589D+00, & 0.816496580927726D+00, 0.0D+00, & 0.0D+00, 0.0D+00, & 1.154700538379251D+00, 0.866025403784439D+00, & 0.0D+00, 0.0D+00, & 0.0D+00, 1.118033988749895D+00 / write ( *, '(a)' ) '' write ( *, '(a)' ) 'R8MAT_IS_LLT_TEST:' write ( *, '(a)' ) & ' R8MAT_IS_LLT tests the error in a lower triangular' write ( *, '(a)' ) & ' Cholesky factorization A = L * L'' by looking at' write ( *, '(a)' ) ' A - L * L''' call r8mat_print ( m, m, a, ' Matrix A:' ); call r8mat_print ( m, n, l, ' Factor L:' ); call r8mat_is_llt ( m, n, a, l, enorm ) write ( *, '(a)' ) '' write ( *, '(a,g14.6)' ) ' Frobenius norm of A-L*L'' is ', enorm write ( *, '(a)' ) '' write ( *, '(a)' ) 'R8MAT_IS_LLT_TEST' write ( *, '(a)' ) ' Normal end of execution.' return end subroutine r8mat_is_null_left_test ( ) c*********************************************************************72 c cc R8MAT_IS_NULL_LEFT_TEST tests R8MAT_IS_NULL_LEFT. c c Licensing: c c This code is distributed under the MIT license. c c Modified: c c 06 March 2015 c c Author: c c John Burkardt c implicit none integer m parameter ( m = 3 ) integer n parameter ( n = 3 ) double precision a(m,n) double precision enorm double precision x(m) save a save x data a / & 1.0D+00, 4.0D+00, 7.0D+00, & 2.0D+00, 5.0D+00, 8.0D+00, & 3.0D+00, 6.0D+00, 9.0D+00 / data x / & 1.0D+00, -2.0D+00, 1.0D+00 / write ( *, '(a)' ) '' write ( *, '(a)' ) 'R8MAT_IS_NULL_LEFT_TEST:' write ( *, '(a)' ) & ' R8MAT_IS_NULL_LEFT tests whether the M vector X' write ( *, '(a)' ) & ' is a left null vector of A, that is, x''*A=0.' call r8mat_print ( m, n, a, ' Matrix A:' ) call r8vec_print ( m, x, ' Vector X:' ) call r8mat_is_null_left ( m, n, a, x, enorm ) write ( *, '(a)' ) '' write ( *, '(a,g14.6)' ) ' Frobenius norm of X''*A is ', enorm return end subroutine r8mat_is_null_right_test ( ) c*********************************************************************72 c cc R8MAT_IS_NULL_RIGHT_TEST tests R8MAT_IS_NULL_RIGHT. c c Licensing: c c This code is distributed under the MIT license. c c Modified: c c 06 March 2015 c c Author: c c John Burkardt c implicit none integer m parameter ( m = 3 ) integer n parameter ( n = 3 ) double precision a(m,n) double precision enorm double precision x(n) save a save x data a / & 1.0D+00, 4.0D+00, 7.0D+00, & 2.0D+00, 5.0D+00, 8.0D+00, & 3.0D+00, 6.0D+00, 9.0D+00 / data x / & 1.0D+00, -2.0D+00, 1.0D+00 / write ( *, '(a)' ) '' write ( *, '(a)' ) 'R8MAT_IS_NULL_RIGHT_TEST:' write ( *, '(a)' ) & ' R8MAT_IS_NULL_RIGHT tests whether the N vector X' write ( *, '(a)' ) & ' is a right null vector of A, that is, A*X=0.' call r8mat_print ( m, n, a, ' Matrix A:' ) call r8vec_print ( n, x, ' Vector X:' ) call r8mat_is_null_right ( m, n, a, x, enorm ) write ( *, '(a)' ) '' write ( *, '(a,g14.6)' ) ' Frobenius norm of A*X is ', enorm return end subroutine r8mat_is_solution_test ( ) c*********************************************************************72 c cc R8MAT_IS_SOLUTION_TEST tests R8MAT_IS_SOLUTION. c c Licensing: c c This code is distributed under the MIT license. c c Modified: c c 28 February 2015 c c Author: c c John Burkardt c implicit none double precision a(10,10) double precision b(10,10) double precision enorm integer i4_hi integer i4_lo integer i4_uniform_ab integer k integer m integer n double precision r8_hi double precision r8_lo integer seed double precision x(10,10) write ( *, '(a)' ) '' write ( *, '(a)' ) 'R8MAT_IS_SOLUTION_TEST:' write ( *, '(a)' ) & ' R8MAT_IS_SOLUTION tests whether X is the solution of' write ( *, '(a)' ) & ' A*X=B by computing the Frobenius norm of the residual.' c c Get random shapes. c i4_lo = 1 i4_hi = 10 seed = 123456789 m = i4_uniform_ab ( i4_lo, i4_hi, seed ) n = i4_uniform_ab ( i4_lo, i4_hi, seed ) k = i4_uniform_ab ( i4_lo, i4_hi, seed ) c c Get a random A. c r8_lo = -5.0D+00 r8_hi = +5.0D+00 call r8mat_uniform_ab ( m, n, r8_lo, r8_hi, seed, a ) c c Get a random X. c r8_lo = -5.0D+00 r8_hi = +5.0D+00 call r8mat_uniform_ab ( n, k, r8_lo, r8_hi, seed, x ) c c Compute B = A * X. c call r8mat_mm ( m, n, k, a, x, b ) c c Compute || A*X-B|| c call r8mat_is_solution ( m, n, k, a, x, b, enorm ) write ( *, '(a)' ) '' write ( *, '(a,i2,a,i2)' ) ' A is ', m, ' by ', n write ( *, '(a,i2,a,i2)' ) ' X is ', n, ' by ', k write ( *, '(a,i2,a,i2)' ) ' B is ', m, ' by ', k write ( *, '(a,g14.6)' ) ' Frobenius error in A*X-B is ', enorm return end subroutine r8mat_norm_fro_test ( ) c*********************************************************************72 c cc R8MAT_NORM_FRO_TEST tests R8MAT_NORM_FRO. c c Licensing: c c This code is distributed under the MIT license. c c Modified: c c 04 December 2014 c c Author: c c John Burkardt c implicit none integer m parameter ( m = 5 ) integer n parameter ( n = 4 ) double precision a(m,n) integer i integer j integer k double precision r8mat_norm_fro double precision t1 double precision t2 write ( *, '(a)' ) ' ' write ( *, '(a)' ) 'R8MAT_NORM_FRO_TEST' write ( *, '(a)' ) & ' R8MAT_NORM_FRO computes the Frobenius norm of an R8MAT;' t1 = 0.0D+00 k = 0 do i = 1, m do j = 1, n k = k + 1 a(i,j) = dble ( k ) t1 = t1 + dble ( k * k ) end do end do t1 = sqrt ( t1 ) call r8mat_print ( m, n, a, ' A:' ) t2 = r8mat_norm_fro ( m, n, a ) write ( *, '(a)' ) '' write ( *, '(a,g14.6)' ) ' Expected norm = ', t1 write ( *, '(a,g14.6)' ) ' Computed norm = ', t2 return end subroutine test_condition ( ) c*********************************************************************72 c cc test_condition() tests the condition number computations. c c Licensing: c c This code is distributed under the MIT license. c c Modified: c c 11 April 2015 c c Author: c c John Burkardt c implicit none integer n_max parameter ( n_max = 70 ) double precision a(n_max,n_max) double precision a_norm double precision alpha double precision b(n_max,n_max) double precision b_norm double precision beta double precision cond1 double precision cond2 integer n double precision r8_hi double precision r8_lo double precision r8_uniform_ab double precision r8mat_norm_l1 integer seed character * ( 20 ) title double precision x(n_max) write ( *, '(a)' ) ' ' write ( *, '(a)' ) 'test_condition()' write ( *, '(a)' ) ' Compute the L1 condition number of an' write ( *, '(a)' ) ' example of each test matrix' write ( *, '(a)' ) ' ' write ( *, '(a)' ) & ' Title N COND COND' write ( *, '(a)' ) ' ' c c AEGERTER c title = 'AEGERTER' n = 5 call aegerter_condition ( n, cond1 ) call aegerter_matrix ( n, a ) call aegerter_inverse ( n, b ) a_norm = r8mat_norm_l1 ( n, n, a ) b_norm = r8mat_norm_l1 ( n, n, b ) cond2 = a_norm * b_norm write ( *, '(2x,a20,2x,i4,2x,g14.6,2x,g14.6)' ) & title, n, cond1, cond2 c c BAB c title = 'BAB' n = 5 r8_lo = -5.0D+00 r8_hi = +5.0D+00 seed = 123456789 alpha = r8_uniform_ab ( r8_lo, r8_hi, seed ) beta = r8_uniform_ab ( r8_lo, r8_hi, seed ) call bab_condition ( n, alpha, beta, cond1 ) call bab_matrix ( n, alpha, beta, a ) call bab_inverse ( n, alpha, beta, b ) a_norm = r8mat_norm_l1 ( n, n, a ) b_norm = r8mat_norm_l1 ( n, n, b ) cond2 = a_norm * b_norm write ( *, '(2x,a20,2x,i4,2x,g14.6,2x,g14.6)' ) & title, n, cond1, cond2 c c BAUER c title = 'BAUER' n = 6 call bauer_condition ( cond1 ) call bauer_matrix ( a ) call bauer_inverse ( b ) a_norm = r8mat_norm_l1 ( n, n, a ) b_norm = r8mat_norm_l1 ( n, n, b ) cond2 = a_norm * b_norm write ( *, '(2x,a20,2x,i4,2x,g14.6,2x,g14.6)' ) & title, n, cond1, cond2 c c BIS c title = 'BIS' n = 5 r8_lo = -5.0D+00 r8_hi = +5.0D+00 seed = 123456789 alpha = r8_uniform_ab ( r8_lo, r8_hi, seed ) beta = r8_uniform_ab ( r8_lo, r8_hi, seed ) call bis_condition ( alpha, beta, n, cond1 ) call bis_matrix ( alpha, beta, n, n, a ); call bis_inverse ( alpha, beta, n, b ) a_norm = r8mat_norm_l1 ( n, n, a ) b_norm = r8mat_norm_l1 ( n, n, b ) cond2 = a_norm * b_norm write ( *, '(2x,a20,2x,i4,2x,g14.6,2x,g14.6)' ) & title, n, cond1, cond2 c c BIW c title = 'BIW' n = 5 call biw_condition ( n, cond1 ) call biw_matrix ( n, a ); call biw_inverse ( n, b ) a_norm = r8mat_norm_l1 ( n, n, a ) b_norm = r8mat_norm_l1 ( n, n, b ) cond2 = a_norm * b_norm write ( *, '(2x,a20,2x,i4,2x,g14.6,2x,g14.6)' ) & title, n, cond1, cond2 c c BODEWIG c title = 'BODEWIG' n = 4 call bodewig_condition ( cond1 ) call bodewig_matrix ( a ) call bodewig_inverse ( b ) a_norm = r8mat_norm_l1 ( n, n, a ) b_norm = r8mat_norm_l1 ( n, n, b ) cond2 = a_norm * b_norm write ( *, '(2x,a20,2x,i4,2x,g14.6,2x,g14.6)' ) & title, n, cond1, cond2 c c BOOTHROYD c title = 'BOOTHROYD' n = 5 call boothroyd_condition ( n, cond1 ) call boothroyd_matrix ( n, a ) call boothroyd_inverse ( n, b ) a_norm = r8mat_norm_l1 ( n, n, a ) b_norm = r8mat_norm_l1 ( n, n, b ) cond2 = a_norm * b_norm write ( *, '(2x,a20,2x,i4,2x,g14.6,2x,g14.6)' ) & title, n, cond1, cond2 c c COMBIN c title = 'COMBIN' n = 3 r8_lo = -5.0D+00 r8_hi = +5.0D+00 seed = 123456789 alpha = r8_uniform_ab ( r8_lo, r8_hi, seed ) beta = r8_uniform_ab ( r8_lo, r8_hi, seed ) call combin_condition ( alpha, beta, n, cond1 ) call combin_matrix ( alpha, beta, n, a ) call combin_inverse ( alpha, beta, n, b ) a_norm = r8mat_norm_l1 ( n, n, a ) b_norm = r8mat_norm_l1 ( n, n, b ) cond2 = a_norm * b_norm write ( *, '(2x,a20,2x,i4,2x,g14.6,2x,g14.6)' ) & title, n, cond1, cond2 c c COMPANION c title = 'COMPANION' n = 5 r8_lo = -5.0D+00 r8_hi = +5.0D+00 seed = 123456789 call r8vec_uniform_ab ( n, r8_lo, r8_hi, seed, x ) call companion_condition ( n, x, cond1 ) call companion_matrix ( n, x, a ) call companion_inverse ( n, x, b ) a_norm = r8mat_norm_l1 ( n, n, a ) b_norm = r8mat_norm_l1 ( n, n, b ) cond2 = a_norm * b_norm write ( *, '(2x,a20,2x,i4,2x,g14.6,2x,g14.6)' ) & title, n, cond1, cond2 c c CONEX1 c title = 'CONEX1' n = 4 r8_lo = -5.0D+00 r8_hi = +5.0D+00 seed = 123456789 alpha = r8_uniform_ab ( r8_lo, r8_hi, seed ) call conex1_condition ( alpha, cond1 ) call conex1_matrix ( alpha, a ) call conex1_inverse ( alpha, b ) a_norm = r8mat_norm_l1 ( n, n, a ) b_norm = r8mat_norm_l1 ( n, n, b ) cond2 = a_norm * b_norm write ( *, '(2x,a20,2x,i4,2x,g14.6,2x,g14.6)' ) & title, n, cond1, cond2 c c CONEX2 c title = 'CONEX2' n = 3 r8_lo = -5.0D+00 r8_hi = +5.0D+00 seed = 123456789 alpha = r8_uniform_ab ( r8_lo, r8_hi, seed ) call conex2_condition ( alpha, cond1 ) call conex2_matrix ( alpha, a ) call conex2_inverse ( alpha, b ) a_norm = r8mat_norm_l1 ( n, n, a ) b_norm = r8mat_norm_l1 ( n, n, b ) cond2 = a_norm * b_norm write ( *, '(2x,a20,2x,i4,2x,g14.6,2x,g14.6)' ) & title, n, cond1, cond2 c c CONEX3 c title = 'CONEX3' n = 5 call conex3_condition ( n, cond1 ) call conex3_matrix ( n, a ) call conex3_inverse ( n, b ) a_norm = r8mat_norm_l1 ( n, n, a ) b_norm = r8mat_norm_l1 ( n, n, b ) cond2 = a_norm * b_norm write ( *, '(2x,a20,2x,i4,2x,g14.6,2x,g14.6)' ) & title, n, cond1, cond2 c c CONEX4 c title = 'CONEX4' n = 4 call conex4_condition ( cond1 ) call conex4_matrix ( a ) call conex4_inverse ( b ) a_norm = r8mat_norm_l1 ( n, n, a ) b_norm = r8mat_norm_l1 ( n, n, b ) cond2 = a_norm * b_norm write ( *, '(2x,a20,2x,i4,2x,g14.6,2x,g14.6)' ) & title, n, cond1, cond2 c c DAUB2 c title = 'DAUB2' n = 4 call daub2_condition ( n, cond1 ) call daub2_matrix ( n, a ) call daub2_inverse ( n, b ) a_norm = r8mat_norm_l1 ( n, n, a ) b_norm = r8mat_norm_l1 ( n, n, b ) cond2 = a_norm * b_norm write ( *, '(2x,a20,2x,i4,2x,g14.6,2x,g14.6)' ) & title, n, cond1, cond2 c c DAUB4 c title = 'DAUB4' n = 8 call daub4_condition ( n, cond1 ) call daub4_matrix ( n, a ) call daub4_inverse ( n, b ) a_norm = r8mat_norm_l1 ( n, n, a ) b_norm = r8mat_norm_l1 ( n, n, b ) cond2 = a_norm * b_norm write ( *, '(2x,a20,2x,i4,2x,g14.6,2x,g14.6)' ) & title, n, cond1, cond2 c c DAUB6 c title = 'DAUB6' n = 12 call daub6_condition ( n, cond1 ) call daub6_matrix ( n, a ) call daub6_inverse ( n, b ) a_norm = r8mat_norm_l1 ( n, n, a ) b_norm = r8mat_norm_l1 ( n, n, b ) cond2 = a_norm * b_norm write ( *, '(2x,a20,2x,i4,2x,g14.6,2x,g14.6)' ) & title, n, cond1, cond2 c c DAUB8 c title = 'DAUB8' n = 16 call daub2_condition ( n, cond1 ) call daub8_matrix ( n, a ) call daub8_inverse ( n, b ) a_norm = r8mat_norm_l1 ( n, n, a ) b_norm = r8mat_norm_l1 ( n, n, b ) cond2 = a_norm * b_norm write ( *, '(2x,a20,2x,i4,2x,g14.6,2x,g14.6)' ) & title, n, cond1, cond2 c c DAUB10 c title = 'DAUB10' n = 20 call daub10_condition ( n, cond1 ) call daub10_matrix ( n, a ) call daub10_inverse ( n, b ) a_norm = r8mat_norm_l1 ( n, n, a ) b_norm = r8mat_norm_l1 ( n, n, b ) cond2 = a_norm * b_norm write ( *, '(2x,a20,2x,i4,2x,g14.6,2x,g14.6)' ) & title, n, cond1, cond2 c c DAUB12 c title = 'DAUB12' n = 24 call daub12_condition ( n, cond1 ) call daub12_matrix ( n, a ) call daub12_inverse ( n, b ) a_norm = r8mat_norm_l1 ( n, n, a ) b_norm = r8mat_norm_l1 ( n, n, b ) cond2 = a_norm * b_norm write ( *, '(2x,a20,2x,i4,2x,g14.6,2x,g14.6)' ) & title, n, cond1, cond2 c c DIAGONAL c title = 'DIAGONAL' n = 5 r8_lo = -5.0D+00 r8_hi = +5.0D+00 seed = 123456789 call r8vec_uniform_ab ( n, r8_lo, r8_hi, seed, x ) call diagonal_condition ( n, x, cond1 ) call diagonal_matrix ( n, n, x, a ) call diagonal_inverse ( n, x, b ) a_norm = r8mat_norm_l1 ( n, n, a ) b_norm = r8mat_norm_l1 ( n, n, b ) cond2 = a_norm * b_norm write ( *, '(2x,a20,2x,i4,2x,g14.6,2x,g14.6)' ) & title, n, cond1, cond2 c c DIF2 c title = 'DIF2' n = 5 call dif2_condition ( n, cond1 ) call dif2_matrix ( n, n, a ) call dif2_inverse ( n, b ) a_norm = r8mat_norm_l1 ( n, n, a ) b_norm = r8mat_norm_l1 ( n, n, b ) cond2 = a_norm * b_norm write ( *, '(2x,a20,2x,i4,2x,g14.6,2x,g14.6)' ) & title, n, cond1, cond2 c c DOWNSHIFT c title = 'DOWNSHIFT' n = 5 call downshift_condition ( n, cond1 ) call downshift_matrix ( n, a ) call downshift_inverse ( n, b ) a_norm = r8mat_norm_l1 ( n, n, a ) b_norm = r8mat_norm_l1 ( n, n, b ) cond2 = a_norm * b_norm write ( *, '(2x,a20,2x,i4,2x,g14.6,2x,g14.6)' ) & title, n, cond1, cond2 c c EXCHANGE c title = 'EXCHANGE' n = 5 call exchange_condition ( n, cond1 ) call exchange_matrix ( n, n, a ) call exchange_inverse ( n, b ) a_norm = r8mat_norm_l1 ( n, n, a ) b_norm = r8mat_norm_l1 ( n, n, b ) cond2 = a_norm * b_norm write ( *, '(2x,a20,2x,i4,2x,g14.6,2x,g14.6)' ) & title, n, cond1, cond2 c c FIBONACCI2 c title = 'FIBONACCI2' n = 5 call fibonacci2_condition ( n, cond1 ) call fibonacci2_matrix ( n, a ) call fibonacci2_inverse ( n, b ) a_norm = r8mat_norm_l1 ( n, n, a ) b_norm = r8mat_norm_l1 ( n, n, b ) cond2 = a_norm * b_norm write ( *, '(2x,a20,2x,i4,2x,g14.6,2x,g14.6)' ) & title, n, cond1, cond2 c c GFPP c title = 'GFPP' n = 5 r8_lo = -5.0D+00 r8_hi = +5.0D+00 seed = 123456789 alpha = r8_uniform_ab ( r8_lo, r8_hi, seed ) call gfpp_condition ( n, alpha, cond1 ) call gfpp_matrix ( n, alpha, a ) call gfpp_inverse ( n, alpha, b ) a_norm = r8mat_norm_l1 ( n, n, a ) b_norm = r8mat_norm_l1 ( n, n, b ) cond2 = a_norm * b_norm write ( *, '(2x,a20,2x,i4,2x,g14.6,2x,g14.6)' ) & title, n, cond1, cond2 c c GIVENS c title = 'GIVENS' n = 5 call givens_condition ( n, cond1 ) call givens_matrix ( n, n, a ) call givens_inverse ( n, b ) a_norm = r8mat_norm_l1 ( n, n, a ) b_norm = r8mat_norm_l1 ( n, n, b ) cond2 = a_norm * b_norm write ( *, '(2x,a20,2x,i4,2x,g14.6,2x,g14.6)' ) & title, n, cond1, cond2 c c HANKEL_N c title = 'HANKEL_N' n = 5 call hankel_n_condition ( n, cond1 ) call hankel_n_matrix ( n, a ) call hankel_n_inverse ( n, b ) a_norm = r8mat_norm_l1 ( n, n, a ) b_norm = r8mat_norm_l1 ( n, n, b ) cond2 = a_norm * b_norm write ( *, '(2x,a20,2x,i4,2x,g14.6,2x,g14.6)' ) & title, n, cond1, cond2 c c HARMAN c title = 'HARMAN' n = 8 call harman_condition ( cond1 ) call harman_matrix ( a ) call harman_inverse ( b ) a_norm = r8mat_norm_l1 ( n, n, a ) b_norm = r8mat_norm_l1 ( n, n, b ) cond2 = a_norm * b_norm write ( *, '(2x,a20,2x,i4,2x,g14.6,2x,g14.6)' ) & title, n, cond1, cond2 c c HARTLEY c title = 'HARTLEY' n = 5 call hartley_condition ( n, cond1 ) call hartley_matrix ( n, a ) call hartley_inverse ( n, b ) a_norm = r8mat_norm_l1 ( n, n, a ) b_norm = r8mat_norm_l1 ( n, n, b ) cond2 = a_norm * b_norm write ( *, '(2x,a20,2x,i4,2x,g14.6,2x,g14.6)' ) & title, n, cond1, cond2 c c IDENTITY c title = 'IDENTITY' n = 5 call identity_condition ( n, cond1 ) call identity_matrix ( n, n, a ) call identity_inverse ( n, b ) a_norm = r8mat_norm_l1 ( n, n, a ) b_norm = r8mat_norm_l1 ( n, n, b ) cond2 = a_norm * b_norm write ( *, '(2x,a20,2x,i4,2x,g14.6,2x,g14.6)' ) & title, n, cond1, cond2 c c ILL3 c title = 'ILL3' n = 3 call ill3_condition ( cond1 ) call ill3_matrix ( a ) call ill3_inverse ( b ) a_norm = r8mat_norm_l1 ( n, n, a ) b_norm = r8mat_norm_l1 ( n, n, b ) cond2 = a_norm * b_norm write ( *, '(2x,a20,2x,i4,2x,g14.6,2x,g14.6)' ) & title, n, cond1, cond2 c c JORDAN c title = 'JORDAN' n = 5 r8_lo = -5.0D+00 r8_hi = +5.0D+00 seed = 123456789 alpha = r8_uniform_ab ( r8_lo, r8_hi, seed ) call jordan_condition ( n, alpha, cond1 ) call jordan_matrix ( n, n, alpha, a ) call jordan_inverse ( n, alpha, b ) a_norm = r8mat_norm_l1 ( n, n, a ) b_norm = r8mat_norm_l1 ( n, n, b ) cond2 = a_norm * b_norm write ( *, '(2x,a20,2x,i4,2x,g14.6,2x,g14.6)' ) & title, n, cond1, cond2 c c KERSHAW c title = 'KERSHAW' n = 4 call kershaw_condition ( cond1 ) call kershaw_matrix ( a ) call kershaw_inverse ( b ) a_norm = r8mat_norm_l1 ( n, n, a ) b_norm = r8mat_norm_l1 ( n, n, b ) cond2 = a_norm * b_norm write ( *, '(2x,a20,2x,i4,2x,g14.6,2x,g14.6)' ) & title, n, cond1, cond2 c c LIETZKE c title = 'LIETZKE' n = 5 call lietzke_condition ( n, cond1 ) call lietzke_matrix ( n, a ) call lietzke_inverse ( n, b ) a_norm = r8mat_norm_l1 ( n, n, a ) b_norm = r8mat_norm_l1 ( n, n, b ) cond2 = a_norm * b_norm write ( *, '(2x,a20,2x,i4,2x,g14.6,2x,g14.6)' ) & title, n, cond1, cond2 c c MAXIJ c title = 'MAXIJ' n = 5 call maxij_condition ( n, cond1 ) call maxij_matrix ( n, n, a ) call maxij_inverse ( n, b ) a_norm = r8mat_norm_l1 ( n, n, a ) b_norm = r8mat_norm_l1 ( n, n, b ) cond2 = a_norm * b_norm write ( *, '(2x,a20,2x,i4,2x,g14.6,2x,g14.6)' ) & title, n, cond1, cond2 c c MINIJ c title = 'MINIJ' n = 5 call minij_condition ( n, cond1 ) call minij_matrix ( n, n, a ) call minij_inverse ( n, b ) a_norm = r8mat_norm_l1 ( n, n, a ) b_norm = r8mat_norm_l1 ( n, n, b ) cond2 = a_norm * b_norm write ( *, '(2x,a20,2x,i4,2x,g14.6,2x,g14.6)' ) & title, n, cond1, cond2 c c ORTH_SYMM c title = 'ORTH_SYMM' n = 5 call orth_symm_condition ( n, cond1 ) call orth_symm_matrix ( n, a ) call orth_symm_inverse ( n, b ) a_norm = r8mat_norm_l1 ( n, n, a ) b_norm = r8mat_norm_l1 ( n, n, b ) cond2 = a_norm * b_norm write ( *, '(2x,a20,2x,i4,2x,g14.6,2x,g14.6)' ) & title, n, cond1, cond2 c c OTO c title = 'OTO' n = 5 call oto_condition ( n, cond1 ) call oto_matrix ( n, n, a ) call oto_inverse ( n, b ) a_norm = r8mat_norm_l1 ( n, n, a ) b_norm = r8mat_norm_l1 ( n, n, b ) cond2 = a_norm * b_norm write ( *, '(2x,a20,2x,i4,2x,g14.6,2x,g14.6)' ) & title, n, cond1, cond2 c c PASCAL1 c title = 'PASCAL1' n = 5 call pascal1_condition ( n, cond1 ) call pascal1_matrix ( n, a ) call pascal1_inverse ( n, b ) a_norm = r8mat_norm_l1 ( n, n, a ) b_norm = r8mat_norm_l1 ( n, n, b ) cond2 = a_norm * b_norm write ( *, '(2x,a20,2x,i4,2x,g14.6,2x,g14.6)' ) & title, n, cond1, cond2 c c PASCAL3 c title = 'PASCAL3' n = 5 r8_lo = -5.0D+00 r8_hi = +5.0D+00 seed = 123456789 alpha = r8_uniform_ab ( r8_lo, r8_hi, seed ) call pascal3_condition ( n, alpha, cond1 ) call pascal3_matrix ( n, alpha, a ) call pascal3_inverse ( n, alpha, b ) a_norm = r8mat_norm_l1 ( n, n, a ) b_norm = r8mat_norm_l1 ( n, n, b ) cond2 = a_norm * b_norm write ( *, '(2x,a20,2x,i4,2x,g14.6,2x,g14.6)' ) & title, n, cond1, cond2 c c PEI c title = 'PEI' n = 5 r8_lo = -5.0D+00 r8_hi = +5.0D+00 seed = 123456789 alpha = r8_uniform_ab ( r8_lo, r8_hi, seed ) call pei_condition ( alpha, n, cond1 ) call pei_matrix ( alpha, n, a ) call pei_inverse ( alpha, n, b ) a_norm = r8mat_norm_l1 ( n, n, a ) b_norm = r8mat_norm_l1 ( n, n, b ) cond2 = a_norm * b_norm write ( *, '(2x,a20,2x,i4,2x,g14.6,2x,g14.6)' ) & title, n, cond1, cond2 c c RODMAN c title = 'RODMAN' n = 5 r8_lo = -5.0D+00 r8_hi = +5.0D+00 seed = 123456789 alpha = r8_uniform_ab ( r8_lo, r8_hi, seed ) call rodman_condition ( n, alpha, cond1 ) call rodman_matrix ( n, n, alpha, a ) call rodman_inverse ( n, alpha, b ) a_norm = r8mat_norm_l1 ( n, n, a ) b_norm = r8mat_norm_l1 ( n, n, b ) cond2 = a_norm * b_norm write ( *, '(2x,a20,2x,i4,2x,g14.6,2x,g14.6)' ) & title, n, cond1, cond2 c c RUTIS1 c title = 'RUTIS1' n = 4 call rutis1_condition ( cond1 ) call rutis1_matrix ( a ) call rutis1_inverse ( b ) a_norm = r8mat_norm_l1 ( n, n, a ) b_norm = r8mat_norm_l1 ( n, n, b ) cond2 = a_norm * b_norm write ( *, '(2x,a20,2x,i4,2x,g14.6,2x,g14.6)' ) & title, n, cond1, cond2 c c RUTIS2 c title = 'RUTIS2' n = 4 call rutis2_condition ( cond1 ) call rutis2_matrix ( a ) call rutis2_inverse ( b ) a_norm = r8mat_norm_l1 ( n, n, a ) b_norm = r8mat_norm_l1 ( n, n, b ) cond2 = a_norm * b_norm write ( *, '(2x,a20,2x,i4,2x,g14.6,2x,g14.6)' ) & title, n, cond1, cond2 c c RUTIS3 c title = 'RUTIS3' n = 4 call rutis3_condition ( cond1 ) call rutis3_matrix ( a ) call rutis3_inverse ( b ) a_norm = r8mat_norm_l1 ( n, n, a ) b_norm = r8mat_norm_l1 ( n, n, b ) cond2 = a_norm * b_norm write ( *, '(2x,a20,2x,i4,2x,g14.6,2x,g14.6)' ) & title, n, cond1, cond2 c c RUTIS5 c title = 'RUTIS5' n = 4 call rutis5_condition ( cond1 ) call rutis5_matrix ( a ) call rutis5_inverse ( b ) a_norm = r8mat_norm_l1 ( n, n, a ) b_norm = r8mat_norm_l1 ( n, n, b ) cond2 = a_norm * b_norm write ( *, '(2x,a20,2x,i4,2x,g14.6,2x,g14.6)' ) & title, n, cond1, cond2 c c SUMMATION c title = 'SUMMATION' n = 5 call summation_condition ( n, cond1 ) call summation_matrix ( n, n, a ) call summation_inverse ( n, b ) a_norm = r8mat_norm_l1 ( n, n, a ) b_norm = r8mat_norm_l1 ( n, n, b ) cond2 = a_norm * b_norm write ( *, '(2x,a20,2x,i4,2x,g14.6,2x,g14.6)' ) & title, n, cond1, cond2 c c SWEET1 c title = 'SWEET1' n = 6 call sweet1_condition ( cond1 ) call sweet1_matrix ( a ) call sweet1_inverse ( b ) a_norm = r8mat_norm_l1 ( n, n, a ) b_norm = r8mat_norm_l1 ( n, n, b ) cond2 = a_norm * b_norm write ( *, '(2x,a20,2x,i4,2x,g14.6,2x,g14.6)' ) & title, n, cond1, cond2 c c SWEET2 c title = 'SWEET2' n = 6 call sweet2_condition ( cond1 ) call sweet2_matrix ( a ) call sweet2_inverse ( b ) a_norm = r8mat_norm_l1 ( n, n, a ) b_norm = r8mat_norm_l1 ( n, n, b ) cond2 = a_norm * b_norm write ( *, '(2x,a20,2x,i4,2x,g14.6,2x,g14.6)' ) & title, n, cond1, cond2 c c SWEET3 c title = 'SWEET3' n = 6 call sweet3_condition ( cond1 ) call sweet3_matrix ( a ) call sweet3_inverse ( b ) a_norm = r8mat_norm_l1 ( n, n, a ) b_norm = r8mat_norm_l1 ( n, n, b ) cond2 = a_norm * b_norm write ( *, '(2x,a20,2x,i4,2x,g14.6,2x,g14.6)' ) & title, n, cond1, cond2 c c SWEET4 c title = 'SWEET4' n = 13 call sweet4_condition ( cond1 ) call sweet4_matrix ( a ) call sweet4_inverse ( b ) a_norm = r8mat_norm_l1 ( n, n, a ) b_norm = r8mat_norm_l1 ( n, n, b ) cond2 = a_norm * b_norm write ( *, '(2x,a20,2x,i4,2x,g14.6,2x,g14.6)' ) & title, n, cond1, cond2 c c TRI_UPPER c title = 'TRI_UPPER' n = 5 r8_lo = -5.0D+00 r8_hi = +5.0D+00 seed = 123456789 alpha = r8_uniform_ab ( r8_lo, r8_hi, seed ) call tri_upper_condition ( alpha, n, cond1 ) call tri_upper_matrix ( alpha, n, a ) call tri_upper_inverse ( alpha, n, b ) a_norm = r8mat_norm_l1 ( n, n, a ) b_norm = r8mat_norm_l1 ( n, n, b ) cond2 = a_norm * b_norm write ( *, '(2x,a20,2x,i4,2x,g14.6,2x,g14.6)' ) & title, n, cond1, cond2 c c UPSHIFT c title = 'UPSHIFT' n = 5 call upshift_condition ( n, cond1 ) call upshift_matrix ( n, a ) call upshift_inverse ( n, b ) a_norm = r8mat_norm_l1 ( n, n, a ) b_norm = r8mat_norm_l1 ( n, n, b ) cond2 = a_norm * b_norm write ( *, '(2x,a20,2x,i4,2x,g14.6,2x,g14.6)' ) & title, n, cond1, cond2 c c WILK03 c title = 'WILK03' n = 3 call wilk03_condition ( cond1 ) call wilk03_matrix ( a ) call wilk03_inverse ( b ) a_norm = r8mat_norm_l1 ( n, n, a ) b_norm = r8mat_norm_l1 ( n, n, b ) cond2 = a_norm * b_norm write ( *, '(2x,a20,2x,i4,2x,g14.6,2x,g14.6)' ) & title, n, cond1, cond2 c c WILK04 c title = 'WILK04' n = 4 call wilk04_condition ( cond1 ) call wilk04_matrix ( a ) call wilk04_inverse ( b ) a_norm = r8mat_norm_l1 ( n, n, a ) b_norm = r8mat_norm_l1 ( n, n, b ) cond2 = a_norm * b_norm write ( *, '(2x,a20,2x,i4,2x,g14.6,2x,g14.6)' ) & title, n, cond1, cond2 c c WILK05 c title = 'WILK05' n = 5 call wilk05_condition ( cond1 ) call wilk05_matrix ( a ) call wilk05_inverse ( b ) a_norm = r8mat_norm_l1 ( n, n, a ) b_norm = r8mat_norm_l1 ( n, n, b ) cond2 = a_norm * b_norm write ( *, '(2x,a20,2x,i4,2x,g14.6,2x,g14.6)' ) & title, n, cond1, cond2 c c WILSON c title = 'WILSON' n = 4 call wilson_condition ( cond1 ) call wilson_matrix ( a ) call wilson_inverse ( b ) a_norm = r8mat_norm_l1 ( n, n, a ) b_norm = r8mat_norm_l1 ( n, n, b ) cond2 = a_norm * b_norm write ( *, '(2x,a20,2x,i4,2x,g14.6,2x,g14.6)' ) & title, n, cond1, cond2 return end subroutine test_determinant ( ) c*********************************************************************72 c cc test_determinant() tests the determinant computations. c c Licensing: c c This code is distributed under the MIT license. c c Modified: c c 04 April 2024 c c Author: c c John Burkardt c implicit none integer n_max parameter ( n_max = 70 ) double precision a(n_max,n_max) double precision alpha double precision b double precision beta integer col_num double precision d(n_max) double precision d1 double precision d2 double precision d3 double precision d4 double precision d5 double precision da double precision determ1 double precision determ2 double precision di double precision gam integer i integer i4_hi integer i4_lo integer i4_uniform_ab integer ii integer jj integer k integer key integer m integer n double precision norm_frobenius integer pivot(n_max) double precision prob double precision r8_hi double precision r8_lo double precision r8_uniform_ab double precision r8mat_norm_fro double precision r8vec_sum integer rank integer row_num integer seed character*80 title double precision v1(n_max) double precision v2(n_max) double precision v3(n_max) double precision w(n_max) double precision x(2*n_max-1) integer x_n double precision y(n_max) integer y_n double precision y_sum double precision z(n_max) write ( *, '(a)' ) ' ' write ( *, '(a)' ) 'test_determinant()' write ( *, '(a)' ) & ' Compute the determinants of an example of each' write ( *, '(a)' ) & ' test matrix; compare with the determinant routine,' write ( *, '(a)' ) & ' if available. Print the matrix Frobenius norm' write ( *, '(a)' ) ' for an estimate of magnitude.' write ( *, '(a)' ) ' ' write ( *, '(a,a)' ) ' Title N ', & 'Determ Determ ||A||' write ( *, '(a)' ) ' ' c c A123 c title = 'A123' n = 3 call a123_matrix ( a ) call a123_determinant ( determ1 ) call r8mat_determinant ( n, a, determ2 ) norm_frobenius = r8mat_norm_fro ( n, n, a ) write ( *, '(2x,a20,2x,i4,2x,g14.6,2x,g14.6,2x,g14.6)' ) & title, n, determ1, determ2, norm_frobenius c c AEGERTER c title = 'AEGERTER' n = 5 call aegerter_matrix ( n, a ) call aegerter_determinant ( n, determ1 ) call r8mat_determinant ( n, a, determ2 ) norm_frobenius = r8mat_norm_fro ( n, n, a ) write ( *, '(2x,a20,2x,i4,2x,g14.6,2x,g14.6,2x,g14.6)' ) & title, n, determ1, determ2, norm_frobenius c c ANTICIRCULANT c title = 'ANTICIRCULANT' n = 3 r8_lo = -5.0D+00 r8_hi = +5.0D+00 seed = 123456789 call r8vec_uniform_ab ( n, r8_lo, r8_hi, seed, x ) call anticirculant_matrix ( n, n, x, a ) call anticirculant_determinant ( n, x, determ1 ) call r8mat_determinant ( n, a, determ2 ) norm_frobenius = r8mat_norm_fro ( n, n, a ) write ( *, '(2x,a20,2x,i4,2x,g14.6,2x,g14.6,2x,g14.6)' ) & title, n, determ1, determ2, norm_frobenius c c ANTICIRCULANT c title = 'ANTICIRCULANT' n = 4 r8_lo = -5.0D+00 r8_hi = +5.0D+00 seed = 123456789 call r8vec_uniform_ab ( n, r8_lo, r8_hi, seed, x ) call anticirculant_matrix ( n, n, x, a ) call anticirculant_determinant ( n, x, determ1 ) call r8mat_determinant ( n, a, determ2 ) norm_frobenius = r8mat_norm_fro ( n, n, a ) write ( *, '(2x,a20,2x,i4,2x,g14.6,2x,g14.6,2x,g14.6)' ) & title, n, determ1, determ2, norm_frobenius c c ANTICIRCULANT c title = 'ANTICIRCULANT' n = 5 r8_lo = -5.0D+00 r8_hi = +5.0D+00 seed = 123456789 call r8vec_uniform_ab ( n, r8_lo, r8_hi, seed, x ) call anticirculant_matrix ( n, n, x, a ) call anticirculant_determinant ( n, x, determ1 ) call r8mat_determinant ( n, a, determ2 ) norm_frobenius = r8mat_norm_fro ( n, n, a ) write ( *, '(2x,a20,2x,i4,2x,g14.6,2x,g14.6,2x,g14.6)' ) & title, n, determ1, determ2, norm_frobenius c c ANTIHADAMARD c title = 'ANTIHADAMARD' n = 5 call antihadamard_matrix ( n, a ) call antihadamard_determinant ( n, determ1 ) call r8mat_determinant ( n, a, determ2 ) norm_frobenius = r8mat_norm_fro ( n, n, a ) write ( *, '(2x,a20,2x,i4,2x,g14.6,2x,g14.6,2x,g14.6)' ) & title, n, determ1, determ2, norm_frobenius c c ANTISYMM_RANDOM c title = 'ANTISYMM_RANDOM' n = 5 key = 123456789 call antisymm_random_matrix ( n, key, a ) call r8mat_determinant ( n, a, determ2 ) norm_frobenius = r8mat_norm_fro ( n, n, a ) write ( *, '(2x,a20,2x,i4,2x,14x,2x,g14.6,2x,g14.6)' ) & title, n, determ2, norm_frobenius c c ANTISYMM_RANDOM c title = 'ANTISYMM_RANDOM' n = 6 key = 123456789 call antisymm_random_matrix ( n, key, a ) call r8mat_determinant ( n, a, determ2 ) norm_frobenius = r8mat_norm_fro ( n, n, a ) write ( *, '(2x,a20,2x,i4,2x,14x,2x,g14.6,2x,g14.6)' ) & title, n, determ2, norm_frobenius c c BAB c title = 'BAB' n = 5 r8_lo = -5.0D+00 r8_hi = +5.0D+00 seed = 123456789 alpha = r8_uniform_ab ( r8_lo, r8_hi, seed ) beta = r8_uniform_ab ( r8_lo, r8_hi, seed ) call bab_matrix ( n, alpha, beta, a ) call bab_determinant ( n, alpha, beta, determ1 ) call r8mat_determinant ( n, a, determ2 ) norm_frobenius = r8mat_norm_fro ( n, n, a ) write ( *, '(2x,a20,2x,i4,2x,g14.6,2x,g14.6,2x,g14.6)' ) & title, n, determ1, determ2, norm_frobenius c c BAUER c title = 'BAUER' n = 6 call bauer_matrix ( a ) call bauer_determinant ( determ1 ) call r8mat_determinant ( n, a, determ2 ) norm_frobenius = r8mat_norm_fro ( n, n, a ) write ( *, '(2x,a20,2x,i4,2x,g14.6,2x,g14.6,2x,g14.6)' ) & title, n, determ1, determ2, norm_frobenius c c BERNSTEIN c title = 'BERNSTEIN' n = 5 call bernstein_matrix ( n, a ) call bernstein_determinant ( n, determ1 ) call r8mat_determinant ( n, a, determ2 ) norm_frobenius = r8mat_norm_fro ( n, n, a ) write ( *, '(2x,a20,2x,i4,2x,g14.6,2x,g14.6,2x,g14.6)' ) & title, n, determ1, determ2, norm_frobenius c c BIMARKOV_RANDOM c title = 'BIMARKOV_RANDOM' n = 5 key = 123456789 call bimarkov_random_matrix ( n, key, a ) call r8mat_determinant ( n, a, determ2 ) norm_frobenius = r8mat_norm_fro ( n, n, a ) write ( *, '(2x,a20,2x,i4,2x,14x,2x,g14.6,2x,g14.6)' ) & title, n, determ2, norm_frobenius c c BIS c title = 'BIS' n = 5 r8_lo = -5.0D+00 r8_hi = +5.0D+00 seed = 123456789 alpha = r8_uniform_ab ( r8_lo, r8_hi, seed ) beta = r8_uniform_ab ( r8_lo, r8_hi, seed ) call bis_matrix ( alpha, beta, n, n, a ) call bis_determinant ( alpha, beta, n, determ1 ) call r8mat_determinant ( n, a, determ2 ) norm_frobenius = r8mat_norm_fro ( n, n, a ) write ( *, '(2x,a20,2x,i4,2x,g14.6,2x,g14.6,2x,g14.6)' ) & title, n, determ1, determ2, norm_frobenius c c BIW c title = 'BIW' n = 5 call biw_matrix ( n, a ) call biw_determinant ( n, determ1 ) call r8mat_determinant ( n, a, determ2 ) norm_frobenius = r8mat_norm_fro ( n, n, a ) write ( *, '(2x,a20,2x,i4,2x,g14.6,2x,g14.6,2x,g14.6)' ) & title, n, determ1, determ2, norm_frobenius c c BODEWIG c title = 'BODEWIG' n = 4 call bodewig_matrix ( a ) call bodewig_determinant ( determ1 ) call r8mat_determinant ( n, a, determ2 ) norm_frobenius = r8mat_norm_fro ( n, n, a ) write ( *, '(2x,a20,2x,i4,2x,g14.6,2x,g14.6,2x,g14.6)' ) & title, n, determ1, determ2, norm_frobenius c c BOOTHROYD c title = 'BOOTHROYD' n = 5 call boothroyd_matrix ( n, a ) call boothroyd_determinant ( n, determ1 ) call r8mat_determinant ( n, a, determ2 ) norm_frobenius = r8mat_norm_fro ( n, n, a ) write ( *, '(2x,a20,2x,i4,2x,g14.6,2x,g14.6,2x,g14.6)' ) & title, n, determ1, determ2, norm_frobenius c c BORDERBAND c title = 'BORDERBAND' n = 5 call borderband_matrix ( n, a ) call borderband_determinant ( n, determ1 ) call r8mat_determinant ( n, a, determ2 ) norm_frobenius = r8mat_norm_fro ( n, n, a ) write ( *, '(2x,a20,2x,i4,2x,g14.6,2x,g14.6,2x,g14.6)' ) & title, n, determ1, determ2, norm_frobenius c c CARRY c title = 'CARRY' n = 5 i4_lo = 2 i4_hi = 20 seed = 123456789 k = i4_uniform_ab ( i4_lo, i4_hi, seed ) call carry_matrix ( n, k, a ) call carry_determinant ( n, k, determ1 ) call r8mat_determinant ( n, a, determ2 ) norm_frobenius = r8mat_norm_fro ( n, n, a ) write ( *, '(2x,a20,2x,i4,2x,g14.6,2x,g14.6,2x,g14.6)' ) & title, n, determ1, determ2, norm_frobenius c c CAUCHY c title = 'CAUCHY' n = 5 r8_lo = -5.0D+00 r8_hi = +5.0D+00 seed = 123456789 call r8vec_uniform_ab ( n, r8_lo, r8_hi, seed, x ) call r8vec_uniform_ab ( n, r8_lo, r8_hi, seed, y ) call cauchy_matrix ( n, x, y, a ) call cauchy_determinant ( n, x, y, determ1 ) call r8mat_determinant ( n, a, determ2 ) norm_frobenius = r8mat_norm_fro ( n, n, a ) write ( *, '(2x,a20,2x,i4,2x,g14.6,2x,g14.6,2x,g14.6)' ) & title, n, determ1, determ2, norm_frobenius c c CHEBY_DIFF1 c title = 'CHEBY_DIFF1' n = 5 call cheby_diff1_matrix ( n, a ) call r8mat_determinant ( n, a, determ2 ) norm_frobenius = r8mat_norm_fro ( n, n, a ) write ( *, '(2x,a20,2x,i4,2x,14x,2x,g14.6,2x,g14.6)' ) & title, n, determ2, norm_frobenius c c CHEBY_DIFF1 c title = 'CHEBY_DIFF1' n = 6 call cheby_diff1_matrix ( n, a ) call r8mat_determinant ( n, a, determ2 ) norm_frobenius = r8mat_norm_fro ( n, n, a ) write ( *, '(2x,a20,2x,i4,2x,14x,2x,g14.6,2x,g14.6)' ) & title, n, determ2, norm_frobenius c c CHEBY_T c title = 'CHEBY_T' n = 5 call cheby_t_matrix ( n, a ) call cheby_t_determinant ( n, determ1 ) call r8mat_determinant ( n, a, determ2 ) norm_frobenius = r8mat_norm_fro ( n, n, a ) write ( *, '(2x,a20,2x,i4,2x,g14.6,2x,g14.6,2x,g14.6)' ) & title, n, determ1, determ2, norm_frobenius c c CHEBY_U c title = 'CHEBY_U' n = 5 call cheby_u_matrix ( n, a ) call cheby_u_determinant ( n, determ1 ) call r8mat_determinant ( n, a, determ2 ) norm_frobenius = r8mat_norm_fro ( n, n, a ) write ( *, '(2x,a20,2x,i4,2x,g14.6,2x,g14.6,2x,g14.6)' ) & title, n, determ1, determ2, norm_frobenius c c CHEBY_VAN1 c title = 'CHEBY_VAN1' n = 5 r8_lo = -5.0D+00 r8_hi = +5.0D+00 call r8vec_linspace ( n, r8_lo, r8_hi, x ) call cheby_van1_matrix ( n, r8_lo, r8_hi, n, x, a ) call r8mat_determinant ( n, a, determ2 ) norm_frobenius = r8mat_norm_fro ( n, n, a ) write ( *, '(2x,a20,2x,i4,2x,14x,2x,g14.6,2x,g14.6)' ) & title, n, determ2, norm_frobenius c c CHEBY_VAN2 c do n = 2, 10 title = 'CHEBY_VAN2' call cheby_van2_matrix ( n, a ) call cheby_van2_determinant ( n, determ1 ) call r8mat_determinant ( n, a, determ2 ) norm_frobenius = r8mat_norm_fro ( n, n, a ) write ( *, '(2x,a20,2x,i4,2x,g14.6,2x,g14.6,2x,g14.6)' ) & title, n, determ1, determ2, norm_frobenius end do c c CHEBY_VAN3 c title = 'CHEBY_VAN3' n = 5 call cheby_van3_matrix ( n, a ) call cheby_van3_determinant ( n, determ1 ) call r8mat_determinant ( n, a, determ2 ) norm_frobenius = r8mat_norm_fro ( n, n, a ) write ( *, '(2x,a20,2x,i4,2x,g14.6,2x,g14.6,2x,g14.6)' ) & title, n, determ1, determ2, norm_frobenius c c CHOW c title = 'CHOW' n = 5 r8_lo = -5.0D+00 r8_hi = +5.0D+00 seed = 123456789 alpha = r8_uniform_ab ( r8_lo, r8_hi, seed ) beta = r8_uniform_ab ( r8_lo, r8_hi, seed ) call chow_matrix ( alpha, beta, n, n, a ) call chow_determinant ( alpha, beta, n, determ1 ) call r8mat_determinant ( n, a, determ2 ) norm_frobenius = r8mat_norm_fro ( n, n, a ) write ( *, '(2x,a20,2x,i4,2x,g14.6,2x,g14.6,2x,g14.6)' ) & title, n, determ1, determ2, norm_frobenius c c CIRCULANT c title = 'CIRCULANT' n = 5 r8_lo = -5.0D+00 r8_hi = +5.0D+00 seed = 123456789; call r8vec_uniform_ab ( n, r8_lo, r8_hi, seed, x ) call circulant_matrix ( n, n, x, a ) call circulant_determinant ( n, x, determ1 ) call r8mat_determinant ( n, a, determ2 ) norm_frobenius = r8mat_norm_fro ( n, n, a ) write ( *, '(2x,a20,2x,i4,2x,g14.6,2x,g14.6,2x,g14.6)' ) & title, n, determ1, determ2, norm_frobenius c c CIRCULANT2 c title = 'CIRCULANT2' n = 3 call circulant2_matrix ( n, a ) call circulant2_determinant ( n, determ1 ) call r8mat_determinant ( n, a, determ2 ) norm_frobenius = r8mat_norm_fro ( n, n, a ) write ( *, '(2x,a20,2x,i4,2x,g14.6,2x,g14.6,2x,g14.6)' ) & title, n, determ1, determ2, norm_frobenius c c CIRCULANT2 c title = 'CIRCULANT2' n = 4 call circulant2_matrix ( n, a ) call circulant2_determinant ( n, determ1 ) call r8mat_determinant ( n, a, determ2 ) norm_frobenius = r8mat_norm_fro ( n, n, a ) write ( *, '(2x,a20,2x,i4,2x,g14.6,2x,g14.6,2x,g14.6)' ) & title, n, determ1, determ2, norm_frobenius c c CIRCULANT2 c title = 'CIRCULANT2' n = 5 call circulant2_matrix ( n, a ) call circulant2_determinant ( n, determ1 ) call r8mat_determinant ( n, a, determ2 ) norm_frobenius = r8mat_norm_fro ( n, n, a ) write ( *, '(2x,a20,2x,i4,2x,g14.6,2x,g14.6,2x,g14.6)' ) & title, n, determ1, determ2, norm_frobenius c c CLEMENT1 c title = 'CLEMENT1' n = 5 call clement1_matrix ( n, a ) call clement1_determinant ( n, determ1 ) call r8mat_determinant ( n, a, determ2 ) norm_frobenius = r8mat_norm_fro ( n, n, a ) write ( *, '(2x,a20,2x,i4,2x,g14.6,2x,g14.6,2x,g14.6)' ) & title, n, determ1, determ2, norm_frobenius c c CLEMENT1 c title = 'CLEMENT1' n = 6 call clement1_matrix ( n, a ) call clement1_determinant ( n, determ1 ) call r8mat_determinant ( n, a, determ2 ) norm_frobenius = r8mat_norm_fro ( n, n, a ) write ( *, '(2x,a20,2x,i4,2x,g14.6,2x,g14.6,2x,g14.6)' ) & title, n, determ1, determ2, norm_frobenius c c CLEMENT2 c title = 'CLEMENT2' n = 5 r8_lo = -5.0D+00 r8_hi = +5.0D+00 seed = 123456789 call r8vec_uniform_ab ( n - 1, r8_lo, r8_hi, seed, x ) call r8vec_uniform_ab ( n - 1, r8_lo, r8_hi, seed, y ) call clement2_matrix ( n, x, y, a ) call clement2_determinant ( n, x, y, determ1 ) call r8mat_determinant ( n, a, determ2 ) norm_frobenius = r8mat_norm_fro ( n, n, a ) write ( *, '(2x,a20,2x,i4,2x,g14.6,2x,g14.6,2x,g14.6)' ) & title, n, determ1, determ2, norm_frobenius c c CLEMENT2 c title = 'CLEMENT2' n = 6 r8_lo = -5.0D+00 r8_hi = +5.0D+00 seed = 123456789 call r8vec_uniform_ab ( n - 1, r8_lo, r8_hi, seed, x ) call r8vec_uniform_ab ( n - 1, r8_lo, r8_hi, seed, y ) call clement2_matrix ( n, x, y, a ) call clement2_determinant ( n, x, y, determ1 ) call r8mat_determinant ( n, a, determ2 ) norm_frobenius = r8mat_norm_fro ( n, n, a ) write ( *, '(2x,a20,2x,i4,2x,g14.6,2x,g14.6,2x,g14.6)' ) & title, n, determ1, determ2, norm_frobenius c c COMBIN c title = 'COMBIN' n = 5 r8_lo = -5.0D+00 r8_hi = +5.0D+00 seed = 123456789 alpha = r8_uniform_ab ( r8_lo, r8_hi, seed ) beta = r8_uniform_ab ( r8_lo, r8_hi, seed ) call combin_matrix ( alpha, beta, n, a ) call combin_determinant ( alpha, beta, n, determ1 ) call r8mat_determinant ( n, a, determ2 ) norm_frobenius = r8mat_norm_fro ( n, n, a ) write ( *, '(2x,a20,2x,i4,2x,g14.6,2x,g14.6,2x,g14.6)' ) & title, n, determ1, determ2, norm_frobenius c c COMPANION c title = 'COMPANION' n = 5 r8_lo = -5.0D+00 r8_hi = +5.0D+00 seed = 123456789 call r8vec_uniform_ab ( n, r8_lo, r8_hi, seed, x ) call companion_matrix ( n, x, a ) call companion_determinant ( n, x, determ1 ) call r8mat_determinant ( n, a, determ2 ) norm_frobenius = r8mat_norm_fro ( n, n, a ) write ( *, '(2x,a20,2x,i4,2x,g14.6,2x,g14.6,2x,g14.6)' ) & title, n, determ1, determ2, norm_frobenius c c COMPLEX_I c title = 'COMPLEX_I' n = 2 call complex_i_matrix ( a ) call complex_i_determinant ( determ1 ) call r8mat_determinant ( n, a, determ2 ) norm_frobenius = r8mat_norm_fro ( n, n, a ) write ( *, '(2x,a20,2x,i4,2x,g14.6,2x,g14.6,2x,g14.6)' ) & title, n, determ1, determ2, norm_frobenius c c CONEX1 c title = 'CONEX1' n = 4 r8_lo = -5.0D+00 r8_hi = +5.0D+00 seed = 123456789 alpha = r8_uniform_ab ( r8_lo, r8_hi, seed ) call conex1_matrix ( alpha, a ) call conex1_determinant ( alpha, determ1 ) call r8mat_determinant ( n, a, determ2 ) norm_frobenius = r8mat_norm_fro ( n, n, a ) write ( *, '(2x,a20,2x,i4,2x,g14.6,2x,g14.6,2x,g14.6)' ) & title, n, determ1, determ2, norm_frobenius c c CONEX2 c title = 'CONEX2' n = 3 r8_lo = -5.0D+00 r8_hi = +5.0D+00 seed = 123456789 alpha = r8_uniform_ab ( r8_lo, r8_hi, seed ) call conex2_matrix ( alpha, a ) call conex2_determinant ( alpha, determ1 ) call r8mat_determinant ( n, a, determ2 ) norm_frobenius = r8mat_norm_fro ( n, n, a ) write ( *, '(2x,a20,2x,i4,2x,g14.6,2x,g14.6,2x,g14.6)' ) & title, n, determ1, determ2, norm_frobenius c c CONEX3 c title = 'CONEX3' n = 5 call conex3_matrix ( n, a ) call conex3_determinant ( n, determ1 ) call r8mat_determinant ( n, a, determ2 ) norm_frobenius = r8mat_norm_fro ( n, n, a ) write ( *, '(2x,a20,2x,i4,2x,g14.6,2x,g14.6,2x,g14.6)' ) & title, n, determ1, determ2, norm_frobenius c c CONEX4 c title = 'CONEX4' n = 4 call conex4_matrix ( a ) call conex4_determinant ( determ1 ) call r8mat_determinant ( n, a, determ2 ) norm_frobenius = r8mat_norm_fro ( n, n, a ) write ( *, '(2x,a20,2x,i4,2x,g14.6,2x,g14.6,2x,g14.6)' ) & title, n, determ1, determ2, norm_frobenius c c CONFERENCE c title = 'CONFERENCE' n = 6 call conference_matrix ( n, a ) call conference_determinant ( n, determ1 ) call r8mat_determinant ( n, a, determ2 ) norm_frobenius = r8mat_norm_fro ( n, n, a ) write ( *, '(2x,a20,2x,i4,2x,g14.6,2x,g14.6,2x,g14.6)' ) & title, n, determ1, determ2, norm_frobenius c c CREATION c title = 'CREATION' n = 5 call creation_matrix ( n, n, a ) call creation_determinant ( n, determ1 ) call r8mat_determinant ( n, a, determ2 ) norm_frobenius = r8mat_norm_fro ( n, n, a ) write ( *, '(2x,a20,2x,i4,2x,g14.6,2x,g14.6,2x,g14.6)' ) & title, n, determ1, determ2, norm_frobenius c c DAUB2 c title = 'DAUB2' n = 4 call daub2_matrix ( n, a ) call daub2_determinant ( n, determ1 ) call r8mat_determinant ( n, a, determ2 ) norm_frobenius = r8mat_norm_fro ( n, n, a ) write ( *, '(2x,a20,2x,i4,2x,g14.6,2x,g14.6,2x,g14.6)' ) & title, n, determ1, determ2, norm_frobenius c c DAUB4 c title = 'DAUB4' n = 8 call daub4_matrix ( n, a ) call daub4_determinant ( n, determ1 ) call r8mat_determinant ( n, a, determ2 ) norm_frobenius = r8mat_norm_fro ( n, n, a ) write ( *, '(2x,a20,2x,i4,2x,g14.6,2x,g14.6,2x,g14.6)' ) & title, n, determ1, determ2, norm_frobenius c c DAUB6 c title = 'DAUB6' n = 12 call daub6_matrix ( n, a ) call daub6_determinant ( n, determ1 ) call r8mat_determinant ( n, a, determ2 ) norm_frobenius = r8mat_norm_fro ( n, n, a ) write ( *, '(2x,a20,2x,i4,2x,g14.6,2x,g14.6,2x,g14.6)' ) & title, n, determ1, determ2, norm_frobenius c c DAUB8 c title = 'DAUB8' n = 16 call daub8_matrix ( n, a ) call daub8_determinant ( n, determ1 ) call r8mat_determinant ( n, a, determ2 ) norm_frobenius = r8mat_norm_fro ( n, n, a ) write ( *, '(2x,a20,2x,i4,2x,g14.6,2x,g14.6,2x,g14.6)' ) & title, n, determ1, determ2, norm_frobenius c c DAUB10 c title = 'DAUB10' n = 20 call daub10_matrix ( n, a ) call daub10_determinant ( n, determ1 ) call r8mat_determinant ( n, a, determ2 ) norm_frobenius = r8mat_norm_fro ( n, n, a ) write ( *, '(2x,a20,2x,i4,2x,g14.6,2x,g14.6,2x,g14.6)' ) & title, n, determ1, determ2, norm_frobenius c c DAUB12 c title = 'DAUB12' n = 24 call daub12_matrix ( n, a ) call daub12_determinant ( n, determ1 ) call r8mat_determinant ( n, a, determ2 ) norm_frobenius = r8mat_norm_fro ( n, n, a ) write ( *, '(2x,a20,2x,i4,2x,g14.6,2x,g14.6,2x,g14.6)' ) & title, n, determ1, determ2, norm_frobenius c c DIAGONAL c title = 'DIAGONAL' n = 5 r8_lo = -5.0D+00 r8_hi = +5.0D+00 seed = 123456789 call r8vec_uniform_ab ( n, r8_lo, r8_hi, seed, x ) call diagonal_matrix ( n, n, x, a ) call diagonal_determinant ( n, x, determ1 ) call r8mat_determinant ( n, a, determ2 ) norm_frobenius = r8mat_norm_fro ( n, n, a ) write ( *, '(2x,a20,2x,i4,2x,g14.6,2x,g14.6,2x,g14.6)' ) & title, n, determ1, determ2, norm_frobenius c c DIF1 c title = 'DIF1' n = 5 call dif1_matrix ( n, n, a ) call dif1_determinant ( n, determ1 ) call r8mat_determinant ( n, a, determ2 ) norm_frobenius = r8mat_norm_fro ( n, n, a ) write ( *, '(2x,a20,2x,i4,2x,g14.6,2x,g14.6,2x,g14.6)' ) & title, n, determ1, determ2, norm_frobenius c c DIF1 c title = 'DIF1' n = 6 call dif1_matrix ( n, n, a ) call dif1_determinant ( n, determ1 ) call r8mat_determinant ( n, a, determ2 ) norm_frobenius = r8mat_norm_fro ( n, n, a ) write ( *, '(2x,a20,2x,i4,2x,g14.6,2x,g14.6,2x,g14.6)' ) & title, n, determ1, determ2, norm_frobenius c c DIF1CYCLIC c title = 'DIF1CYCLIC' n = 5 call dif1cyclic_matrix ( n, a ) call dif1cyclic_determinant ( n, determ1 ) call r8mat_determinant ( n, a, determ2 ) norm_frobenius = r8mat_norm_fro ( n, n, a ) write ( *, '(2x,a20,2x,i4,2x,g14.6,2x,g14.6,2x,g14.6)' ) & title, n, determ1, determ2, norm_frobenius c c DIF2 c title = 'DIF2' n = 5 call dif2_matrix ( n, n, a ) call dif2_determinant ( n, determ1 ) call r8mat_determinant ( n, a, determ2 ) norm_frobenius = r8mat_norm_fro ( n, n, a ) write ( *, '(2x,a20,2x,i4,2x,g14.6,2x,g14.6,2x,g14.6)' ) & title, n, determ1, determ2, norm_frobenius c c DIF2CYCLIC c title = 'DIF2CYCLIC' n = 5 call dif2cyclic_matrix ( n, a ) call dif2cyclic_determinant ( n, determ1 ) call r8mat_determinant ( n, a, determ2 ) norm_frobenius = r8mat_norm_fro ( n, n, a ) write ( *, '(2x,a20,2x,i4,2x,g14.6,2x,g14.6,2x,g14.6)' ) & title, n, determ1, determ2, norm_frobenius c c DORR c title = 'DORR' n = 5 r8_lo = -5.0D+00 r8_hi = +5.0D+00 seed = 123456789 alpha = r8_uniform_ab ( r8_lo, r8_hi, seed ) call dorr_matrix ( alpha, n, a ) call dorr_determinant ( alpha, n, determ1 ) call r8mat_determinant ( n, a, determ2 ) norm_frobenius = r8mat_norm_fro ( n, n, a ) write ( *, '(2x,a20,2x,i4,2x,g14.6,2x,g14.6,2x,g14.6)' ) & title, n, determ1, determ2, norm_frobenius c c DOWNSHIFT c title = 'DOWNSHIFT' n = 5 call downshift_matrix ( n, a ) call downshift_determinant ( n, determ1 ) call r8mat_determinant ( n, a, determ2 ) norm_frobenius = r8mat_norm_fro ( n, n, a ) write ( *, '(2x,a20,2x,i4,2x,g14.6,2x,g14.6,2x,g14.6)' ) & title, n, determ1, determ2, norm_frobenius c c EBERLEIN c title = 'EBERLEIN' n = 5 r8_lo = -5.0D+00 r8_hi = +5.0D+00 seed = 123456789 alpha = r8_uniform_ab ( r8_lo, r8_hi, seed ) call eberlein_matrix ( alpha, n, a ) call eberlein_determinant ( alpha, n, determ1 ) call r8mat_determinant ( n, a, determ2 ) norm_frobenius = r8mat_norm_fro ( n, n, a ) write ( *, '(2x,a20,2x,i4,2x,g14.6,2x,g14.6,2x,g14.6)' ) & title, n, determ1, determ2, norm_frobenius c c EULERIAN c title = 'EULERIAN' n = 5 call eulerian_matrix ( n, n, a ) call eulerian_determinant ( n, determ1 ) call r8mat_determinant ( n, a, determ2 ) norm_frobenius = r8mat_norm_fro ( n, n, a ) write ( *, '(2x,a20,2x,i4,2x,g14.6,2x,g14.6,2x,g14.6)' ) & title, n, determ1, determ2, norm_frobenius c c EXCHANGE c title = 'EXCHANGE' n = 5 call exchange_matrix ( n, n, a ) call exchange_determinant ( n, determ1 ) call r8mat_determinant ( n, a, determ2 ) norm_frobenius = r8mat_norm_fro ( n, n, a ) write ( *, '(2x,a20,2x,i4,2x,g14.6,2x,g14.6,2x,g14.6)' ) & title, n, determ1, determ2, norm_frobenius c c FIBONACCI1 c title = 'FIBONACCI1' n = 5 r8_lo = -5.0D+00 r8_hi = +5.0D+00 seed = 123456789 alpha = r8_uniform_ab ( r8_lo, r8_hi, seed ) beta = r8_uniform_ab ( r8_lo, r8_hi, seed ) call fibonacci1_matrix ( n, alpha, beta, a ) call fibonacci1_determinant ( n, alpha, beta, determ1 ) call r8mat_determinant ( n, a, determ2 ) norm_frobenius = r8mat_norm_fro ( n, n, a ) write ( *, '(2x,a20,2x,i4,2x,g14.6,2x,g14.6,2x,g14.6)' ) & title, n, determ1, determ2, norm_frobenius c c FIBONACCI2 c title = 'FIBONACCI2' n = 5 call fibonacci2_matrix ( n, a ) call fibonacci2_determinant ( n, determ1 ) call r8mat_determinant ( n, a, determ2 ) norm_frobenius = r8mat_norm_fro ( n, n, a ) write ( *, '(2x,a20,2x,i4,2x,g14.6,2x,g14.6,2x,g14.6)' ) & title, n, determ1, determ2, norm_frobenius c c FIBONACCI3 c title = 'FIBONACCI3' n = 5 call fibonacci3_matrix ( n, a ) call fibonacci3_determinant ( n, determ1 ) call r8mat_determinant ( n, a, determ2 ) norm_frobenius = r8mat_norm_fro ( n, n, a ) write ( *, '(2x,a20,2x,i4,2x,g14.6,2x,g14.6,2x,g14.6)' ) & title, n, determ1, determ2, norm_frobenius c c FIEDLER c title = 'FIEDLER' n = 7 r8_lo = -5.0D+00 r8_hi = +5.0D+00 seed = 123456789 call r8vec_uniform_ab ( n, r8_lo, r8_hi, seed, x ) call fiedler_matrix ( n, n, x, a ) call fiedler_determinant ( n, x, determ1 ) call r8mat_determinant ( n, a, determ2 ) norm_frobenius = r8mat_norm_fro ( n, n, a ) write ( *, '(2x,a20,2x,i4,2x,g14.6,2x,g14.6,2x,g14.6)' ) & title, n, determ1, determ2, norm_frobenius c c FORSYTHE c title = 'FORSYTHE' n = 5 r8_lo = -5.0D+00 r8_hi = +5.0D+00 seed = 123456789 alpha = r8_uniform_ab ( r8_lo, r8_hi, seed ) beta = r8_uniform_ab ( r8_lo, r8_hi, seed ) call forsythe_matrix ( alpha, beta, n, a ) call forsythe_determinant ( alpha, beta, n, determ1 ) call r8mat_determinant ( n, a, determ2 ) norm_frobenius = r8mat_norm_fro ( n, n, a ) write ( *, '(2x,a20,2x,i4,2x,g14.6,2x,g14.6,2x,g14.6)' ) & title, n, determ1, determ2, norm_frobenius c c FORSYTHE c title = 'FORSYTHE' n = 6 r8_lo = -5.0D+00 r8_hi = +5.0D+00 seed = 123456789 alpha = r8_uniform_ab ( r8_lo, r8_hi, seed ) beta = r8_uniform_ab ( r8_lo, r8_hi, seed ) call forsythe_matrix ( alpha, beta, n, a ) call forsythe_determinant ( alpha, beta, n, determ1 ) call r8mat_determinant ( n, a, determ2 ) norm_frobenius = r8mat_norm_fro ( n, n, a ) write ( *, '(2x,a20,2x,i4,2x,g14.6,2x,g14.6,2x,g14.6)' ) & title, n, determ1, determ2, norm_frobenius c c FOURIER_COSINE c title = 'FOURIER_COSINE' n = 5 call fourier_cosine_matrix ( n, a ) call fourier_cosine_determinant ( n, determ1 ) call r8mat_determinant ( n, a, determ2 ) norm_frobenius = r8mat_norm_fro ( n, n, a ) write ( *, '(2x,a20,2x,i4,2x,g14.6,2x,g14.6,2x,g14.6)' ) & title, n, determ1, determ2, norm_frobenius c c FOURIER_SINE c title = 'FOURIER_SINE' n = 5 call fourier_sine_matrix ( n, a ) call fourier_sine_determinant ( n, determ1 ) call r8mat_determinant ( n, a, determ2 ) norm_frobenius = r8mat_norm_fro ( n, n, a ) write ( *, '(2x,a20,2x,i4,2x,g14.6,2x,g14.6,2x,g14.6)' ) & title, n, determ1, determ2, norm_frobenius c c FRANK c title = 'FRANK' n = 5 call frank_matrix ( n, a ) call frank_determinant ( n, determ1 ) call r8mat_determinant ( n, a, determ2 ) norm_frobenius = r8mat_norm_fro ( n, n, a ) write ( *, '(2x,a20,2x,i4,2x,g14.6,2x,g14.6,2x,g14.6)' ) & title, n, determ1, determ2, norm_frobenius c c GEAR c do n = 4, 8 title = 'GEAR' i4_lo = -n i4_hi = +n seed = 123456789 ii = i4_uniform_ab ( i4_lo, i4_hi, seed ) jj = i4_uniform_ab ( i4_lo, i4_hi, seed ) call gear_matrix ( ii, jj, n, a ) call gear_determinant ( ii, jj, n, determ1 ) call r8mat_determinant ( n, a, determ2 ) norm_frobenius = r8mat_norm_fro ( n, n, a ) write ( *, '(2x,a20,2x,i4,2x,g14.6,2x,g14.6,2x,g14.6)' ) & title, n, determ1, determ2, norm_frobenius end do c c GFPP c title = 'GFPP' n = 5 r8_lo = -5.0D+00 r8_hi = +5.0D+00 seed = 123456789 alpha = r8_uniform_ab ( r8_lo, r8_hi, seed ) call gfpp_matrix ( n, alpha, a ) call gfpp_determinant ( n, alpha, determ1 ) call r8mat_determinant ( n, a, determ2 ) norm_frobenius = r8mat_norm_fro ( n, n, a ) write ( *, '(2x,a20,2x,i4,2x,g14.6,2x,g14.6,2x,g14.6)' ) & title, n, determ1, determ2, norm_frobenius c c GIVENS c title = 'GIVENS' n = 5 call givens_matrix ( n, n, a ) call givens_determinant ( n, determ1 ) call r8mat_determinant ( n, a, determ2 ) norm_frobenius = r8mat_norm_fro ( n, n, a ) write ( *, '(2x,a20,2x,i4,2x,g14.6,2x,g14.6,2x,g14.6)' ) & title, n, determ1, determ2, norm_frobenius c c GK316 c title = 'GK316' n = 5 call gk316_matrix ( n, a ) call gk316_determinant ( n, determ1 ) call r8mat_determinant ( n, a, determ2 ) norm_frobenius = r8mat_norm_fro ( n, n, a ) write ( *, '(2x,a20,2x,i4,2x,g14.6,2x,g14.6,2x,g14.6)' ) & title, n, determ1, determ2, norm_frobenius c c GK323 c title = 'GK323' n = 5 call gk323_matrix ( n, n, a ) call gk323_determinant ( n, determ1 ) call r8mat_determinant ( n, a, determ2 ) norm_frobenius = r8mat_norm_fro ( n, n, a ) write ( *, '(2x,a20,2x,i4,2x,g14.6,2x,g14.6,2x,g14.6)' ) & title, n, determ1, determ2, norm_frobenius c c GK324 c title = 'GK324' n = 5 r8_lo = -5.0D+00 r8_hi = +5.0D+00 seed = 123456789 call r8vec_uniform_ab ( n - 1, r8_lo, r8_hi, seed, x ) call gk324_matrix ( n, n, x, a ) call gk324_determinant ( n, x, determ1 ) call r8mat_determinant ( n, a, determ2 ) norm_frobenius = r8mat_norm_fro ( n, n, a ) write ( *, '(2x,a20,2x,i4,2x,g14.6,2x,g14.6,2x,g14.6)' ) & title, n, determ1, determ2, norm_frobenius c c GRCAR c title = 'GRCAR' n = 5 i4_lo = 1 i4_hi = n - 1 seed = 123456789 k = i4_uniform_ab ( i4_lo, i4_hi, seed ) call grcar_matrix ( n, n, k, a ) call r8mat_determinant ( n, a, determ2 ) norm_frobenius = r8mat_norm_fro ( n, n, a ) write ( *, '(2x,a20,2x,i4,2x,14x,2x,g14.6,2x,g14.6)' ) & title, n, determ2, norm_frobenius c c HADAMARD c title = 'HADAMARD' n = 5 call hadamard_matrix ( n, n, a ) call r8mat_determinant ( n, a, determ2 ) norm_frobenius = r8mat_norm_fro ( n, n, a ) write ( *, '(2x,a20,2x,i4,2x,14x,2x,g14.6,2x,g14.6)' ) & title, n, determ2, norm_frobenius c c HANKEL c title = 'HANKEL' n = 5 r8_lo = -5.0D+00 r8_hi = +5.0D+00 seed = 123456789 call r8vec_uniform_ab ( 2 * n - 1, r8_lo, r8_hi, seed, x ) call hankel_matrix ( n, x, a ) call r8mat_determinant ( n, a, determ2 ) norm_frobenius = r8mat_norm_fro ( n, n, a ) write ( *, '(2x,a20,2x,i4,2x,14x,2x,g14.6,2x,g14.6)' ) & title, n, determ2, norm_frobenius c c HANKEL_N c title = 'HANKEL_N' n = 5 call hankel_n_matrix ( n, a ) call hankel_n_determinant ( n, determ1 ) call r8mat_determinant ( n, a, determ2 ) norm_frobenius = r8mat_norm_fro ( n, n, a ) write ( *, '(2x,a20,2x,i4,2x,g14.6,2x,g14.6,2x,g14.6)' ) & title, n, determ1, determ2, norm_frobenius c c HANOWA c title = 'HANOWA' n = 6 r8_lo = -5.0D+00 r8_hi = +5.0D+00 seed = 123456789 alpha = r8_uniform_ab ( r8_lo, r8_hi, seed ) call hanowa_matrix ( alpha, n, a ) call hanowa_determinant ( alpha, n, determ1 ) call r8mat_determinant ( n, a, determ2 ) norm_frobenius = r8mat_norm_fro ( n, n, a ) write ( *, '(2x,a20,2x,i4,2x,g14.6,2x,g14.6,2x,g14.6)' ) & title, n, determ1, determ2, norm_frobenius c c HARMAN c title = 'HARMAN' n = 8 call harman_matrix ( a ) call harman_determinant ( determ1 ) call r8mat_determinant ( n, a, determ2 ) norm_frobenius = r8mat_norm_fro ( n, n, a ) write ( *, '(2x,a20,2x,i4,2x,g14.6,2x,g14.6,2x,g14.6)' ) & title, n, determ1, determ2, norm_frobenius c c HARTLEY c title = 'HARTLEY' do n = 5, 8 call hartley_matrix ( n, a ) call hartley_determinant ( n, determ1 ) call r8mat_determinant ( n, a, determ2 ) norm_frobenius = r8mat_norm_fro ( n, n, a ) write ( *, '(2x,a20,2x,i4,2x,g14.6,2x,g14.6,2x,g14.6)' ) & title, n, determ1, determ2, norm_frobenius end do c c HELMERT c title = 'HELMERT' n = 5 call helmert_matrix ( n, a ) call helmert_determinant ( n, determ1 ) call r8mat_determinant ( n, a, determ2 ) norm_frobenius = r8mat_norm_fro ( n, n, a ) write ( *, '(2x,a20,2x,i4,2x,g14.6,2x,g14.6,2x,g14.6)' ) & title, n, determ1, determ2, norm_frobenius c c HELMERT2 c title = 'HELMERT2' n = 5 r8_lo = -5.0D+00 r8_hi = +5.0D+00 seed = 123456789 call r8vec_uniform_ab ( n, r8_lo, r8_hi, seed, x ) call helmert2_matrix ( n, x, a ) call r8mat_determinant ( n, a, determ2 ) norm_frobenius = r8mat_norm_fro ( n, n, a ) write ( *, '(2x,a20,2x,i4,2x,g14.6,2x,g14.6,2x,g14.6)' ) & title, n, determ1, determ2, norm_frobenius c c HERMITE c title = 'HERMITE' n = 5 call hermite_matrix ( n, a ) call hermite_determinant ( n, determ1 ) call r8mat_determinant ( n, a, determ2 ) norm_frobenius = r8mat_norm_fro ( n, n, a ) write ( *, '(2x,a20,2x,i4,2x,g14.6,2x,g14.6,2x,g14.6)' ) & title, n, determ1, determ2, norm_frobenius c c HERNDON c title = 'HERNDON' n = 5 call herndon_matrix ( n, a ) call herndon_determinant ( n, determ1 ) call r8mat_determinant ( n, a, determ2 ) norm_frobenius = r8mat_norm_fro ( n, n, a ) write ( *, '(2x,a20,2x,i4,2x,g14.6,2x,g14.6,2x,g14.6)' ) & title, n, determ1, determ2, norm_frobenius c c HILBERT c title = 'HILBERT' n = 5 call hilbert_matrix ( n, n, a ) call hilbert_determinant ( n, determ1 ) call r8mat_determinant ( n, a, determ2 ) norm_frobenius = r8mat_norm_fro ( n, n, a ) write ( *, '(2x,a20,2x,i4,2x,g14.6,2x,g14.6,2x,g14.6)' ) & title, n, determ1, determ2, norm_frobenius c c HOUSEHOLDER c title = 'HOUSEHOLDER' n = 5 r8_lo = -5.0D+00 r8_hi = +5.0D+00 seed = 123456789 call r8vec_uniform_ab ( n, r8_lo, r8_hi, seed, x ) call householder_matrix ( n, x, a ) call householder_determinant ( n, x, determ1 ) call r8mat_determinant ( n, a, determ2 ) norm_frobenius = r8mat_norm_fro ( n, n, a ) write ( *, '(2x,a20,2x,i4,2x,g14.6,2x,g14.6,2x,g14.6)' ) & title, n, determ1, determ2, norm_frobenius c c IDEM_RANDOM c title = 'IDEM_RANDOM' n = 5 i4_lo = 0 i4_hi = n seed = 123456789 rank = i4_uniform_ab ( i4_lo, i4_hi, seed ) key = 123456789 call idem_random_matrix ( n, rank, key, a ) call idem_random_determinant ( n, rank, key, determ1 ) call r8mat_determinant ( n, a, determ2 ) norm_frobenius = r8mat_norm_fro ( n, n, a ) write ( *, '(2x,a20,2x,i4,2x,g14.6,2x,g14.6,2x,g14.6)' ) & title, n, determ1, determ2, norm_frobenius c c IDENTITY c title = 'IDENTITY' n = 5 call identity_matrix ( n, n, a ) call identity_determinant ( n, determ1 ) call r8mat_determinant ( n, a, determ2 ) norm_frobenius = r8mat_norm_fro ( n, n, a ) write ( *, '(2x,a20,2x,i4,2x,g14.6,2x,g14.6,2x,g14.6)' ) & title, n, determ1, determ2, norm_frobenius c c IJFACT1 c title = 'IJFACT1' n = 5 call ijfact1_matrix ( n, a ) call ijfact1_determinant ( n, determ1 ) call r8mat_determinant ( n, a, determ2 ) norm_frobenius = r8mat_norm_fro ( n, n, a ) write ( *, '(2x,a20,2x,i4,2x,g14.6,2x,g14.6,2x,g14.6)' ) & title, n, determ1, determ2, norm_frobenius c c IJFACT2 c title = 'IJFACT2' n = 5 call ijfact2_matrix ( n, a ) call ijfact2_determinant ( n, determ1 ) call r8mat_determinant ( n, a, determ2 ) norm_frobenius = r8mat_norm_fro ( n, n, a ) write ( *, '(2x,a20,2x,i4,2x,g14.6,2x,g14.6,2x,g14.6)' ) & title, n, determ1, determ2, norm_frobenius c c ILL3 c title = 'ILL3' n = 3 call ill3_matrix ( a ) call ill3_determinant ( determ1 ) call r8mat_determinant ( n, a, determ2 ) norm_frobenius = r8mat_norm_fro ( n, n, a ) write ( *, '(2x,a20,2x,i4,2x,g14.6,2x,g14.6,2x,g14.6)' ) & title, n, determ1, determ2, norm_frobenius c c INTEGRATION c title = 'INTEGRATION' n = 6 r8_lo = -5.0D+00 r8_hi = +5.0D+00 seed = 123456789 alpha = r8_uniform_ab ( r8_lo, r8_hi, seed ) call integration_matrix ( alpha, n, a ) call integration_determinant ( alpha, n, determ1 ) call r8mat_determinant ( n, a, determ2 ) norm_frobenius = r8mat_norm_fro ( n, n, a ) write ( *, '(2x,a20,2x,i4,2x,g14.6,2x,g14.6,2x,g14.6)' ) & title, n, determ1, determ2, norm_frobenius c c INVOL c title = 'INVOL' n = 5 call invol_matrix ( n, a ) call invol_determinant ( n, determ1 ) call r8mat_determinant ( n, a, determ2 ) norm_frobenius = r8mat_norm_fro ( n, n, a ) write ( *, '(2x,a20,2x,i4,2x,g14.6,2x,g14.6,2x,g14.6)' ) & title, n, determ1, determ2, norm_frobenius c c INVOL_RANDOM c title = 'INVOL_RANDOM' n = 5 i4_lo = 0 i4_hi = n seed = 123456789 rank = i4_uniform_ab ( i4_lo, i4_hi, seed ) key = 123456789 call invol_random_matrix ( n, rank, key, a ) call r8mat_determinant ( n, a, determ2 ) norm_frobenius = r8mat_norm_fro ( n, n, a ) write ( *, '(2x,a20,2x,i4,2x,14x,2x,g14.6,2x,g14.6)' ) & title, n, determ2, norm_frobenius c c jacobi_legendre c title = 'jacobi_legendre' n = 5 call jacobi_legendre_matrix ( n, n, a ) call jacobi_legendre_determinant ( n, determ1 ) call r8mat_determinant ( n, a, determ2 ) norm_frobenius = r8mat_norm_fro ( n, n, a ) write ( *, '(2x,a20,2x,i4,2x,g14.6,2x,g14.6,2x,g14.6)' ) & title, n, determ1, determ2, norm_frobenius c c jacobi_legendre c title = 'jacobi_legendre' n = 6 call jacobi_legendre_matrix ( n, n, a ) call jacobi_legendre_determinant ( n, determ1 ) call r8mat_determinant ( n, a, determ2 ) norm_frobenius = r8mat_norm_fro ( n, n, a ) write ( *, '(2x,a20,2x,i4,2x,g14.6,2x,g14.6,2x,g14.6)' ) & title, n, determ1, determ2, norm_frobenius c c JORDAN c title = 'JORDAN' n = 6 r8_lo = -5.0D+00 r8_hi = +5.0D+00 seed = 123456789 alpha = r8_uniform_ab ( r8_lo, r8_hi, seed ) call jordan_matrix ( n, n, alpha, a ) call jordan_determinant ( n, alpha, determ1 ) call r8mat_determinant ( n, a, determ2 ) norm_frobenius = r8mat_norm_fro ( n, n, a ) write ( *, '(2x,a20,2x,i4,2x,g14.6,2x,g14.6,2x,g14.6)' ) & title, n, determ1, determ2, norm_frobenius c c KAHAN c title = 'KAHAN' n = 5 r8_lo = -5.0D+00 r8_hi = +5.0D+00 seed = 123456789 alpha = r8_uniform_ab ( r8_lo, r8_hi, seed ) call kahan_matrix ( alpha, n, n, a ) call kahan_determinant ( alpha, n, determ1 ) call r8mat_determinant ( n, a, determ2 ) norm_frobenius = r8mat_norm_fro ( n, n, a ) write ( *, '(2x,a20,2x,i4,2x,g14.6,2x,g14.6,2x,g14.6)' ) & title, n, determ1, determ2, norm_frobenius c c KERSHAW c title = 'KERSHAW' n = 4 call kershaw_matrix ( a ) call kershaw_determinant ( determ1 ) call r8mat_determinant ( n, a, determ2 ) norm_frobenius = r8mat_norm_fro ( n, n, a ) write ( *, '(2x,a20,2x,i4,2x,g14.6,2x,g14.6,2x,g14.6)' ) & title, n, determ1, determ2, norm_frobenius c c KERSHAWTRI c title = 'KERSHAWTRI' n = 5 x_n = ( n + 1 ) / 2 r8_lo = -5.0D+00 r8_hi = +5.0D+00 seed = 123456789 call r8vec_uniform_ab ( x_n, r8_lo, r8_hi, seed, x ) call kershawtri_matrix ( n, x, a ) call kershawtri_determinant ( n, x, determ1 ) call r8mat_determinant ( n, a, determ2 ) norm_frobenius = r8mat_norm_fro ( n, n, a ) write ( *, '(2x,a20,2x,i4,2x,g14.6,2x,g14.6,2x,g14.6)' ) & title, n, determ1, determ2, norm_frobenius c c KMS c title = 'KMS' n = 5 r8_lo = -5.0D+00 r8_hi = +5.0D+00 seed = 123456789 alpha = r8_uniform_ab ( r8_lo, r8_hi, seed ) call kms_matrix ( alpha, n, n, a ) call kms_determinant ( alpha, n, determ1 ) call r8mat_determinant ( n, a, determ2 ) norm_frobenius = r8mat_norm_fro ( n, n, a ) write ( *, '(2x,a20,2x,i4,2x,g14.6,2x,g14.6,2x,g14.6)' ) & title, n, determ1, determ2, norm_frobenius c c LAGUERRE c title = 'LAGUERRE' n = 5 call laguerre_matrix ( n, a ) call laguerre_determinant ( n, determ1 ) call r8mat_determinant ( n, a, determ2 ) norm_frobenius = r8mat_norm_fro ( n, n, a ) write ( *, '(2x,a20,2x,i4,2x,g14.6,2x,g14.6,2x,g14.6)' ) & title, n, determ1, determ2, norm_frobenius c c legendre_matrix c title = 'legendre_matrix' n = 5 call legendre_matrix ( n, a ) call legendre_determinant ( n, determ1 ) call r8mat_determinant ( n, a, determ2 ) norm_frobenius = r8mat_norm_fro ( n, n, a ) write ( *, '(2x,a20,2x,i4,2x,g14.6,2x,g14.6,2x,g14.6)' ) & title, n, determ1, determ2, norm_frobenius c c LEHMER c title = 'LEHMER' n = 5 call lehmer_matrix ( n, n, a ) call lehmer_determinant ( n, determ1 ) call r8mat_determinant ( n, a, determ2 ) norm_frobenius = r8mat_norm_fro ( n, n, a ) write ( *, '(2x,a20,2x,i4,2x,g14.6,2x,g14.6,2x,g14.6)' ) & title, n, determ1, determ2, norm_frobenius c c LESLIE c title = 'LESLIE' n = 4 b = 0.025D+00 di = 0.010D+00 da = 0.100D+00 call leslie_matrix ( b, di, da, a ) call leslie_determinant ( b, di, da, determ1 ) call r8mat_determinant ( n, a, determ2 ) norm_frobenius = r8mat_norm_fro ( n, n, a ) write ( *, '(2x,a20,2x,i4,2x,g14.6,2x,g14.6,2x,g14.6)' ) & title, n, determ1, determ2, norm_frobenius c c LESP c title = 'LESP' n = 5 call lesp_matrix ( n, n, a ) call lesp_determinant ( n, determ1 ) call r8mat_determinant ( n, a, determ2 ) norm_frobenius = r8mat_norm_fro ( n, n, a ) write ( *, '(2x,a20,2x,i4,2x,g14.6,2x,g14.6,2x,g14.6)' ) & title, n, determ1, determ2, norm_frobenius c c LIETZKE c title = 'LIETZKE' n = 5 call lietzke_matrix ( n, a ) call lietzke_determinant ( n, determ1 ) call r8mat_determinant ( n, a, determ2 ) norm_frobenius = r8mat_norm_fro ( n, n, a ) write ( *, '(2x,a20,2x,i4,2x,g14.6,2x,g14.6,2x,g14.6)' ) & title, n, determ1, determ2, norm_frobenius c c LIGHTS_OUT c title = 'LIGHTS_OUT' row_num = 5 col_num = 5 n = row_num * col_num; call lights_out_matrix ( row_num, col_num, n, a ) call r8mat_determinant ( n, a, determ2 ) norm_frobenius = r8mat_norm_fro ( n, n, a ) write ( *, '(2x,a20,2x,i4,2x,14x,2x,g14.6,2x,g14.6)' ) & title, n, determ2, norm_frobenius c c LINE_ADJ c title = 'LINE_ADJ' n = 5 call line_adj_matrix ( n, a ) call line_adj_determinant ( n, determ1 ) call r8mat_determinant ( n, a, determ2 ) norm_frobenius = r8mat_norm_fro ( n, n, a ) write ( *, '(2x,a20,2x,i4,2x,g14.6,2x,g14.6,2x,g14.6)' ) & title, n, determ1, determ2, norm_frobenius c c LINE_ADJ c title = 'LINE_ADJ' n = 6 call line_adj_matrix ( n, a ) call line_adj_determinant ( n, determ1 ) call r8mat_determinant ( n, a, determ2 ) norm_frobenius = r8mat_norm_fro ( n, n, a ) write ( *, '(2x,a20,2x,i4,2x,g14.6,2x,g14.6,2x,g14.6)' ) & title, n, determ1, determ2, norm_frobenius c c LINE_LOOP_ADJ c title = 'LINE_LOOP_ADJ' n = 5 call line_loop_adj_matrix ( n, a ) call line_loop_adj_determinant ( n, determ1 ) call r8mat_determinant ( n, a, determ2 ) norm_frobenius = r8mat_norm_fro ( n, n, a ) write ( *, '(2x,a20,2x,i4,2x,g14.6,2x,g14.6,2x,g14.6)' ) & title, n, determ1, determ2, norm_frobenius c c LOEWNER c title = 'LOEWNER' n = 5 r8_lo = -5.0D+00 r8_hi = +5.0D+00 seed = 123456789 call r8vec_uniform_ab ( n, r8_lo, r8_hi, seed, w ) call r8vec_uniform_ab ( n, r8_lo, r8_hi, seed, x ) call r8vec_uniform_ab ( n, r8_lo, r8_hi, seed, y ) call r8vec_uniform_ab ( n, r8_lo, r8_hi, seed, z ) call loewner_matrix ( w, x, y, z, n, a ) call r8mat_determinant ( n, a, determ2 ) norm_frobenius = r8mat_norm_fro ( n, n, a ) write ( *, '(2x,a20,2x,i4,2x,14x,2x,g14.6,2x,g14.6)' ) & title, n, determ2, norm_frobenius c c LOTKIN c title = 'LOTKIN' n = 5 call lotkin_matrix ( n, n, a ) call lotkin_determinant ( n, determ1 ) call r8mat_determinant ( n, a, determ2 ) norm_frobenius = r8mat_norm_fro ( n, n, a ) write ( *, '(2x,a20,2x,i4,2x,g14.6,2x,g14.6,2x,g14.6)' ) & title, n, determ1, determ2, norm_frobenius c c MARKOV_RANDOM c title = 'MARKOV_RANDOM' n = 5 key = 123456789 call markov_random_matrix ( n, key, a ) call r8mat_determinant ( n, a, determ2 ) norm_frobenius = r8mat_norm_fro ( n, n, a ) write ( *, '(2x,a20,2x,i4,2x,14x,2x,g14.6,2x,g14.6)' ) & title, n, determ2, norm_frobenius c c MAXIJ c title = 'MAXIJ' n = 5 call maxij_matrix ( n, n, a ) call maxij_determinant ( n, determ1 ) call r8mat_determinant ( n, a, determ2 ) norm_frobenius = r8mat_norm_fro ( n, n, a ) write ( *, '(2x,a20,2x,i4,2x,g14.6,2x,g14.6,2x,g14.6)' ) & title, n, determ1, determ2, norm_frobenius c c MILNES c title = 'MILNES' n = 5 r8_lo = -5.0D+00 r8_hi = +5.0D+00 seed = 123456789 call r8vec_uniform_ab ( n, r8_lo, r8_hi, seed, x ) call milnes_matrix ( n, n, x, a ) call milnes_determinant ( n, x, determ1 ) call r8mat_determinant ( n, a, determ2 ) norm_frobenius = r8mat_norm_fro ( n, n, a ) write ( *, '(2x,a20,2x,i4,2x,g14.6,2x,g14.6,2x,g14.6)' ) & title, n, determ1, determ2, norm_frobenius c c MINIJ c title = 'MINIJ' n = 5 call minij_matrix ( n, n, a ) call minij_determinant ( n, determ1 ) call r8mat_determinant ( n, a, determ2 ) norm_frobenius = r8mat_norm_fro ( n, n, a ) write ( *, '(2x,a20,2x,i4,2x,g14.6,2x,g14.6,2x,g14.6)' ) & title, n, determ1, determ2, norm_frobenius c c MOLER1 c title = 'MOLER1' n = 5 r8_lo = -5.0D+00 r8_hi = +5.0D+00 seed = 123456789 alpha = r8_uniform_ab ( r8_lo, r8_hi, seed ) call moler1_matrix ( alpha, n, n, a ) call moler1_determinant ( alpha, n, determ1 ) call r8mat_determinant ( n, a, determ2 ) norm_frobenius = r8mat_norm_fro ( n, n, a ) write ( *, '(2x,a20,2x,i4,2x,g14.6,2x,g14.6,2x,g14.6)' ) & title, n, determ1, determ2, norm_frobenius c c MOLER2 c title = 'MOLER2' n = 5 call moler2_matrix ( a ) call moler2_determinant ( determ1 ) call r8mat_determinant ( n, a, determ2 ) norm_frobenius = r8mat_norm_fro ( n, n, a ) write ( *, '(2x,a20,2x,i4,2x,g14.6,2x,g14.6,2x,g14.6)' ) & title, n, determ1, determ2, norm_frobenius c c MOLER3 c title = 'MOLER3' n = 5 call moler3_matrix ( n, n, a ) call moler3_determinant ( n, determ1 ) call r8mat_determinant ( n, a, determ2 ) norm_frobenius = r8mat_norm_fro ( n, n, a ) write ( *, '(2x,a20,2x,i4,2x,g14.6,2x,g14.6,2x,g14.6)' ) & title, n, determ1, determ2, norm_frobenius c c MOLER4 c title = 'MOLER4' n = 4 call moler4_matrix ( a ) call moler4_determinant ( determ1 ) call r8mat_determinant ( n, a, determ2 ) norm_frobenius = r8mat_norm_fro ( n, n, a ) write ( *, '(2x,a20,2x,i4,2x,g14.6,2x,g14.6,2x,g14.6)' ) & title, n, determ1, determ2, norm_frobenius c c NEUMANN c title = 'NEUMANN' row_num = 5 col_num = 5 n = row_num * col_num call neumann_matrix ( row_num, col_num, a ) call neumann_determinant ( n, determ1 ) call r8mat_determinant ( n, a, determ2 ) norm_frobenius = r8mat_norm_fro ( n, n, a ) write ( *, '(2x,a20,2x,i4,2x,g14.6,2x,g14.6,2x,g14.6)' ) & title, n, determ1, determ2, norm_frobenius c c ONE c title = 'ONE' n = 5 call one_matrix ( n, n, a ) call one_determinant ( n, determ1 ) call r8mat_determinant ( n, a, determ2 ) norm_frobenius = r8mat_norm_fro ( n, n, a ) write ( *, '(2x,a20,2x,i4,2x,g14.6,2x,g14.6,2x,g14.6)' ) & title, n, determ1, determ2, norm_frobenius c c ORTEGA c title = 'ORTEGA' n = 5 r8_lo = -5.0D+00 r8_hi = +5.0D+00 seed = 123456789 call r8vec_uniform_ab ( n, r8_lo, r8_hi, seed, v1 ) call r8vec_uniform_ab ( n, r8_lo, r8_hi, seed, v2 ) call r8vec_uniform_ab ( n, r8_lo, r8_hi, seed, v3 ) call ortega_matrix ( n, v1, v2, v3, a ) call ortega_determinant ( n, v1, v2, v3, determ1 ) call r8mat_determinant ( n, a, determ2 ) norm_frobenius = r8mat_norm_fro ( n, n, a ) write ( *, '(2x,a20,2x,i4,2x,g14.6,2x,g14.6,2x,g14.6)' ) & title, n, determ1, determ2, norm_frobenius c c ORTH_RANDOM c title = 'ORTH_RANDOM' n = 5 r8_lo = -5.0D+00 r8_hi = +5.0D+00 key = 123456789 call orth_random_matrix ( n, key, a ) call orth_random_determinant ( n, key, determ1 ) call r8mat_determinant ( n, a, determ2 ) norm_frobenius = r8mat_norm_fro ( n, n, a ) write ( *, '(2x,a20,2x,i4,2x,g14.6,2x,g14.6,2x,g14.6)' ) & title, n, determ1, determ2, norm_frobenius c c ORTH_SYMM c title = 'ORTH_SYMM' n = 5 call orth_symm_matrix ( n, a ) call orth_symm_determinant ( n, determ1 ) call r8mat_determinant ( n, a, determ2 ) norm_frobenius = r8mat_norm_fro ( n, n, a ) write ( *, '(2x,a20,2x,i4,2x,g14.6,2x,g14.6,2x,g14.6)' ) & title, n, determ1, determ2, norm_frobenius c c OTO c title = 'OTO' n = 5 call oto_matrix ( n, n, a ) call oto_determinant ( n, determ1 ) call r8mat_determinant ( n, a, determ2 ) norm_frobenius = r8mat_norm_fro ( n, n, a ) write ( *, '(2x,a20,2x,i4,2x,g14.6,2x,g14.6,2x,g14.6)' ) & title, n, determ1, determ2, norm_frobenius c c PARTER c title = 'PARTER' n = 5 call parter_matrix ( n, n, a ) call parter_determinant ( n, determ1 ) call r8mat_determinant ( n, a, determ2 ) norm_frobenius = r8mat_norm_fro ( n, n, a ) write ( *, '(2x,a20,2x,i4,2x,g14.6,2x,g14.6,2x,g14.6)' ) & title, n, determ1, determ2, norm_frobenius c c PASCAL1 c title = 'PASCAL1' n = 5 call pascal1_matrix ( n, a ) call pascal1_determinant ( n, determ1 ) call r8mat_determinant ( n, a, determ2 ) norm_frobenius = r8mat_norm_fro ( n, n, a ) write ( *, '(2x,a20,2x,i4,2x,g14.6,2x,g14.6,2x,g14.6)' ) & title, n, determ1, determ2, norm_frobenius c c PASCAL2 c title = 'PASCAL2' n = 5 call pascal2_matrix ( n, a ) call pascal2_determinant ( n, determ1 ) call r8mat_determinant ( n, a, determ2 ) norm_frobenius = r8mat_norm_fro ( n, n, a ) write ( *, '(2x,a20,2x,i4,2x,g14.6,2x,g14.6,2x,g14.6)' ) & title, n, determ1, determ2, norm_frobenius c c PASCAL3 c title = 'PASCAL3' n = 5 r8_lo = -5.0D+00 r8_hi = +5.0D+00 seed = 123456789 alpha = r8_uniform_ab ( r8_lo, r8_hi, seed ) call pascal3_matrix ( n, alpha, a ) call pascal3_determinant ( n, alpha, determ1 ) call r8mat_determinant ( n, a, determ2 ) norm_frobenius = r8mat_norm_fro ( n, n, a ) write ( *, '(2x,a20,2x,i4,2x,g14.6,2x,g14.6,2x,g14.6)' ) & title, n, determ1, determ2, norm_frobenius c c spd_random c title = 'spd_random' n = 5 key = 123456789 call spd_random_matrix ( n, key, a ) call spd_random_determinant ( n, key, determ1 ) call r8mat_determinant ( n, a, determ2 ) norm_frobenius = r8mat_norm_fro ( n, n, a ) write ( *, '(2x,a20,2x,i4,2x,g14.6,2x,g14.6,2x,g14.6)' ) & title, n, determ1, determ2, norm_frobenius c c PEI c title = 'PEI' n = 5 r8_lo = -5.0D+00 r8_hi = +5.0D+00 seed = 123456789 alpha = r8_uniform_ab ( r8_lo, r8_hi, seed ) call pei_matrix ( alpha, n, a ) call pei_determinant ( alpha, n, determ1 ) call r8mat_determinant ( n, a, determ2 ) norm_frobenius = r8mat_norm_fro ( n, n, a ) write ( *, '(2x,a20,2x,i4,2x,g14.6,2x,g14.6,2x,g14.6)' ) & title, n, determ1, determ2, norm_frobenius c c PERMUTATION_RANDOM c title = 'PERMUTATION_RANDOM' n = 5 key = 123456789 call permutation_random_matrix ( n, key, a ) call permutation_random_determinant ( n, key, determ1 ) call r8mat_determinant ( n, a, determ2 ) norm_frobenius = r8mat_norm_fro ( n, n, a ) write ( *, '(2x,a20,2x,i4,2x,g14.6,2x,g14.6,2x,g14.6)' ) & title, n, determ1, determ2, norm_frobenius c c PLU c title = 'PLU' n = 5 seed = 123456789 do i = 1, n i4_lo = i i4_hi = n pivot(i) = i4_uniform_ab ( i4_lo, i4_hi, seed ) end do call plu_matrix ( n, pivot, a ) call plu_determinant ( n, pivot, determ1 ) call r8mat_determinant ( n, a, determ2 ) norm_frobenius = r8mat_norm_fro ( n, n, a ) write ( *, '(2x,a20,2x,i4,2x,g14.6,2x,g14.6,2x,g14.6)' ) & title, n, determ1, determ2, norm_frobenius c c POISSON c title = 'POISSON' row_num = 5 col_num = 5 n = row_num * col_num call poisson_matrix ( row_num, col_num, a ) call poisson_determinant ( row_num, col_num, determ1 ) call r8mat_determinant ( n, a, determ2 ) norm_frobenius = r8mat_norm_fro ( n, n, a ) write ( *, '(2x,a20,2x,i4,2x,g14.6,2x,g14.6,2x,g14.6)' ) & title, n, determ1, determ2, norm_frobenius c c PROLATE c title = 'PROLATE' n = 5 r8_lo = -5.0D+00 r8_hi = +5.0D+00 seed = 123456789 alpha = r8_uniform_ab ( r8_lo, r8_hi, seed ) call prolate_matrix ( alpha, n, a ) call r8mat_determinant ( n, a, determ2 ) norm_frobenius = r8mat_norm_fro ( n, n, a ) write ( *, '(2x,a20,2x,i4,2x,14x,2x,g14.6,2x,g14.6)' ) & title, n, determ2, norm_frobenius c c RECTANGLE_ADJ c title = 'RECTANGLE_ADJ' row_num = 5 col_num = 5 n = row_num * col_num call rectangle_adj_matrix ( row_num, col_num, n, a ) call rectangle_adj_determinant ( row_num, col_num, determ1 ) call r8mat_determinant ( n, a, determ2 ) norm_frobenius = r8mat_norm_fro ( n, n, a ) write ( *, '(2x,a20,2x,i4,2x,g14.6,2x,g14.6,2x,g14.6)' ) & title, n, determ1, determ2, norm_frobenius c c REDHEFFER c title = 'REDHEFFER' n = 5 call redheffer_matrix ( n, a ) call redheffer_determinant ( n, determ1 ) call r8mat_determinant ( n, a, determ2 ) norm_frobenius = r8mat_norm_fro ( n, n, a ) write ( *, '(2x,a20,2x,i4,2x,g14.6,2x,g14.6,2x,g14.6)' ) & title, n, determ1, determ2, norm_frobenius c c REF_RANDOM c title = 'REF_RANDOM' n = 5 prob = 0.65D+00 key = 123456789 call ref_random_matrix ( n, n, prob, key, a ) call ref_random_determinant ( n, prob, key, determ1 ) call r8mat_determinant ( n, a, determ2 ) norm_frobenius = r8mat_norm_fro ( n, n, a ) write ( *, '(2x,a20,2x,i4,2x,g14.6,2x,g14.6,2x,g14.6)' ) & title, n, determ1, determ2, norm_frobenius c c REF_RANDOM c title = 'REF_RANDOM' n = 5 prob = 0.85D+00 key = 123456789 call ref_random_matrix ( n, n, prob, key, a ) call ref_random_determinant ( n, prob, key, determ1 ) call r8mat_determinant ( n, a, determ2 ) norm_frobenius = r8mat_norm_fro ( n, n, a ) write ( *, '(2x,a20,2x,i4,2x,g14.6,2x,g14.6,2x,g14.6)' ) & title, n, determ1, determ2, norm_frobenius c c RIEMANN c title = 'RIEMANN' n = 5 call riemann_matrix ( n, n, a ) call r8mat_determinant ( n, a, determ2 ) norm_frobenius = r8mat_norm_fro ( n, n, a ) write ( *, '(2x,a20,2x,i4,2x,14x,2x,g14.6,2x,g14.6)' ) & title, n, determ2, norm_frobenius c c RING_ADJ c do n = 1, 8 title = 'RING_ADJ' call ring_adj_matrix ( n, a ) call ring_adj_determinant ( n, determ1 ) call r8mat_determinant ( n, a, determ2 ) norm_frobenius = r8mat_norm_fro ( n, n, a ) write ( *, '(2x,a20,2x,i4,2x,g14.6,2x,g14.6,2x,g14.6)' ) & title, n, determ1, determ2, norm_frobenius end do c c RIS c title = 'RIS' n = 5 call ris_matrix ( n, a ) call ris_determinant ( n, determ1 ) call r8mat_determinant ( n, a, determ2 ) norm_frobenius = r8mat_norm_fro ( n, n, a ) write ( *, '(2x,a20,2x,i4,2x,g14.6,2x,g14.6,2x,g14.6)' ) & title, n, determ1, determ2, norm_frobenius c c RODMAN c title = 'RODMAN' n = 5 r8_lo = -5.0D+00 r8_hi = +5.0D+00 seed = 123456789 alpha = r8_uniform_ab ( r8_lo, r8_hi, seed ) call rodman_matrix ( n, n, alpha, a ) call rodman_determinant ( n, alpha, determ1 ) call r8mat_determinant ( n, a, determ2 ) norm_frobenius = r8mat_norm_fro ( n, n, a ) write ( *, '(2x,a20,2x,i4,2x,g14.6,2x,g14.6,2x,g14.6)' ) & title, n, determ1, determ2, norm_frobenius c c ROSSER1 c c Note that while the correct determinant of this matrix is 0, c that value is very difficult to calculate correctly. MATLAB c returns det ( A ) = -10611, for instance. c title = 'ROSSER1' n = 8 call rosser1_matrix ( a ) call rosser1_determinant ( determ1 ) call r8mat_determinant ( n, a, determ2 ) norm_frobenius = r8mat_norm_fro ( n, n, a ) write ( *, '(2x,a20,2x,i4,2x,g14.6,2x,g14.6,2x,g14.6)' ) & title, n, determ1, determ2, norm_frobenius c c ROUTH c title = 'ROUTH' n = 5 r8_lo = -5.0D+00 r8_hi = +5.0D+00 seed = 123456789 call r8vec_uniform_ab ( n, r8_lo, r8_hi, seed, x ) call routh_matrix ( n, x, a ) call routh_determinant ( n, x, determ1 ) call r8mat_determinant ( n, a, determ2 ) norm_frobenius = r8mat_norm_fro ( n, n, a ) write ( *, '(2x,a20,2x,i4,2x,g14.6,2x,g14.6,2x,g14.6)' ) & title, n, determ1, determ2, norm_frobenius c c RUTIS1 c title = 'RUTIS1' n = 4 call rutis1_matrix ( a ) call rutis1_determinant ( determ1 ) call r8mat_determinant ( n, a, determ2 ) norm_frobenius = r8mat_norm_fro ( n, n, a ) write ( *, '(2x,a20,2x,i4,2x,g14.6,2x,g14.6,2x,g14.6)' ) & title, n, determ1, determ2, norm_frobenius c c RUTIS2 c title = 'RUTIS2' n = 4 call rutis2_matrix ( a ) call rutis2_determinant ( determ1 ) call r8mat_determinant ( n, a, determ2 ) norm_frobenius = r8mat_norm_fro ( n, n, a ) write ( *, '(2x,a20,2x,i4,2x,g14.6,2x,g14.6,2x,g14.6)' ) & title, n, determ1, determ2, norm_frobenius c c RUTIS3 c title = 'RUTIS3' n = 4 call rutis3_matrix ( a ) call rutis3_determinant ( determ1 ) call r8mat_determinant ( n, a, determ2 ) norm_frobenius = r8mat_norm_fro ( n, n, a ) write ( *, '(2x,a20,2x,i4,2x,g14.6,2x,g14.6,2x,g14.6)' ) & title, n, determ1, determ2, norm_frobenius c c RUTIS4 c title = 'RUTIS4' n = 5 call rutis4_matrix ( n, a ) call rutis4_determinant ( n, determ1 ) call r8mat_determinant ( n, a, determ2 ) norm_frobenius = r8mat_norm_fro ( n, n, a ) write ( *, '(2x,a20,2x,i4,2x,g14.6,2x,g14.6,2x,g14.6)' ) & title, n, determ1, determ2, norm_frobenius c c RUTIS5 c title = 'RUTIS5' n = 4 call rutis5_matrix ( a ) call rutis5_determinant ( determ1 ) call r8mat_determinant ( n, a, determ2 ) norm_frobenius = r8mat_norm_fro ( n, n, a ) write ( *, '(2x,a20,2x,i4,2x,g14.6,2x,g14.6,2x,g14.6)' ) & title, n, determ1, determ2, norm_frobenius c c SCHUR_BLOCK c title = 'SCHUR_BLOCK' n = 5 x_n = ( n + 1 ) / 2 y_n = n / 2 r8_lo = -5.0D+00 r8_hi = +5.0D+00 seed = 123456789 call r8vec_uniform_ab ( x_n, r8_lo, r8_hi, seed, x ) call r8vec_uniform_ab ( y_n, r8_lo, r8_hi, seed, y ) call schur_block_matrix ( n, x, y, a ) call schur_block_determinant ( n, x, y, determ1 ) call r8mat_determinant ( n, a, determ2 ) norm_frobenius = r8mat_norm_fro ( n, n, a ) write ( *, '(2x,a20,2x,i4,2x,g14.6,2x,g14.6,2x,g14.6)' ) & title, n, determ1, determ2, norm_frobenius c c SKEW_CIRCULANT c title = 'SKEW_CIRCULANT' n = 5 r8_lo = -5.0D+00 r8_hi = +5.0D+00 seed = 123456789 call r8vec_uniform_ab ( n, r8_lo, r8_hi, seed, x ) call skew_circulant_matrix ( n, n, x, a ) call skew_circulant_determinant ( n, x, determ1 ) call r8mat_determinant ( n, a, determ2 ) norm_frobenius = r8mat_norm_fro ( n, n, a ) write ( *, '(2x,a20,2x,i4,2x,g14.6,2x,g14.6,2x,g14.6)' ) & title, n, determ1, determ2, norm_frobenius c c SPLINE c title = 'SPLINE' n = 5 r8_lo = -5.0D+00 r8_hi = +5.0D+00 seed = 123456789 call r8vec_uniform_ab ( n, r8_lo, r8_hi, seed, x ) call spline_matrix ( n, x, a ) call spline_determinant ( n, x, determ1 ) call r8mat_determinant ( n, a, determ2 ) norm_frobenius = r8mat_norm_fro ( n, n, a ) write ( *, '(2x,a20,2x,i4,2x,g14.6,2x,g14.6,2x,g14.6)' ) & title, n, determ1, determ2, norm_frobenius c c STIRLING c title = 'STIRLING' n = 5 call stirling_matrix ( n, n, a ) call stirling_determinant ( n, determ1 ) call r8mat_determinant ( n, a, determ2 ) norm_frobenius = r8mat_norm_fro ( n, n, a ) write ( *, '(2x,a20,2x,i4,2x,g14.6,2x,g14.6,2x,g14.6)' ) & title, n, determ1, determ2, norm_frobenius c c STRIPE c title = 'STRIPE' n = 5 call stripe_matrix ( n, a ) call r8mat_determinant ( n, a, determ2 ) norm_frobenius = r8mat_norm_fro ( n, n, a ) write ( *, '(2x,a20,2x,i4,2x,14x,2x,g14.6,2x,g14.6)' ) & title, n, determ2, norm_frobenius c c SUMMATION c title = 'SUMMATION' n = 5 call summation_matrix ( n, n, a ) call summation_determinant ( n, determ1 ) call r8mat_determinant ( n, a, determ2 ) norm_frobenius = r8mat_norm_fro ( n, n, a ) write ( *, '(2x,a20,2x,i4,2x,g14.6,2x,g14.6,2x,g14.6)' ) & title, n, determ1, determ2, norm_frobenius c c SWEET1 c title = 'SWEET1' n = 6 call sweet1_determinant ( determ1 ) call sweet1_matrix ( a ) call r8mat_determinant ( n, a, determ2 ) norm_frobenius = r8mat_norm_fro ( n, n, a ) write ( *, '(2x,a20,2x,i4,2x,g14.6,2x,g14.6,2x,g14.6)' ) & title, n, determ1, determ2, norm_frobenius c c SWEET2 c title = 'SWEET2' n = 6 call sweet2_determinant ( determ1 ) call sweet2_matrix ( a ) call r8mat_determinant ( n, a, determ2 ) norm_frobenius = r8mat_norm_fro ( n, n, a ) write ( *, '(2x,a20,2x,i4,2x,g14.6,2x,g14.6,2x,g14.6)' ) & title, n, determ1, determ2, norm_frobenius c c SWEET3 c title = 'SWEET3' n = 6 call sweet3_determinant ( determ1 ) call sweet3_matrix ( a ) call r8mat_determinant ( n, a, determ2 ) norm_frobenius = r8mat_norm_fro ( n, n, a ) write ( *, '(2x,a20,2x,i4,2x,g14.6,2x,g14.6,2x,g14.6)' ) & title, n, determ1, determ2, norm_frobenius c c SWEET4 c title = 'SWEET4' n = 13 call sweet4_determinant ( determ1 ) call sweet4_matrix ( a ) call r8mat_determinant ( n, a, determ2 ) norm_frobenius = r8mat_norm_fro ( n, n, a ) write ( *, '(2x,a20,2x,i4,2x,g14.6,2x,g14.6,2x,g14.6)' ) & title, n, determ1, determ2, norm_frobenius c c SYLVESTER c title = 'SYLVESTER' n = 5 x_n = 3 + 1 y_n = 2 + 1 r8_lo = -5.0D+00 r8_hi = +5.0D+00 seed = 123456789 call r8vec_uniform_ab ( x_n, r8_lo, r8_hi, seed, x ) call r8vec_uniform_ab ( y_n, r8_lo, r8_hi, seed, y ) call sylvester_matrix ( n, x_n - 1, x, y_n - 1, y, a ) call r8mat_determinant ( n, a, determ2 ) norm_frobenius = r8mat_norm_fro ( n, n, a ) write ( *, '(2x,a20,2x,i4,2x,14x,2x,g14.6,2x,g14.6)' ) & title, n, determ2, norm_frobenius c c SYLVESTER_KAC c title = 'SYLVESTER_KAC' n = 5 call r8vec_uniform_ab ( x_n, r8_lo, r8_hi, seed, x ) call r8vec_uniform_ab ( y_n, r8_lo, r8_hi, seed, y ) call sylvester_kac_matrix ( n, a ) call sylvester_kac_determinant ( n, determ1 ) call r8mat_determinant ( n, a, determ2 ) norm_frobenius = r8mat_norm_fro ( n, n, a ) write ( *, '(2x,a20,2x,i4,2x,g14.6,2x,g14.6,2x,g14.6)' ) & title, n, determ1, determ2, norm_frobenius c c SYLVESTER_KAC c title = 'SYLVESTER_KAC' n = 6 call r8vec_uniform_ab ( x_n, r8_lo, r8_hi, seed, x ) call r8vec_uniform_ab ( y_n, r8_lo, r8_hi, seed, y ) call sylvester_kac_matrix ( n, a ) call sylvester_kac_determinant ( n, determ1 ) call r8mat_determinant ( n, a, determ2 ) norm_frobenius = r8mat_norm_fro ( n, n, a ) write ( *, '(2x,a20,2x,i4,2x,g14.6,2x,g14.6,2x,g14.6)' ) & title, n, determ1, determ2, norm_frobenius c c SYMM_RANDOM c title = 'SYMM_RANDOM' n = 5 r8_lo = -5.0D+00 r8_hi = +5.0D+00 seed = 123456789 call r8vec_uniform_ab ( n, r8_lo, r8_hi, seed, d ) key = 123456789 call symm_random_matrix ( n, d, key, a ) call symm_random_determinant ( n, d, key, determ1 ) call r8mat_determinant ( n, a, determ2 ) norm_frobenius = r8mat_norm_fro ( n, n, a ) write ( *, '(2x,a20,2x,i4,2x,g14.6,2x,g14.6,2x,g14.6)' ) & title, n, determ1, determ2, norm_frobenius c c TOEPLITZ c title = 'TOEPLITZ' n = 5 r8_lo = -5.0D+00 r8_hi = +5.0D+00 seed = 123456789 call r8vec_uniform_ab ( 2 * n - 1, r8_lo, r8_hi, seed, x ) call toeplitz_matrix ( n, x, a ) call r8mat_determinant ( n, a, determ2 ) norm_frobenius = r8mat_norm_fro ( n, n, a ) write ( *, '(2x,a20,2x,i4,2x,14x,2x,g14.6,2x,g14.6)' ) & title, n, determ2, norm_frobenius c c TOEPLITZ_5DIAG c title = 'TOEPLITZ_5DIAG' n = 5 r8_lo = -5.0D+00 r8_hi = +5.0D+00 seed = 123456789 d1 = r8_uniform_ab ( r8_lo, r8_hi, seed ) d2 = r8_uniform_ab ( r8_lo, r8_hi, seed ) d3 = r8_uniform_ab ( r8_lo, r8_hi, seed ) d4 = r8_uniform_ab ( r8_lo, r8_hi, seed ) d5 = r8_uniform_ab ( r8_lo, r8_hi, seed ) call toeplitz_5diag_matrix ( n, d1, d2, d3, d4, d5, a ) call r8mat_determinant ( n, a, determ2 ) norm_frobenius = r8mat_norm_fro ( n, n, a ) write ( *, '(2x,a20,2x,i4,2x,14x,2x,g14.6,2x,g14.6)' ) & title, n, determ2, norm_frobenius c c TOEPLITZ_5S c title = 'TOEPLITZ_5S' row_num = 5 col_num = 5 n = row_num * col_num r8_lo = -5.0D+00 r8_hi = +5.0D+00 seed = 123456789 alpha = r8_uniform_ab ( r8_lo, r8_hi, seed ) beta = r8_uniform_ab ( r8_lo, r8_hi, seed ) gam = r8_uniform_ab ( r8_lo, r8_hi, seed ) call toeplitz_5s_matrix ( row_num, col_num, alpha, beta, & gam, n, a ) call r8mat_determinant ( n, a, determ2 ) norm_frobenius = r8mat_norm_fro ( n, n, a ) write ( *, '(2x,a20,2x,i4,2x,14x,2x,g14.6,2x,g14.6)' ) & title, n, determ2, norm_frobenius c c toeplitz_spd c title = 'toeplitz_spd' m = 3 n = 5 r8_lo = -5.0D+00 r8_hi = +5.0D+00 seed = 123456789 call r8vec_uniform_ab ( m, r8_lo, r8_hi, seed, x ) call r8vec_uniform_ab ( m, r8_lo, r8_hi, seed, y ) y_sum = r8vec_sum ( m, y ) do i = 1, m y(i) = y(i) / y_sum end do call toeplitz_spd_matrix ( m, n, x, y, a ) call r8mat_determinant ( n, a, determ2 ) norm_frobenius = r8mat_norm_fro ( n, n, a ) write ( *, '(2x,a20,2x,i4,2x,14x,2x,g14.6,2x,g14.6)' ) & title, n, determ2, norm_frobenius c c TOURNAMENT_RANDOM c title = 'TOURNAMENT_RANDOM' n = 5 key = 123456789 call tournament_random_matrix ( n, key, a ) call tournament_random_determinant ( n, key, determ1 ) call r8mat_determinant ( n, a, determ2 ) norm_frobenius = r8mat_norm_fro ( n, n, a ) write ( *, '(2x,a20,2x,i4,2x,g14.6,2x,g14.6,2x,g14.6)' ) & title, n, determ1, determ2, norm_frobenius c c TRANSITION_RANDOM c title = 'TRANSITION_RANDOM' n = 5 key = 123456789 call transition_random_matrix ( n, key, a ) call r8mat_determinant ( n, a, determ2 ) norm_frobenius = r8mat_norm_fro ( n, n, a ) write ( *, '(2x,a20,2x,i4,2x,14x,2x,g14.6,2x,g14.6)' ) & title, n, determ2, norm_frobenius c c TRENCH c title = 'TRENCH' n = 5 r8_lo = -5.0D+00 r8_hi = +5.0D+00 seed = 123456789 alpha = r8_uniform_ab ( r8_lo, r8_hi, seed ) call trench_matrix ( alpha, n, n, a ) call r8mat_determinant ( n, a, determ2 ) norm_frobenius = r8mat_norm_fro ( n, n, a ) write ( *, '(2x,a20,2x,i4,2x,14x,2x,g14.6,2x,g14.6)' ) & title, n, determ2, norm_frobenius c c TRI_UPPER c title = 'TRI_UPPER' n = 5 r8_lo = -5.0D+00 r8_hi = +5.0D+00 seed = 123456789 alpha = r8_uniform_ab ( r8_lo, r8_hi, seed ) call tri_upper_matrix ( alpha, n, a ) call tri_upper_determinant ( alpha, n, determ1 ) call r8mat_determinant ( n, a, determ2 ) norm_frobenius = r8mat_norm_fro ( n, n, a ) write ( *, '(2x,a20,2x,i4,2x,g14.6,2x,g14.6,2x,g14.6)' ) & title, n, determ1, determ2, norm_frobenius c c TRIS c title = 'TRIS' n = 5 r8_lo = -5.0D+00 r8_hi = +5.0D+00 seed = 123456789 alpha = r8_uniform_ab ( r8_lo, r8_hi, seed ) beta = r8_uniform_ab ( r8_lo, r8_hi, seed ) gam = r8_uniform_ab ( r8_lo, r8_hi, seed ) call tris_matrix ( n, n, alpha, beta, gam, a ) call tris_determinant ( n, alpha, beta, gam, determ1 ) call r8mat_determinant ( n, a, determ2 ) norm_frobenius = r8mat_norm_fro ( n, n, a ) write ( *, '(2x,a20,2x,i4,2x,g14.6,2x,g14.6,2x,g14.6)' ) & title, n, determ1, determ2, norm_frobenius c c TRIV c title = 'TRIV' n = 5 r8_lo = -5.0D+00 r8_hi = +5.0D+00 seed = 123456789 call r8vec_uniform_ab ( n - 1, r8_lo, r8_hi, seed, x ) call r8vec_uniform_ab ( n, r8_lo, r8_hi, seed, y ) call r8vec_uniform_ab ( n - 1, r8_lo, r8_hi, seed, z ) call triv_matrix ( n, x, y, z, a ) call triv_determinant ( n, x, y, z, determ1 ) call r8mat_determinant ( n, a, determ2 ) norm_frobenius = r8mat_norm_fro ( n, n, a ) write ( *, '(2x,a20,2x,i4,2x,g14.6,2x,g14.6,2x,g14.6)' ) & title, n, determ1, determ2, norm_frobenius c c TRIW c title = 'TRIW' n = 5 r8_lo = -5.0D+00 r8_hi = +5.0D+00 i4_lo = 0 i4_hi = n - 1 seed = 123456789 k = i4_uniform_ab ( i4_lo, i4_hi, seed ) alpha = r8_uniform_ab ( r8_lo, r8_hi, seed ) call triw_matrix ( alpha, k, n, a ) call triw_determinant ( alpha, k, n, determ1 ) call r8mat_determinant ( n, a, determ2 ) norm_frobenius = r8mat_norm_fro ( n, n, a ) write ( *, '(2x,a20,2x,i4,2x,g14.6,2x,g14.6,2x,g14.6)' ) & title, n, determ1, determ2, norm_frobenius c c UPSHIFT c title = 'UPSHIFT' n = 5 call upshift_matrix ( n, a ) call upshift_determinant ( n, determ1 ) call r8mat_determinant ( n, a, determ2 ) norm_frobenius = r8mat_norm_fro ( n, n, a ) write ( *, '(2x,a20,2x,i4,2x,g14.6,2x,g14.6,2x,g14.6)' ) & title, n, determ1, determ2, norm_frobenius c c VAND1 c title = 'VAND1' n = 5 r8_lo = -5.0D+00 r8_hi = +5.0D+00 seed = 123456789 call r8vec_uniform_ab ( n, r8_lo, r8_hi, seed, x ) call vand1_matrix ( n, x, a ) call vand1_determinant ( n, x, determ1 ) call r8mat_determinant ( n, a, determ2 ) norm_frobenius = r8mat_norm_fro ( n, n, a ) write ( *, '(2x,a20,2x,i4,2x,g14.6,2x,g14.6,2x,g14.6)' ) & title, n, determ1, determ2, norm_frobenius c c VAND2 c title = 'VAND2' n = 5 r8_lo = -5.0D+00 r8_hi = +5.0D+00 seed = 123456789 call r8vec_uniform_ab ( n, r8_lo, r8_hi, seed, x ) call vand2_matrix ( n, x, a ) call vand2_determinant ( n, x, determ1 ) call r8mat_determinant ( n, a, determ2 ) norm_frobenius = r8mat_norm_fro ( n, n, a ) write ( *, '(2x,a20,2x,i4,2x,g14.6,2x,g14.6,2x,g14.6)' ) & title, n, determ1, determ2, norm_frobenius c c WATHEN c title = 'WATHEN' row_num = 4 col_num = 4 call wathen_order ( row_num, col_num, n ) call wathen_matrix ( row_num, col_num, n, a ) call r8mat_determinant ( n, a, determ2 ) call r8mat_determinant ( n, a, determ2 ) norm_frobenius = r8mat_norm_fro ( n, n, a ) write ( *, '(2x,a20,2x,i4,2x,14x,2x,g14.6,2x,g14.6)' ) & title, n, determ2, norm_frobenius c c WILK03 c title = 'WILK03' n = 3 call wilk03_matrix ( a ) call wilk03_determinant ( determ1 ) call r8mat_determinant ( n, a, determ2 ) norm_frobenius = r8mat_norm_fro ( n, n, a ) write ( *, '(2x,a20,2x,i4,2x,g14.6,2x,g14.6,2x,g14.6)' ) & title, n, determ1, determ2, norm_frobenius c c WILK04 c title = 'WILK04' n = 4 call wilk04_matrix ( a ) call wilk04_determinant ( determ1 ) call r8mat_determinant ( n, a, determ2 ) norm_frobenius = r8mat_norm_fro ( n, n, a ) write ( *, '(2x,a20,2x,i4,2x,g14.6,2x,g14.6,2x,g14.6)' ) & title, n, determ1, determ2, norm_frobenius c c WILK05 c title = 'WILK05' n = 5 call wilk05_matrix ( a ) call wilk05_determinant ( determ1 ) call r8mat_determinant ( n, a, determ2 ) norm_frobenius = r8mat_norm_fro ( n, n, a ) write ( *, '(2x,a20,2x,i4,2x,g14.6,2x,g14.6,2x,g14.6)' ) & title, n, determ1, determ2, norm_frobenius c c WILK12 c title = 'WILK12' n = 12 call wilk12_matrix ( a ) call wilk12_determinant ( determ1 ) call r8mat_determinant ( n, a, determ2 ) norm_frobenius = r8mat_norm_fro ( n, n, a ) write ( *, '(2x,a20,2x,i4,2x,g14.6,2x,g14.6,2x,g14.6)' ) & title, n, determ1, determ2, norm_frobenius c c WILK20 c title = 'WILK20' n = 20 r8_lo = -5.0D+00 r8_hi = +5.0D+00 seed = 123456789 alpha = r8_uniform_ab ( r8_lo, r8_hi, seed ) call wilk20_matrix ( alpha, a ) call r8mat_determinant ( n, a, determ2 ) norm_frobenius = r8mat_norm_fro ( n, n, a ) write ( *, '(2x,a20,2x,i4,2x,14x,2x,g14.6,2x,g14.6)' ) & title, n, determ2, norm_frobenius c c WILK21 c title = 'WILK21' n = 21 call wilk21_matrix ( n, a ) call wilk21_determinant ( n, determ1 ) call r8mat_determinant ( n, a, determ2 ) norm_frobenius = r8mat_norm_fro ( n, n, a ) write ( *, '(2x,a20,2x,i4,2x,g14.6,2x,g14.6,2x,g14.6)' ) & title, n, determ1, determ2, norm_frobenius c c WILSON c title = 'WILSON' n = 4 call wilson_matrix ( a ) call wilson_determinant ( n, determ1 ) call r8mat_determinant ( n, a, determ2 ) norm_frobenius = r8mat_norm_fro ( n, n, a ) write ( *, '(2x,a20,2x,i4,2x,g14.6,2x,g14.6,2x,g14.6)' ) & title, n, determ1, determ2, norm_frobenius c c ZERO c title = 'ZERO' n = 5 call zero_matrix ( n, n, a ) call zero_determinant ( n, determ1 ) call r8mat_determinant ( n, a, determ2 ) norm_frobenius = r8mat_norm_fro ( n, n, a ) write ( *, '(2x,a20,2x,i4,2x,g14.6,2x,g14.6,2x,g14.6)' ) & title, n, determ1, determ2, norm_frobenius c c ZIELKE c title = 'ZIELKE' n = 5 r8_lo = -5.0D+00 r8_hi = +5.0D+00 seed = 123456789 d1 = r8_uniform_ab ( r8_lo, r8_hi, seed ) d2 = r8_uniform_ab ( r8_lo, r8_hi, seed ) d3 = r8_uniform_ab ( r8_lo, r8_hi, seed ) call zielke_matrix ( n, d1, d2, d3, a ) call r8mat_determinant ( n, a, determ2 ) norm_frobenius = r8mat_norm_fro ( n, n, a ) write ( *, '(2x,a20,2x,i4,2x,14x,2x,g14.6,2x,g14.6)' ) & title, n, determ2, norm_frobenius return end subroutine test_eigen_left ( ) c*********************************************************************72 c cc test_eigen_left() tests left eigensystems. c c Licensing: c c This code is distributed under the MIT license. c c Modified: c c 15 March 2015 c c Author: c c John Burkardt c implicit none integer n_max parameter ( n_max = 25 ) double precision a(n_max,n_max) double precision alpha double precision beta double precision d(n_max) double precision error_frobenius integer i1 integer i4_hi integer i4_lo integer i4_uniform_ab integer k integer key double precision lambda(n_max) integer n double precision norm_frobenius double precision r8_hi double precision r8_lo double precision r8_uniform_ab double precision r8mat_norm_fro integer seed character * ( 20 ) title double precision x(n_max,n_max) write ( *, '(a)' ) ' ' write ( *, '(a)' ) 'test_eigen_left():' write ( *, '(a)' ) & ' Compute the Frobenius norm of the eigenvalue error:' write ( *, '(a)' ) ' X * A - LAMBDA * X' write ( *, '(a)' ) & ' given K left eigenvectors X and eigenvalues LAMBDA.' write ( *, '(a)' ) ' ' write ( *, '(a)' ) & ' Title N K ||A||' & // ' ||X*A-Lambda*X||' write ( *, '(a)' ) ' ' c c A123 c title = 'A123' n = 3 k = 3 call a123_matrix ( a ) call a123_eigenvalues ( lambda ) call a123_eigen_left ( x ) call r8mat_is_eigen_left ( n, k, a, x, lambda, error_frobenius ) norm_frobenius = r8mat_norm_fro ( n, n, a ) write ( *, '(2x,a20,2x,i4,2x,i4,2x,g14.6,2x,g14.6)' ) & title, n, k, norm_frobenius, error_frobenius c c CARRY c title = 'CARRY' n = 5 k = 5 i4_lo = 2 i4_hi = 20 seed = 123456789 i1 = i4_uniform_ab ( i4_lo, i4_hi, seed ) call carry_matrix ( n, i1, a ) call carry_eigenvalues ( n, i1, lambda ) call carry_eigen_left ( n, i1, x ) call r8mat_is_eigen_left ( n, k, a, x, lambda, error_frobenius ) norm_frobenius = r8mat_norm_fro ( n, n, a ) write ( *, '(2x,a20,2x,i4,2x,i4,2x,g14.6,2x,g14.6)' ) & title, n, k, norm_frobenius, error_frobenius c c CHOW c title = 'CHOW' n = 5 k = 5 r8_lo = -5.0D+00 r8_hi = +5.0D+00 seed = 123456789 alpha = r8_uniform_ab ( r8_lo, r8_hi, seed ) beta = r8_uniform_ab ( r8_lo, r8_hi, seed ) call chow_matrix ( alpha, beta, n, n, a ) call chow_eigenvalues ( alpha, beta, n, lambda ) call chow_eigen_left ( alpha, beta, n, x ) call r8mat_is_eigen_left ( n, k, a, x, lambda, error_frobenius ) norm_frobenius = r8mat_norm_fro ( n, n, a ) write ( *, '(2x,a20,2x,i4,2x,i4,2x,g14.6,2x,g14.6)' ) & title, n, k, norm_frobenius, error_frobenius c c DIAGONAL c title = 'DIAGONAL' n = 5 k = 5 r8_lo = -5.0D+00 r8_hi = +5.0D+00 seed = 123456789 call r8vec_uniform_ab ( n, r8_lo, r8_hi, seed, d ) call diagonal_matrix ( n, n, d, a ) call diagonal_eigenvalues ( n, d, lambda ) call diagonal_eigen_left ( n, d, x ) call r8mat_is_eigen_left ( n, k, a, x, lambda, error_frobenius ) norm_frobenius = r8mat_norm_fro ( n, n, a ) write ( *, '(2x,a20,2x,i4,2x,i4,2x,g14.6,2x,g14.6)' ) & title, n, k, norm_frobenius, error_frobenius c c ROSSER1 c title = 'ROSSER1' n = 8 k = 8 call rosser1_matrix ( a ) call rosser1_eigenvalues ( lambda ) call rosser1_eigen_left ( x ) call r8mat_is_eigen_left ( n, k, a, x, lambda, error_frobenius ) norm_frobenius = r8mat_norm_fro ( n, n, a ) write ( *, '(2x,a20,2x,i4,2x,i4,2x,g14.6,2x,g14.6)' ) & title, n, k, norm_frobenius, error_frobenius c c SYMM_RANDOM c title = 'SYMM_RANDOM' n = 5 k = 5 r8_lo = -5.0D+00 r8_hi = +5.0D+00 seed = 123456789 call r8vec_uniform_ab ( n, r8_lo, r8_hi, seed, d ) key = 123456789 call symm_random_matrix ( n, d, key, a ) call symm_random_eigenvalues ( n, d, key, lambda ) call symm_random_eigen_left ( n, d, key, x ) call r8mat_is_eigen_left ( n, k, a, x, lambda, error_frobenius ) norm_frobenius = r8mat_norm_fro ( n, n, a ) write ( *, '(2x,a20,2x,i4,2x,i4,2x,g14.6,2x,g14.6)' ) & title, n, k, norm_frobenius, error_frobenius return end subroutine test_eigen_right ( ) c*********************************************************************72 c cc test_eigen_right() tests right eigensystems. c c Licensing: c c This code is distributed under the MIT license. c c Modified: c c 14 April 2015 c c Author: c c John Burkardt c implicit none integer n_max parameter ( n_max = 25 ) double precision a(n_max,n_max) double precision alpha double precision beta double precision d(n_max) double precision error_frobenius integer i1 integer i4_hi integer i4_lo integer i4_uniform_ab integer k integer key double precision lambda(n_max) integer n double precision norm_frobenius double precision r8_hi double precision r8_lo double precision r8_uniform_ab double precision r8mat_norm_fro integer rank integer seed character * ( 20 ) title double precision v1(n_max) double precision v2(n_max) double precision v3(n_max) double precision x(n_max,n_max) write ( *, '(a)' ) ' ' write ( *, '(a)' ) 'TEST_EIGEN_RIGHT' write ( *, '(a)' ) & ' Compute the Frobenius norm of the eigenvalue error:' write ( *, '(a)' ) ' A * X - X * LAMBDA' write ( *, '(a)' ) & ' given K right eigenvectors X and eigenvalues LAMBDA.' write ( *, '(a)' ) ' ' write ( *, '(a)' ) & ' Title N K ||A||' & // ' ||A*X-X*Lambda||' write ( *, '(a)' ) ' ' c c A123 c title = 'A123' n = 3 k = 3 call a123_matrix ( a ) call a123_eigenvalues ( lambda ) call a123_eigen_right ( x ) call r8mat_is_eigen_right ( n, k, a, x, lambda, error_frobenius ) norm_frobenius = r8mat_norm_fro ( n, n, a ) write ( *, '(2x,a20,2x,i4,2x,i4,2x,g14.6,2x,g14.6)' ) & title, n, k, norm_frobenius, error_frobenius c c BAB c title = 'BAB' n = 5 k = 5 r8_lo = -5.0D+00 r8_hi = +5.0D+00 seed = 123456789 alpha = r8_uniform_ab ( r8_lo, r8_hi, seed ) beta = r8_uniform_ab ( r8_lo, r8_hi, seed ) call bab_matrix ( n, alpha, beta, a ) call bab_eigenvalues ( n, alpha, beta, lambda ) call bab_eigen_right ( n, alpha, beta, x ) call r8mat_is_eigen_right ( n, k, a, x, lambda, error_frobenius ) norm_frobenius = r8mat_norm_fro ( n, n, a ) write ( *, '(2x,a20,2x,i4,2x,i4,2x,g14.6,2x,g14.6)' ) & title, n, k, norm_frobenius, error_frobenius c c BODEWIG c title = 'BODEWIG' n = 4 k = 4 call bodewig_matrix ( a ) call bodewig_eigenvalues ( lambda ) call bodewig_eigen_right ( x ) call r8mat_is_eigen_right ( n, k, a, x, lambda, error_frobenius ) norm_frobenius = r8mat_norm_fro ( n, n, a ) write ( *, '(2x,a20,2x,i4,2x,i4,2x,g14.6,2x,g14.6)' ) & title, n, k, norm_frobenius, error_frobenius c c CARRY c title = 'CARRY' n = 5 k = 5 i4_lo = 2 i4_hi = 20 seed = 123456789 i1 = i4_uniform_ab ( i4_lo, i4_hi, seed ) call carry_matrix ( n, i1, a ) call carry_eigenvalues ( n, i1, lambda ) call carry_eigen_right ( n, i1, x ) call r8mat_is_eigen_right ( n, k, a, x, lambda, error_frobenius ) norm_frobenius = r8mat_norm_fro ( n, n, a ) write ( *, '(2x,a20,2x,i4,2x,i4,2x,g14.6,2x,g14.6)' ) & title, n, k, norm_frobenius, error_frobenius c c CHOW c title = 'CHOW' n = 5 k = 5 r8_lo = -5.0D+00 r8_hi = +5.0D+00 seed = 123456789 alpha = r8_uniform_ab ( r8_lo, r8_hi, seed ) beta = r8_uniform_ab ( r8_lo, r8_hi, seed ) call chow_matrix ( alpha, beta, n, n, a ) call chow_eigenvalues ( alpha, beta, n, lambda ) call chow_eigen_right ( alpha, beta, n, x ) call r8mat_is_eigen_right ( n, k, a, x, lambda, error_frobenius ) norm_frobenius = r8mat_norm_fro ( n, n, a ) write ( *, '(2x,a20,2x,i4,2x,i4,2x,g14.6,2x,g14.6)' ) & title, n, k, norm_frobenius, error_frobenius c c COMBIN c title = 'COMBIN' n = 5 k = 5 r8_lo = -5.0D+00 r8_hi = +5.0D+00 seed = 123456789 alpha = r8_uniform_ab ( r8_lo, r8_hi, seed ) beta = r8_uniform_ab ( r8_lo, r8_hi, seed ) call combin_matrix ( alpha, beta, n, a ) call combin_eigenvalues ( alpha, beta, n, lambda ) call combin_eigen_right ( alpha, beta, n, x ) call r8mat_is_eigen_right ( n, k, a, x, lambda, error_frobenius ) norm_frobenius = r8mat_norm_fro ( n, n, a ) write ( *, '(2x,a20,2x,i4,2x,i4,2x,g14.6,2x,g14.6)' ) & title, n, k, norm_frobenius, error_frobenius c c DIF2 c title = 'DIF2' n = 5 k = 5 call dif2_matrix ( n, n, a ) call dif2_eigenvalues ( n, lambda ) call dif2_eigen_right ( n, x ) call r8mat_is_eigen_right ( n, k, a, x, lambda, error_frobenius ) norm_frobenius = r8mat_norm_fro ( n, n, a ) write ( *, '(2x,a20,2x,i4,2x,i4,2x,g14.6,2x,g14.6)' ) & title, n, k, norm_frobenius, error_frobenius c c EXCHANGE c title = 'EXCHANGE' n = 5 k = 5 call exchange_matrix ( n, n, a ) call exchange_eigenvalues ( n, lambda ) call exchange_eigen_right ( n, x ) call r8mat_is_eigen_right ( n, k, a, x, lambda, error_frobenius ) norm_frobenius = r8mat_norm_fro ( n, n, a ) write ( *, '(2x,a20,2x,i4,2x,i4,2x,g14.6,2x,g14.6)' ) & title, n, k, norm_frobenius, error_frobenius c c IDEM_RANDOM c title = 'IDEM_RANDOM' n = 5 k = 5 rank = 3 key = 123456789 call idem_random_matrix ( n, rank, key, a ) call idem_random_eigenvalues ( n, rank, key, lambda ) call idem_random_eigen_right ( n, rank, key, x ) call r8mat_is_eigen_right ( n, k, a, x, lambda, error_frobenius ) norm_frobenius = r8mat_norm_fro ( n, n, a ) write ( *, '(2x,a20,2x,i4,2x,i4,2x,g14.6,2x,g14.6)' ) & title, n, k, norm_frobenius, error_frobenius c c IDENTITY c title = 'IDENTITY' n = 5 k = 5 call identity_matrix ( n, n, a ) call identity_eigenvalues ( n, lambda ) call identity_eigen_right ( n, x ) call r8mat_is_eigen_right ( n, k, a, x, lambda, error_frobenius ) norm_frobenius = r8mat_norm_fro ( n, n, a ) write ( *, '(2x,a20,2x,i4,2x,i4,2x,g14.6,2x,g14.6)' ) & title, n, k, norm_frobenius, error_frobenius c c ILL3 c title = 'ILL3' n = 3 k = 3 call ill3_matrix ( a ) call ill3_eigenvalues ( lambda ) call ill3_eigen_right ( x ) call r8mat_is_eigen_right ( n, k, a, x, lambda, error_frobenius ) norm_frobenius = r8mat_norm_fro ( n, n, a ) write ( *, '(2x,a20,2x,i4,2x,i4,2x,g14.6,2x,g14.6)' ) & title, n, k, norm_frobenius, error_frobenius c c KERSHAW c title = 'KERSHAW' n = 4 k = 4 call kershaw_matrix ( a ) call kershaw_eigenvalues ( lambda ) call kershaw_eigen_right ( x ) call r8mat_is_eigen_right ( n, k, a, x, lambda, error_frobenius ) norm_frobenius = r8mat_norm_fro ( n, n, a ) write ( *, '(2x,a20,2x,i4,2x,i4,2x,g14.6,2x,g14.6)' ) & title, n, k, norm_frobenius, error_frobenius c c KMS c Eigenvalue information requires 0 <= ALPHA <= 1. c title = 'KMS' n = 5 k = 5 r8_lo = 0.0D+00 r8_hi = 1.0D+00 seed = 123456789 alpha = r8_uniform_ab ( r8_lo, r8_hi, seed ) call kms_matrix ( alpha, n, n, a ) call kms_eigenvalues ( alpha, n, lambda ) call kms_eigen_right ( alpha, n, x ) call r8mat_is_eigen_right ( n, k, a, x, lambda, error_frobenius ) norm_frobenius = r8mat_norm_fro ( n, n, a ) write ( *, '(2x,a20,2x,i4,2x,i4,2x,g14.6,2x,g14.6)' ) & title, n, k, norm_frobenius, error_frobenius c c LINE_ADJ c title = 'LINE_ADJ' n = 5 k = 5 call line_adj_matrix ( n, a ) call line_adj_eigenvalues ( n, lambda ) call line_adj_eigen_right ( n, x ) call r8mat_is_eigen_right ( n, k, a, x, lambda, error_frobenius ) norm_frobenius = r8mat_norm_fro ( n, n, a ) write ( *, '(2x,a20,2x,i4,2x,i4,2x,g14.6,2x,g14.6)' ) & title, n, k, norm_frobenius, error_frobenius c c LINE_LOOP_ADJ c title = 'LINE_LOOP_ADJ' n = 5 k = 5 call line_loop_adj_matrix ( n, a ) call line_loop_adj_eigenvalues ( n, lambda ) call line_loop_adj_eigen_right ( n, x ) call r8mat_is_eigen_right ( n, k, a, x, lambda, error_frobenius ) norm_frobenius = r8mat_norm_fro ( n, n, a ) write ( *, '(2x,a20,2x,i4,2x,i4,2x,g14.6,2x,g14.6)' ) & title, n, k, norm_frobenius, error_frobenius c c ONE c title = 'ONE' n = 5 k = 5 call one_matrix ( n, n, a ) call one_eigenvalues ( n, lambda ) call one_eigen_right ( n, x ) call r8mat_is_eigen_right ( n, k, a, x, lambda, error_frobenius ) norm_frobenius = r8mat_norm_fro ( n, n, a ) write ( *, '(2x,a20,2x,i4,2x,i4,2x,g14.6,2x,g14.6)' ) & title, n, k, norm_frobenius, error_frobenius c c ORTEGA c title = 'ORTEGA' n = 5 k = n r8_lo = -5.0D+00 r8_hi = +5.0D+00 seed = 123456789 call r8vec_uniform_ab ( n, r8_lo, r8_hi, seed, v1 ) call r8vec_uniform_ab ( n, r8_lo, r8_hi, seed, v2 ) call r8vec_uniform_ab ( n, r8_lo, r8_hi, seed, v3 ) call ortega_matrix ( n, v1, v2, v3, a ) call ortega_eigenvalues ( n, v1, v2, v3, lambda ) call ortega_eigen_right ( n, v1, v2, v3, x ) call r8mat_is_eigen_right ( n, k, a, x, lambda, error_frobenius ) norm_frobenius = r8mat_norm_fro ( n, n, a ) write ( *, '(2x,a20,2x,i4,2x,i4,2x,g14.6,2x,g14.6)' ) & title, n, k, norm_frobenius, error_frobenius c c OTO c title = 'OTO' n = 5 k = 5 call oto_matrix ( n, n, a ) call oto_eigenvalues ( n, lambda ) call oto_eigen_right ( n, x ) call r8mat_is_eigen_right ( n, k, a, x, lambda, error_frobenius ) norm_frobenius = r8mat_norm_fro ( n, n, a ) write ( *, '(2x,a20,2x,i4,2x,i4,2x,g14.6,2x,g14.6)' ) & title, n, k, norm_frobenius, error_frobenius c c spd_random c title = 'spd_random' n = 5 k = 5 key = 123456789 call spd_random_matrix ( n, key, a ) call spd_random_eigenvalues ( n, key, lambda ) call spd_random_eigen_right ( n, key, x ) call r8mat_is_eigen_right ( n, k, a, x, lambda, error_frobenius ) norm_frobenius = r8mat_norm_fro ( n, n, a ) write ( *, '(2x,a20,2x,i4,2x,i4,2x,g14.6,2x,g14.6)' ) & title, n, k, norm_frobenius, error_frobenius c c PEI c title = 'PEI' n = 5 k = 5 r8_lo = -5.0D+00 r8_hi = +5.0D+00 seed = 123456789 alpha = r8_uniform_ab ( r8_lo, r8_hi, seed ) call pei_matrix ( alpha, n, a ) call pei_eigenvalues ( alpha, n, lambda ) call pei_eigen_right ( alpha, n, x ) call r8mat_is_eigen_right ( n, k, a, x, lambda, error_frobenius ) norm_frobenius = r8mat_norm_fro ( n, n, a ) write ( *, '(2x,a20,2x,i4,2x,i4,2x,g14.6,2x,g14.6)' ) & title, n, k, norm_frobenius, error_frobenius c c RODMAN c title = 'RODMAN' n = 5 k = 5 r8_lo = -5.0D+00 r8_hi = +5.0D+00 seed = 123456789 alpha = r8_uniform_ab ( r8_lo, r8_hi, seed ) call rodman_matrix ( n, n, alpha, a ) call rodman_eigenvalues ( n, alpha, lambda ) call rodman_eigen_right ( n, alpha, x ) call r8mat_is_eigen_right ( n, k, a, x, lambda, error_frobenius ) norm_frobenius = r8mat_norm_fro ( n, n, a ) write ( *, '(2x,a20,2x,i4,2x,i4,2x,g14.6,2x,g14.6)' ) & title, n, k, norm_frobenius, error_frobenius c c ROSSER1 c title = 'ROSSER1' n = 8 k = 8 call rosser1_matrix ( a ) call rosser1_eigenvalues ( lambda ) call rosser1_eigen_right ( x ) call r8mat_is_eigen_right ( n, k, a, x, lambda, error_frobenius ) norm_frobenius = r8mat_norm_fro ( n, n, a ) write ( *, '(2x,a20,2x,i4,2x,i4,2x,g14.6,2x,g14.6)' ) & title, n, k, norm_frobenius, error_frobenius c c RUTIS1 c title = 'RUTIS1' n = 4 k = 4 call rutis1_matrix ( a ) call rutis1_eigenvalues ( lambda ) call rutis1_eigen_right ( x ) call r8mat_is_eigen_right ( n, k, a, x, lambda, error_frobenius ) norm_frobenius = r8mat_norm_fro ( n, n, a ) write ( *, '(2x,a20,2x,i4,2x,i4,2x,g14.6,2x,g14.6)' ) & title, n, k, norm_frobenius, error_frobenius c c RUTIS2 c title = 'RUTIS2' n = 4 k = 4 call rutis2_matrix ( a ) call rutis2_eigenvalues ( lambda ) call rutis2_eigen_right ( x ) call r8mat_is_eigen_right ( n, k, a, x, lambda, error_frobenius ) norm_frobenius = r8mat_norm_fro ( n, n, a ) write ( *, '(2x,a20,2x,i4,2x,i4,2x,g14.6,2x,g14.6)' ) & title, n, k, norm_frobenius, error_frobenius c c RUTIS3 c COMPLEX eigenvalues cannot be handled yetc c if ( .false. ) then title = 'RUTIS3' n = 4 k = 4 call rutis3_matrix ( a ) call rutis3_eigenvalues ( lambda ) call rutis3_eigen_right ( x ) c call r8mat_is_eigen_right ( n, k, a, x, lambda, error_frobenius ) norm_frobenius = r8mat_norm_fro ( n, n, a ) write ( *, '(2x,a20,2x,i4,2x,i4,2x,g14.6,2x,g14.6)' ) & title, n, k, norm_frobenius, error_frobenius end if c c RUTIS5 c title = 'RUTIS5' n = 4 k = 4 call rutis5_matrix ( a ) call rutis5_eigenvalues ( lambda ) call rutis5_eigen_right ( x ) call r8mat_is_eigen_right ( n, k, a, x, lambda, error_frobenius ) norm_frobenius = r8mat_norm_fro ( n, n, a ) write ( *, '(2x,a20,2x,i4,2x,i4,2x,g14.6,2x,g14.6)' ) & title, n, k, norm_frobenius, error_frobenius c c SYLVESTER_KAC c title = 'SYLVESTER_KAC' n = 5 k = 5 call sylvester_kac_matrix ( n, a ) call sylvester_kac_eigenvalues ( n, lambda ) call sylvester_kac_eigen_right ( n, x ) call r8mat_is_eigen_right ( n, k, a, x, lambda, error_frobenius ) norm_frobenius = r8mat_norm_fro ( n, n, a ) write ( *, '(2x,a20,2x,i4,2x,i4,2x,g14.6,2x,g14.6)' ) & title, n, k, norm_frobenius, error_frobenius c c SYMM_RANDOM c title = 'SYMM_RANDOM' n = 5 k = 5 r8_lo = -5.0D+00 r8_hi = +5.0D+00 seed = 123456789 call r8vec_uniform_ab ( n, r8_lo, r8_hi, seed, d ) key = 123456789 call symm_random_matrix ( n, d, key, a ) call symm_random_eigenvalues ( n, d, key, lambda ) call symm_random_eigen_right ( n, d, key, x ) call r8mat_is_eigen_right ( n, k, a, x, lambda, error_frobenius ) norm_frobenius = r8mat_norm_fro ( n, n, a ) write ( *, '(2x,a20,2x,i4,2x,i4,2x,g14.6,2x,g14.6)' ) & title, n, k, norm_frobenius, error_frobenius c c WILK12 c title = 'WILK12' n = 12 k = 12 call wilk12_matrix ( a ) call wilk12_eigenvalues ( lambda ) call wilk12_eigen_right ( x ) call r8mat_is_eigen_right ( n, k, a, x, lambda, error_frobenius ) norm_frobenius = r8mat_norm_fro ( n, n, a ) write ( *, '(2x,a20,2x,i4,2x,i4,2x,g14.6,2x,g14.6)' ) & title, n, k, norm_frobenius, error_frobenius c c WILSON c title = 'WILSON' n = 4 k = 4 call wilson_matrix ( a ) call wilson_eigenvalues ( lambda ) call wilson_eigen_right ( x ) call r8mat_is_eigen_right ( n, k, a, x, lambda, error_frobenius ) norm_frobenius = r8mat_norm_fro ( n, n, a ) write ( *, '(2x,a20,2x,i4,2x,i4,2x,g14.6,2x,g14.6)' ) & title, n, k, norm_frobenius, error_frobenius c c ZERO c title = 'ZERO' n = 5 k = 5 call zero_matrix ( n, n, a ) call zero_eigenvalues ( n, lambda ) call zero_eigen_right ( n, x ) call r8mat_is_eigen_right ( n, k, a, x, lambda, error_frobenius ) norm_frobenius = r8mat_norm_fro ( n, n, a ) write ( *, '(2x,a20,2x,i4,2x,i4,2x,g14.6,2x,g14.6)' ) & title, n, k, norm_frobenius, error_frobenius return end subroutine test_inverse ( ) c*********************************************************************72 c cc test_inverse() tests the inverse computations. c c Licensing: c c This code is distributed under the MIT license. c c Modified: c c 16 April 2015 c c Author: c c John Burkardt c implicit none integer n_max parameter ( n_max = 25 ) double precision a(n_max,n_max) double precision alpha double precision b(n_max,n_max) double precision beta double precision c(n_max,n_max) double precision d(n_max) double precision error_ab double precision error_ac double precision gam integer i integer i4_hi integer i4_lo integer i4_uniform_ab integer k integer key integer n double precision norm_frobenius integer pivot(n_max) double precision r8_hi double precision r8_lo double precision r8_uniform_ab double precision r8mat_norm_fro integer seed character * ( 20 ) title double precision v1(n_max) double precision v2(n_max) double precision v3(n_max) double precision x(n_max) integer x_n double precision y(n_max) integer y_n double precision z(n_max) write ( *, '(a)' ) ' ' write ( *, '(a)' ) 'TEST_INVERSE' write ( *, '(a)' ) ' A = a test matrix of order N;' write ( *, '(a)' ) ' B = inverse as computed by a routine.' write ( *, '(a)' ) ' C = inverse as computed by R8MAT_INVERSE.' write ( *, '(a)' ) ' ' write ( *, '(a)' ) ' ||A|| = Frobenius norm of A.' write ( *, '(a)' ) ' ||I-AB|| = Frobenius norm of I-A*B.' write ( *, '(a)' ) ' ||I-AC|| = Frobenius norm of I-A*C.' write ( *, '(a)' ) ' ' write ( *, '(a)' ) ' Title N ' // & '||A|| ||I-AB|| ||I-AC||' write ( *, '(a)' ) ' ' c c AEGERTER c title = 'AEGERTER' n = 5 call aegerter_matrix ( n, a ) call aegerter_inverse ( n, b ) call r8mat_inverse ( n, a, c ) call r8mat_is_inverse ( n, a, b, error_ab ) call r8mat_is_inverse ( n, a, c, error_ac ) norm_frobenius = r8mat_norm_fro ( n, n, a ) write ( *, '(2x,a20,2x,i4,2x,g14.6,2x,g14.6,2x,g14.6)' ) & title, n, norm_frobenius, error_ab, error_ac c c BAB c title = 'BAB' n = 5 r8_lo = -5.0D+00 r8_hi = +5.0D+00 seed = 123456789 alpha = r8_uniform_ab ( r8_lo, r8_hi, seed ) beta = r8_uniform_ab ( r8_lo, r8_hi, seed ) call bab_matrix ( n, alpha, beta, a ) call bab_inverse ( n, alpha, beta, b ) call r8mat_inverse ( n, a, c ) call r8mat_is_inverse ( n, a, b, error_ab ) call r8mat_is_inverse ( n, a, c, error_ac ) norm_frobenius = r8mat_norm_fro ( n, n, a ) write ( *, '(2x,a20,2x,i4,2x,g14.6,2x,g14.6,2x,g14.6)' ) & title, n, norm_frobenius, error_ab, error_ac c c BAUER c title = 'BAUER' n = 6 call bauer_matrix ( a ) call bauer_inverse ( b ) call r8mat_inverse ( n, a, c ) call r8mat_is_inverse ( n, a, b, error_ab ) call r8mat_is_inverse ( n, a, c, error_ac ) norm_frobenius = r8mat_norm_fro ( n, n, a ) write ( *, '(2x,a20,2x,i4,2x,g14.6,2x,g14.6,2x,g14.6)' ) & title, n, norm_frobenius, error_ab, error_ac c c BERNSTEIN c title = 'BERNSTEIN' n = 5 call bernstein_matrix ( n, a ) call bernstein_inverse ( n, b ) call r8mat_inverse ( n, a, c ) call r8mat_is_inverse ( n, a, b, error_ab ) call r8mat_is_inverse ( n, a, c, error_ac ) norm_frobenius = r8mat_norm_fro ( n, n, a ) write ( *, '(2x,a20,2x,i4,2x,g14.6,2x,g14.6,2x,g14.6)' ) & title, n, norm_frobenius, error_ab, error_ac c c BIS c title = 'BIS' n = 5 r8_lo = -5.0D+00 r8_hi = +5.0D+00 seed = 123456789 alpha = r8_uniform_ab ( r8_lo, r8_hi, seed ) beta = r8_uniform_ab ( r8_lo, r8_hi, seed ) call bis_matrix ( alpha, beta, n, n, a ); call bis_inverse ( alpha, beta, n, b ) call r8mat_inverse ( n, a, c ) call r8mat_is_inverse ( n, a, b, error_ab ) call r8mat_is_inverse ( n, a, c, error_ac ) norm_frobenius = r8mat_norm_fro ( n, n, a ) write ( *, '(2x,a20,2x,i4,2x,g14.6,2x,g14.6,2x,g14.6)' ) & title, n, norm_frobenius, error_ab, error_ac c c BIW c title = 'BIW' n = 5 call biw_matrix ( n, a ); call biw_inverse ( n, b ) call r8mat_inverse ( n, a, c ) call r8mat_is_inverse ( n, a, b, error_ab ) call r8mat_is_inverse ( n, a, c, error_ac ) norm_frobenius = r8mat_norm_fro ( n, n, a ) write ( *, '(2x,a20,2x,i4,2x,g14.6,2x,g14.6,2x,g14.6)' ) & title, n, norm_frobenius, error_ab, error_ac c c BODEWIG c title = 'BODEWIG' n = 4 call bodewig_matrix ( a ) call bodewig_inverse ( b ) call r8mat_inverse ( n, a, c ) call r8mat_is_inverse ( n, a, b, error_ab ) call r8mat_is_inverse ( n, a, c, error_ac ) norm_frobenius = r8mat_norm_fro ( n, n, a ) write ( *, '(2x,a20,2x,i4,2x,g14.6,2x,g14.6,2x,g14.6)' ) & title, n, norm_frobenius, error_ab, error_ac c c BOOTHROYD c title = 'BOOTHROYD' n = 5 call boothroyd_matrix ( n, a ) call boothroyd_inverse ( n, b ) call r8mat_inverse ( n, a, c ) call r8mat_is_inverse ( n, a, b, error_ab ) call r8mat_is_inverse ( n, a, c, error_ac ) norm_frobenius = r8mat_norm_fro ( n, n, a ) write ( *, '(2x,a20,2x,i4,2x,g14.6,2x,g14.6,2x,g14.6)' ) & title, n, norm_frobenius, error_ab, error_ac c c BORDERBAND c title = 'BORDERBAND' n = 5 call borderband_matrix ( n, a ) call borderband_inverse ( n, b ) call r8mat_inverse ( n, a, c ) call r8mat_is_inverse ( n, a, b, error_ab ) call r8mat_is_inverse ( n, a, c, error_ac ) norm_frobenius = r8mat_norm_fro ( n, n, a ) write ( *, '(2x,a20,2x,i4,2x,g14.6,2x,g14.6,2x,g14.6)' ) & title, n, norm_frobenius, error_ab, error_ac c c CARRY c title = 'CARRY' n = 5 i4_lo = 2 i4_hi = 20 seed = 123456789 k = i4_uniform_ab ( i4_lo, i4_hi, seed ) call carry_matrix ( n, k, a ) call carry_inverse ( n, k, b ) call r8mat_inverse ( n, a, c ) call r8mat_is_inverse ( n, a, b, error_ab ) call r8mat_is_inverse ( n, a, c, error_ac ) norm_frobenius = r8mat_norm_fro ( n, n, a ) write ( *, '(2x,a20,2x,i4,2x,g14.6,2x,g14.6,2x,g14.6)' ) & title, n, norm_frobenius, error_ab, error_ac c c CAUCHY c title = 'CAUCHY' n = 5 r8_lo = -5.0D+00 r8_hi = +5.0D+00 seed = 123456789 call r8vec_uniform_ab ( n, r8_lo, r8_hi, seed, x ) call r8vec_uniform_ab ( n, r8_lo, r8_hi, seed, y ) call cauchy_matrix ( n, x, y, a ) call cauchy_inverse ( n, x, y, b ) call r8mat_inverse ( n, a, c ) call r8mat_is_inverse ( n, a, b, error_ab ) call r8mat_is_inverse ( n, a, c, error_ac ) norm_frobenius = r8mat_norm_fro ( n, n, a ) write ( *, '(2x,a20,2x,i4,2x,g14.6,2x,g14.6,2x,g14.6)' ) & title, n, norm_frobenius, error_ab, error_ac c c CHEBY_T c title = 'CHEBY_T' n = 5 call cheby_t_matrix ( n, a ) call cheby_t_inverse ( n, b ) call r8mat_inverse ( n, a, c ) call r8mat_is_inverse ( n, a, b, error_ab ) call r8mat_is_inverse ( n, a, c, error_ac ) norm_frobenius = r8mat_norm_fro ( n, n, a ) write ( *, '(2x,a20,2x,i4,2x,g14.6,2x,g14.6,2x,g14.6)' ) & title, n, norm_frobenius, error_ab, error_ac c c CHEBY_U c title = 'CHEBY_U' n = 5 call cheby_u_matrix ( n, a ) call cheby_u_inverse ( n, b ) call r8mat_inverse ( n, a, c ) call r8mat_is_inverse ( n, a, b, error_ab ) call r8mat_is_inverse ( n, a, c, error_ac ) norm_frobenius = r8mat_norm_fro ( n, n, a ) write ( *, '(2x,a20,2x,i4,2x,g14.6,2x,g14.6,2x,g14.6)' ) & title, n, norm_frobenius, error_ab, error_ac c c CHEBY_VAN2 c title = 'CHEBY_VAN2' n = 5 call cheby_van2_matrix ( n, a ) call cheby_van2_inverse ( n, b ) call r8mat_inverse ( n, a, c ) call r8mat_is_inverse ( n, a, b, error_ab ) call r8mat_is_inverse ( n, a, c, error_ac ) norm_frobenius = r8mat_norm_fro ( n, n, a ) write ( *, '(2x,a20,2x,i4,2x,g14.6,2x,g14.6,2x,g14.6)' ) & title, n, norm_frobenius, error_ab, error_ac c c CHEBY_VAN3 c title = 'CHEBY_VAN3' n = 5 call cheby_van3_matrix ( n, a ) call cheby_van3_inverse ( n, b ) call r8mat_inverse ( n, a, c ) call r8mat_is_inverse ( n, a, b, error_ab ) call r8mat_is_inverse ( n, a, c, error_ac ) norm_frobenius = r8mat_norm_fro ( n, n, a ) write ( *, '(2x,a20,2x,i4,2x,g14.6,2x,g14.6,2x,g14.6)' ) & title, n, norm_frobenius, error_ab, error_ac c c CHOW c title = 'CHOW' n = 5 r8_lo = -5.0D+00 r8_hi = +5.0D+00 seed = 123456789 alpha = r8_uniform_ab ( r8_lo, r8_hi, seed ) beta = r8_uniform_ab ( r8_lo, r8_hi, seed ) call chow_matrix ( alpha, beta, n, n, a ) call chow_inverse ( alpha, beta, n, b ) call r8mat_inverse ( n, a, c ) call r8mat_is_inverse ( n, a, b, error_ab ) call r8mat_is_inverse ( n, a, c, error_ac ) norm_frobenius = r8mat_norm_fro ( n, n, a ) write ( *, '(2x,a20,2x,i4,2x,g14.6,2x,g14.6,2x,g14.6)' ) & title, n, norm_frobenius, error_ab, error_ac c c CIRCULANT c if ( .false. ) then title = 'CIRCULANT' n = 5 r8_lo = -5.0D+00 r8_hi = +5.0D+00 seed = 123456789 call r8vec_uniform_ab ( n, r8_lo, r8_hi, seed, x ) call circulant_matrix ( n, n, x, a ) c call circulant_inverse ( n, x, b ) call r8mat_inverse ( n, a, c ) call r8mat_is_inverse ( n, a, b, error_ab ) call r8mat_is_inverse ( n, a, c, error_ac ) norm_frobenius = r8mat_norm_fro ( n, n, a ) write ( *, '(2x,a20,2x,i4,2x,g14.6,2x,g14.6,2x,g14.6)' ) & title, n, norm_frobenius, error_ab, error_ac else write ( *, '(2x,a)' ) 'CIRCULANT --- NOT READY' end if c c CIRCULANT2 c title = 'CIRCULANT2' n = 5 call circulant2_matrix ( n, a ) call circulant2_inverse ( n, b ) call r8mat_inverse ( n, a, c ) call r8mat_is_inverse ( n, a, b, error_ab ) call r8mat_is_inverse ( n, a, c, error_ac ) norm_frobenius = r8mat_norm_fro ( n, n, a ) write ( *, '(2x,a20,2x,i4,2x,g14.6,2x,g14.6,2x,g14.6)' ) & title, n, norm_frobenius, error_ab, error_ac c c CLEMENT1 c title = 'CLEMENT1' n = 6 call clement1_matrix ( n, a ) call clement1_inverse ( n, b ) call r8mat_inverse ( n, a, c ) call r8mat_is_inverse ( n, a, b, error_ab ) call r8mat_is_inverse ( n, a, c, error_ac ) norm_frobenius = r8mat_norm_fro ( n, n, a ) write ( *, '(2x,a20,2x,i4,2x,g14.6,2x,g14.6,2x,g14.6)' ) & title, n, norm_frobenius, error_ab, error_ac c c CLEMENT2 c title = 'CLEMENT2' n = 6 r8_lo = -5.0D+00 r8_hi = +5.0D+00 seed = 123456789 call r8vec_uniform_ab ( n - 1, r8_lo, r8_hi, seed, x ) call r8vec_uniform_ab ( n - 1, r8_lo, r8_hi, seed, y ) call clement2_matrix ( n, x, y, a ) call clement2_inverse ( n, x, y, b ) call r8mat_inverse ( n, a, c ) call r8mat_is_inverse ( n, a, b, error_ab ) call r8mat_is_inverse ( n, a, c, error_ac ) norm_frobenius = r8mat_norm_fro ( n, n, a ) write ( *, '(2x,a20,2x,i4,2x,g14.6,2x,g14.6,2x,g14.6)' ) & title, n, norm_frobenius, error_ab, error_ac c c COMBIN c title = 'COMBIN' n = 5 r8_lo = -5.0D+00 r8_hi = +5.0D+00 seed = 123456789 alpha = r8_uniform_ab ( r8_lo, r8_hi, seed ) beta = r8_uniform_ab ( r8_lo, r8_hi, seed ) call combin_matrix ( alpha, beta, n, a ) call combin_inverse ( alpha, beta, n, b ) call r8mat_inverse ( n, a, c ) call r8mat_is_inverse ( n, a, b, error_ab ) call r8mat_is_inverse ( n, a, c, error_ac ) norm_frobenius = r8mat_norm_fro ( n, n, a ) write ( *, '(2x,a20,2x,i4,2x,g14.6,2x,g14.6,2x,g14.6)' ) & title, n, norm_frobenius, error_ab, error_ac c c COMPANION c title = 'COMPANION' n = 5 r8_lo = -5.0D+00 r8_hi = +5.0D+00 seed = 123456789 call r8vec_uniform_ab ( n, r8_lo, r8_hi, seed, x ) call companion_matrix ( n, x, a ) call companion_inverse ( n, x, b ) call r8mat_inverse ( n, a, c ) call r8mat_is_inverse ( n, a, b, error_ab ) call r8mat_is_inverse ( n, a, c, error_ac ) norm_frobenius = r8mat_norm_fro ( n, n, a ) write ( *, '(2x,a20,2x,i4,2x,g14.6,2x,g14.6,2x,g14.6)' ) & title, n, norm_frobenius, error_ab, error_ac c c COMPLEX_I c title = 'COMPLEX_I' n = 2 call complex_i_matrix ( a ) call complex_i_inverse ( b ) call r8mat_inverse ( n, a, c ) call r8mat_is_inverse ( n, a, b, error_ab ) call r8mat_is_inverse ( n, a, c, error_ac ) norm_frobenius = r8mat_norm_fro ( n, n, a ) write ( *, '(2x,a20,2x,i4,2x,g14.6,2x,g14.6,2x,g14.6)' ) & title, n, norm_frobenius, error_ab, error_ac c c CONEX1 c title = 'CONEX1' n = 4 r8_lo = -5.0D+00 r8_hi = +5.0D+00 seed = 123456789 alpha = r8_uniform_ab ( r8_lo, r8_hi, seed ) call conex1_matrix ( alpha, a ) call conex1_inverse ( alpha, b ) call r8mat_inverse ( n, a, c ) call r8mat_is_inverse ( n, a, b, error_ab ) call r8mat_is_inverse ( n, a, c, error_ac ) norm_frobenius = r8mat_norm_fro ( n, n, a ) write ( *, '(2x,a20,2x,i4,2x,g14.6,2x,g14.6,2x,g14.6)' ) & title, n, norm_frobenius, error_ab, error_ac c c CONEX2 c title = 'CONEX2' n = 3 r8_lo = -5.0D+00 r8_hi = +5.0D+00 seed = 123456789 alpha = r8_uniform_ab ( r8_lo, r8_hi, seed ) call conex2_matrix ( alpha, a ) call conex2_inverse ( alpha, b ) call r8mat_inverse ( n, a, c ) call r8mat_is_inverse ( n, a, b, error_ab ) call r8mat_is_inverse ( n, a, c, error_ac ) norm_frobenius = r8mat_norm_fro ( n, n, a ) write ( *, '(2x,a20,2x,i4,2x,g14.6,2x,g14.6,2x,g14.6)' ) & title, n, norm_frobenius, error_ab, error_ac c c CONEX3 c title = 'CONEX3' n = 5 call conex3_matrix ( n, a ) call conex3_inverse ( n, b ) call r8mat_inverse ( n, a, c ) call r8mat_is_inverse ( n, a, b, error_ab ) call r8mat_is_inverse ( n, a, c, error_ac ) norm_frobenius = r8mat_norm_fro ( n, n, a ) write ( *, '(2x,a20,2x,i4,2x,g14.6,2x,g14.6,2x,g14.6)' ) & title, n, norm_frobenius, error_ab, error_ac c c CONFERENCE c title = 'CONFERENCE' n = 6 call conference_matrix ( n, a ) call conference_inverse ( n, b ) call r8mat_inverse ( n, a, c ) call r8mat_is_inverse ( n, a, b, error_ab ) call r8mat_is_inverse ( n, a, c, error_ac ) norm_frobenius = r8mat_norm_fro ( n, n, a ) write ( *, '(2x,a20,2x,i4,2x,g14.6,2x,g14.6,2x,g14.6)' ) & title, n, norm_frobenius, error_ab, error_ac c c DAUB2 c title = 'DAUB2' n = 4 call daub2_matrix ( n, a ) call daub2_inverse ( n, b ) call r8mat_inverse ( n, a, c ) call r8mat_is_inverse ( n, a, b, error_ab ) call r8mat_is_inverse ( n, a, c, error_ac ) norm_frobenius = r8mat_norm_fro ( n, n, a ) write ( *, '(2x,a20,2x,i4,2x,g14.6,2x,g14.6,2x,g14.6)' ) & title, n, norm_frobenius, error_ab, error_ac c c DAUB4 c title = 'DAUB4' n = 8 call daub4_matrix ( n, a ) call daub4_inverse ( n, b ) call r8mat_inverse ( n, a, c ) call r8mat_is_inverse ( n, a, b, error_ab ) call r8mat_is_inverse ( n, a, c, error_ac ) norm_frobenius = r8mat_norm_fro ( n, n, a ) write ( *, '(2x,a20,2x,i4,2x,g14.6,2x,g14.6,2x,g14.6)' ) & title, n, norm_frobenius, error_ab, error_ac c c DAUB6 c title = 'DAUB6' n = 12 call daub6_matrix ( n, a ) call daub6_inverse ( n, b ) call r8mat_inverse ( n, a, c ) call r8mat_is_inverse ( n, a, b, error_ab ) call r8mat_is_inverse ( n, a, c, error_ac ) norm_frobenius = r8mat_norm_fro ( n, n, a ) write ( *, '(2x,a20,2x,i4,2x,g14.6,2x,g14.6,2x,g14.6)' ) & title, n, norm_frobenius, error_ab, error_ac c c DAUB8 c title = 'DAUB8' n = 16 call daub8_matrix ( n, a ) call daub8_inverse ( n, b ) call r8mat_inverse ( n, a, c ) call r8mat_is_inverse ( n, a, b, error_ab ) call r8mat_is_inverse ( n, a, c, error_ac ) norm_frobenius = r8mat_norm_fro ( n, n, a ) write ( *, '(2x,a20,2x,i4,2x,g14.6,2x,g14.6,2x,g14.6)' ) & title, n, norm_frobenius, error_ab, error_ac c c DAUB10 c title = 'DAUB10' n = 20 call daub10_matrix ( n, a ) call daub10_inverse ( n, b ) call r8mat_inverse ( n, a, c ) call r8mat_is_inverse ( n, a, b, error_ab ) call r8mat_is_inverse ( n, a, c, error_ac ) norm_frobenius = r8mat_norm_fro ( n, n, a ) write ( *, '(2x,a20,2x,i4,2x,g14.6,2x,g14.6,2x,g14.6)' ) & title, n, norm_frobenius, error_ab, error_ac c c DAUB12 c title = 'DAUB12' n = 24 call daub12_matrix ( n, a ) call daub12_inverse ( n, b ) call r8mat_inverse ( n, a, c ) call r8mat_is_inverse ( n, a, b, error_ab ) call r8mat_is_inverse ( n, a, c, error_ac ) norm_frobenius = r8mat_norm_fro ( n, n, a ) write ( *, '(2x,a20,2x,i4,2x,g14.6,2x,g14.6,2x,g14.6)' ) & title, n, norm_frobenius, error_ab, error_ac c c DIAGONAL c title = 'DIAGONAL' n = 5 r8_lo = -5.0D+00 r8_hi = +5.0D+00 seed = 123456789 call r8vec_uniform_ab ( n, r8_lo, r8_hi, seed, x ) call diagonal_matrix ( n, n, x, a ) call diagonal_inverse ( n, x, b ) call r8mat_inverse ( n, a, c ) call r8mat_is_inverse ( n, a, b, error_ab ) call r8mat_is_inverse ( n, a, c, error_ac ) norm_frobenius = r8mat_norm_fro ( n, n, a ) write ( *, '(2x,a20,2x,i4,2x,g14.6,2x,g14.6,2x,g14.6)' ) & title, n, norm_frobenius, error_ab, error_ac c c DIF1 c N must be even. c title = 'DIF1' n = 6 call dif1_matrix ( n, n, a ) call dif1_inverse ( n, b ) call r8mat_inverse ( n, a, c ) call r8mat_is_inverse ( n, a, b, error_ab ) call r8mat_is_inverse ( n, a, c, error_ac ) norm_frobenius = r8mat_norm_fro ( n, n, a ) write ( *, '(2x,a20,2x,i4,2x,g14.6,2x,g14.6,2x,g14.6)' ) & title, n, norm_frobenius, error_ab, error_ac c c DIF2 c title = 'DIF2' n = 5 call dif2_matrix ( n, n, a ) call dif2_inverse ( n, b ) call r8mat_inverse ( n, a, c ) call r8mat_is_inverse ( n, a, b, error_ab ) call r8mat_is_inverse ( n, a, c, error_ac ) norm_frobenius = r8mat_norm_fro ( n, n, a ) write ( *, '(2x,a20,2x,i4,2x,g14.6,2x,g14.6,2x,g14.6)' ) & title, n, norm_frobenius, error_ab, error_ac c c DORR c title = 'DORR' n = 5 r8_lo = -5.0D+00 r8_hi = +5.0D+00 seed = 123456789 alpha = r8_uniform_ab ( r8_lo, r8_hi, seed ) call dorr_matrix ( alpha, n, a ) call dorr_inverse ( alpha, n, b ) call r8mat_inverse ( n, a, c ) call r8mat_is_inverse ( n, a, b, error_ab ) call r8mat_is_inverse ( n, a, c, error_ac ) norm_frobenius = r8mat_norm_fro ( n, n, a ) write ( *, '(2x,a20,2x,i4,2x,g14.6,2x,g14.6,2x,g14.6)' ) & title, n, norm_frobenius, error_ab, error_ac c c DOWNSHIFT c title = 'DOWNSHIFT' n = 5 call downshift_matrix ( n, a ) call downshift_inverse ( n, b ) call r8mat_inverse ( n, a, c ) call r8mat_is_inverse ( n, a, b, error_ab ) call r8mat_is_inverse ( n, a, c, error_ac ) norm_frobenius = r8mat_norm_fro ( n, n, a ) write ( *, '(2x,a20,2x,i4,2x,g14.6,2x,g14.6,2x,g14.6)' ) & title, n, norm_frobenius, error_ab, error_ac c c EULERIAN c title = 'EULERIAN' n = 5 call eulerian_matrix ( n, n, a ) call eulerian_inverse ( n, b ) call r8mat_inverse ( n, a, c ) call r8mat_is_inverse ( n, a, b, error_ab ) call r8mat_is_inverse ( n, a, c, error_ac ) norm_frobenius = r8mat_norm_fro ( n, n, a ) write ( *, '(2x,a20,2x,i4,2x,g14.6,2x,g14.6,2x,g14.6)' ) & title, n, norm_frobenius, error_ab, error_ac c c EXCHANGE c title = 'EXCHANGE' n = 5 call exchange_matrix ( n, n, a ) call exchange_inverse ( n, b ) call r8mat_inverse ( n, a, c ) call r8mat_is_inverse ( n, a, b, error_ab ) call r8mat_is_inverse ( n, a, c, error_ac ) norm_frobenius = r8mat_norm_fro ( n, n, a ) write ( *, '(2x,a20,2x,i4,2x,g14.6,2x,g14.6,2x,g14.6)' ) & title, n, norm_frobenius, error_ab, error_ac c c FIBONACCI2 c title = 'FIBONACCI2' n = 5 call fibonacci2_matrix ( n, a ) call fibonacci2_inverse ( n, b ) call r8mat_inverse ( n, a, c ) call r8mat_is_inverse ( n, a, b, error_ab ) call r8mat_is_inverse ( n, a, c, error_ac ) norm_frobenius = r8mat_norm_fro ( n, n, a ) write ( *, '(2x,a20,2x,i4,2x,g14.6,2x,g14.6,2x,g14.6)' ) & title, n, norm_frobenius, error_ab, error_ac c c FIBONACCI3 c title = 'FIBONACCI3' n = 5 call fibonacci3_matrix ( n, a ) call fibonacci3_inverse ( n, b ) call r8mat_inverse ( n, a, c ) call r8mat_is_inverse ( n, a, b, error_ab ) call r8mat_is_inverse ( n, a, c, error_ac ) norm_frobenius = r8mat_norm_fro ( n, n, a ) write ( *, '(2x,a20,2x,i4,2x,g14.6,2x,g14.6,2x,g14.6)' ) & title, n, norm_frobenius, error_ab, error_ac c c FIEDLER c The FIEDLER_INVERSE routine assumes the X vector is sorted. c title = 'FIEDLER' n = 7 r8_lo = -5.0D+00 r8_hi = +5.0D+00 seed = 123456789 call r8vec_uniform_ab ( n, r8_lo, r8_hi, seed, x ) call r8vec_sort_bubble_a ( n, x ) call fiedler_matrix ( n, n, x, a ) call fiedler_inverse ( n, x, b ) call r8mat_inverse ( n, a, c ) call r8mat_is_inverse ( n, a, b, error_ab ) call r8mat_is_inverse ( n, a, c, error_ac ) norm_frobenius = r8mat_norm_fro ( n, n, a ) write ( *, '(2x,a20,2x,i4,2x,g14.6,2x,g14.6,2x,g14.6)' ) & title, n, norm_frobenius, error_ab, error_ac c c FORSYTHE c title = 'FORSYTHE' n = 5 r8_lo = -5.0D+00 r8_hi = +5.0D+00 seed = 123456789 alpha = r8_uniform_ab ( r8_lo, r8_hi, seed ) beta = r8_uniform_ab ( r8_lo, r8_hi, seed ) call forsythe_matrix ( alpha, beta, n, a ) call forsythe_inverse ( alpha, beta, n, b ) call r8mat_inverse ( n, a, c ) call r8mat_is_inverse ( n, a, b, error_ab ) call r8mat_is_inverse ( n, a, c, error_ac ) norm_frobenius = r8mat_norm_fro ( n, n, a ) write ( *, '(2x,a20,2x,i4,2x,g14.6,2x,g14.6,2x,g14.6)' ) & title, n, norm_frobenius, error_ab, error_ac c c FOURIER_COSINE c title = 'FOURIER_COSINE' n = 5 call fourier_cosine_matrix ( n, a ) call fourier_cosine_inverse ( n, b ) call r8mat_inverse ( n, a, c ) call r8mat_is_inverse ( n, a, b, error_ab ) call r8mat_is_inverse ( n, a, c, error_ac ) norm_frobenius = r8mat_norm_fro ( n, n, a ) write ( *, '(2x,a20,2x,i4,2x,g14.6,2x,g14.6,2x,g14.6)' ) & title, n, norm_frobenius, error_ab, error_ac c c FOURIER_SINE c title = 'FOURIER_SINE' n = 5 call fourier_sine_matrix ( n, a ) call fourier_sine_inverse ( n, b ) call r8mat_inverse ( n, a, c ) call r8mat_is_inverse ( n, a, b, error_ab ) call r8mat_is_inverse ( n, a, c, error_ac ) norm_frobenius = r8mat_norm_fro ( n, n, a ) write ( *, '(2x,a20,2x,i4,2x,g14.6,2x,g14.6,2x,g14.6)' ) & title, n, norm_frobenius, error_ab, error_ac c c FRANK c title = 'FRANK' n = 5 call frank_matrix ( n, a ) call frank_inverse ( n, b ) call r8mat_inverse ( n, a, c ) call r8mat_is_inverse ( n, a, b, error_ab ) call r8mat_is_inverse ( n, a, c, error_ac ) norm_frobenius = r8mat_norm_fro ( n, n, a ) write ( *, '(2x,a20,2x,i4,2x,g14.6,2x,g14.6,2x,g14.6)' ) & title, n, norm_frobenius, error_ab, error_ac c c GFPP c title = 'GFPP' n = 5 r8_lo = -5.0D+00 r8_hi = +5.0D+00 seed = 123456789 alpha = r8_uniform_ab ( r8_lo, r8_hi, seed ) call gfpp_matrix ( n, alpha, a ) call gfpp_inverse ( n, alpha, b ) call r8mat_inverse ( n, a, c ) call r8mat_is_inverse ( n, a, b, error_ab ) call r8mat_is_inverse ( n, a, c, error_ac ) norm_frobenius = r8mat_norm_fro ( n, n, a ) write ( *, '(2x,a20,2x,i4,2x,g14.6,2x,g14.6,2x,g14.6)' ) & title, n, norm_frobenius, error_ab, error_ac c c GIVENS c title = 'GIVENS' n = 5 call givens_matrix ( n, n, a ) call givens_inverse ( n, b ) call r8mat_inverse ( n, a, c ) call r8mat_is_inverse ( n, a, b, error_ab ) call r8mat_is_inverse ( n, a, c, error_ac ) norm_frobenius = r8mat_norm_fro ( n, n, a ) write ( *, '(2x,a20,2x,i4,2x,g14.6,2x,g14.6,2x,g14.6)' ) & title, n, norm_frobenius, error_ab, error_ac c c GK316 c title = 'GK316' n = 5 call gk316_matrix ( n, a ) call gk316_inverse ( n, b ) call r8mat_inverse ( n, a, c ) call r8mat_is_inverse ( n, a, b, error_ab ) call r8mat_is_inverse ( n, a, c, error_ac ) norm_frobenius = r8mat_norm_fro ( n, n, a ) write ( *, '(2x,a20,2x,i4,2x,g14.6,2x,g14.6,2x,g14.6)' ) & title, n, norm_frobenius, error_ab, error_ac c c GK323 c title = 'GK323' n = 5 call gk323_matrix ( n, n, a ) call gk323_inverse ( n, b ) call r8mat_inverse ( n, a, c ) call r8mat_is_inverse ( n, a, b, error_ab ) call r8mat_is_inverse ( n, a, c, error_ac ) norm_frobenius = r8mat_norm_fro ( n, n, a ) write ( *, '(2x,a20,2x,i4,2x,g14.6,2x,g14.6,2x,g14.6)' ) & title, n, norm_frobenius, error_ab, error_ac c c GK324 c title = 'GK324' n = 5 r8_lo = -5.0D+00 r8_hi = +5.0D+00 seed = 123456789 call r8vec_uniform_ab ( n - 1, r8_lo, r8_hi, seed, x ) call gk324_matrix ( n, n, x, a ) call gk324_inverse ( n, x, b ) call r8mat_inverse ( n, a, c ) call r8mat_is_inverse ( n, a, b, error_ab ) call r8mat_is_inverse ( n, a, c, error_ac ) norm_frobenius = r8mat_norm_fro ( n, n, a ) write ( *, '(2x,a20,2x,i4,2x,g14.6,2x,g14.6,2x,g14.6)' ) & title, n, norm_frobenius, error_ab, error_ac c c HANKEL_N c title = 'HANKEL_N' n = 6 call hankel_n_matrix ( n, a ) call hankel_n_inverse ( n, b ) call r8mat_inverse ( n, a, c ) call r8mat_is_inverse ( n, a, b, error_ab ) call r8mat_is_inverse ( n, a, c, error_ac ) norm_frobenius = r8mat_norm_fro ( n, n, a ) write ( *, '(2x,a20,2x,i4,2x,g14.6,2x,g14.6,2x,g14.6)' ) & title, n, norm_frobenius, error_ab, error_ac c c HANOWA c title = 'HANOWA' n = 8 r8_lo = -5.0D+00 r8_hi = +5.0D+00 seed = 123456789 alpha = r8_uniform_ab ( r8_lo, r8_hi, seed ) call hanowa_matrix ( alpha, n, a ) call hanowa_inverse ( alpha, n, b ) call r8mat_inverse ( n, a, c ) call r8mat_is_inverse ( n, a, b, error_ab ) call r8mat_is_inverse ( n, a, c, error_ac ) norm_frobenius = r8mat_norm_fro ( n, n, a ) write ( *, '(2x,a20,2x,i4,2x,g14.6,2x,g14.6,2x,g14.6)' ) & title, n, norm_frobenius, error_ab, error_ac c c HARMAN c title = 'HARMAN' n = 8 call harman_matrix ( a ) call harman_inverse ( b ) call r8mat_inverse ( n, a, c ) call r8mat_is_inverse ( n, a, b, error_ab ) call r8mat_is_inverse ( n, a, c, error_ac ) norm_frobenius = r8mat_norm_fro ( n, n, a ) write ( *, '(2x,a20,2x,i4,2x,g14.6,2x,g14.6,2x,g14.6)' ) & title, n, norm_frobenius, error_ab, error_ac c c HARTLEY c title = 'HARTLEY' n = 5 call hartley_matrix ( n, a ) call hartley_inverse ( n, b ) call r8mat_inverse ( n, a, c ) call r8mat_is_inverse ( n, a, b, error_ab ) call r8mat_is_inverse ( n, a, c, error_ac ) norm_frobenius = r8mat_norm_fro ( n, n, a ) write ( *, '(2x,a20,2x,i4,2x,g14.6,2x,g14.6,2x,g14.6)' ) & title, n, norm_frobenius, error_ab, error_ac c c HELMERT c title = 'HELMERT' n = 5 call helmert_matrix ( n, a ) call helmert_inverse ( n, b ) call r8mat_inverse ( n, a, c ) call r8mat_is_inverse ( n, a, b, error_ab ) call r8mat_is_inverse ( n, a, c, error_ac ) norm_frobenius = r8mat_norm_fro ( n, n, a ) write ( *, '(2x,a20,2x,i4,2x,g14.6,2x,g14.6,2x,g14.6)' ) & title, n, norm_frobenius, error_ab, error_ac c c HELMERT2 c title = 'HELMERT2' n = 5 r8_lo = -5.0D+00 r8_hi = +5.0D+00 seed = 123456789 call r8vec_uniform_ab ( n, r8_lo, r8_hi, seed, x ) call helmert2_matrix ( n, x, a ) call helmert2_inverse ( n, x, b ) call r8mat_inverse ( n, a, c ) call r8mat_is_inverse ( n, a, b, error_ab ) call r8mat_is_inverse ( n, a, c, error_ac ) norm_frobenius = r8mat_norm_fro ( n, n, a ) write ( *, '(2x,a20,2x,i4,2x,g14.6,2x,g14.6,2x,g14.6)' ) & title, n, norm_frobenius, error_ab, error_ac c c HERMITE c title = 'HERMITE' n = 5 call hermite_matrix ( n, a ) call hermite_inverse ( n, b ) call r8mat_inverse ( n, a, c ) call r8mat_is_inverse ( n, a, b, error_ab ) call r8mat_is_inverse ( n, a, c, error_ac ) norm_frobenius = r8mat_norm_fro ( n, n, a ) write ( *, '(2x,a20,2x,i4,2x,g14.6,2x,g14.6,2x,g14.6)' ) & title, n, norm_frobenius, error_ab, error_ac c c HERNDON c title = 'HERNDON' n = 5 call herndon_matrix ( n, a ) call herndon_inverse ( n, b ) call r8mat_inverse ( n, a, c ) call r8mat_is_inverse ( n, a, b, error_ab ) call r8mat_is_inverse ( n, a, c, error_ac ) norm_frobenius = r8mat_norm_fro ( n, n, a ) write ( *, '(2x,a20,2x,i4,2x,g14.6,2x,g14.6,2x,g14.6)' ) & title, n, norm_frobenius, error_ab, error_ac c c HILBERT c title = 'HILBERT' n = 5 call hilbert_matrix ( n, n, a ) call hilbert_inverse ( n, b ) call r8mat_inverse ( n, a, c ) call r8mat_is_inverse ( n, a, b, error_ab ) call r8mat_is_inverse ( n, a, c, error_ac ) norm_frobenius = r8mat_norm_fro ( n, n, a ) write ( *, '(2x,a20,2x,i4,2x,g14.6,2x,g14.6,2x,g14.6)' ) & title, n, norm_frobenius, error_ab, error_ac c c HOUSEHOLDER c title = 'HOUSEHOLDER' n = 5 r8_lo = -5.0D+00 r8_hi = +5.0D+00 seed = 123456789 call r8vec_uniform_ab ( n, r8_lo, r8_hi, seed, x ) call householder_matrix ( n, x, a ) call householder_inverse ( n, x, b ) call r8mat_inverse ( n, a, c ) call r8mat_is_inverse ( n, a, b, error_ab ) call r8mat_is_inverse ( n, a, c, error_ac ) norm_frobenius = r8mat_norm_fro ( n, n, a ) write ( *, '(2x,a20,2x,i4,2x,g14.6,2x,g14.6,2x,g14.6)' ) & title, n, norm_frobenius, error_ab, error_ac c c IDENTITY c title = 'IDENTITY' n = 5 call identity_matrix ( n, n, a ) call identity_inverse ( n, b ) call r8mat_inverse ( n, a, c ) call r8mat_is_inverse ( n, a, b, error_ab ) call r8mat_is_inverse ( n, a, c, error_ac ) norm_frobenius = r8mat_norm_fro ( n, n, a ) write ( *, '(2x,a20,2x,i4,2x,g14.6,2x,g14.6,2x,g14.6)' ) & title, n, norm_frobenius, error_ab, error_ac c c ILL3 c title = 'ILL3' n = 3 call ill3_matrix ( a ) call ill3_inverse ( b ) call r8mat_inverse ( n, a, c ) call r8mat_is_inverse ( n, a, b, error_ab ) call r8mat_is_inverse ( n, a, c, error_ac ) norm_frobenius = r8mat_norm_fro ( n, n, a ) write ( *, '(2x,a20,2x,i4,2x,g14.6,2x,g14.6,2x,g14.6)' ) & title, n, norm_frobenius, error_ab, error_ac c c INTEGRATION c title = 'INTEGRATION' n = 6 r8_lo = -5.0D+00 r8_hi = +5.0D+00 seed = 123456789 alpha = r8_uniform_ab ( r8_lo, r8_hi, seed ) call integration_matrix ( alpha, n, a ) call integration_inverse ( alpha, n, b ) call r8mat_inverse ( n, a, c ) call r8mat_is_inverse ( n, a, b, error_ab ) call r8mat_is_inverse ( n, a, c, error_ac ) norm_frobenius = r8mat_norm_fro ( n, n, a ) write ( *, '(2x,a20,2x,i4,2x,g14.6,2x,g14.6,2x,g14.6)' ) & title, n, norm_frobenius, error_ab, error_ac c c INVOL c title = 'INVOL' n = 5 call invol_matrix ( n, a ) call invol_inverse ( n, b ) call r8mat_inverse ( n, a, c ) call r8mat_is_inverse ( n, a, b, error_ab ) call r8mat_is_inverse ( n, a, c, error_ac ) norm_frobenius = r8mat_norm_fro ( n, n, a ) write ( *, '(2x,a20,2x,i4,2x,g14.6,2x,g14.6,2x,g14.6)' ) & title, n, norm_frobenius, error_ab, error_ac c c jacobi_legendre c N must be even. c title = 'jacobi_legendre' n = 6 call jacobi_legendre_matrix ( n, n, a ) call jacobi_legendre_inverse ( n, b ) call r8mat_inverse ( n, a, c ) call r8mat_is_inverse ( n, a, b, error_ab ) call r8mat_is_inverse ( n, a, c, error_ac ) norm_frobenius = r8mat_norm_fro ( n, n, a ) write ( *, '(2x,a20,2x,i4,2x,g14.6,2x,g14.6,2x,g14.6)' ) & title, n, norm_frobenius, error_ab, error_ac c c JORDAN c title = 'JORDAN' n = 6 r8_lo = -5.0D+00 r8_hi = +5.0D+00 seed = 123456789 alpha = r8_uniform_ab ( r8_lo, r8_hi, seed ) call jordan_matrix ( n, n, alpha, a ) call jordan_inverse ( n, alpha, b ) call r8mat_inverse ( n, a, c ) call r8mat_is_inverse ( n, a, b, error_ab ) call r8mat_is_inverse ( n, a, c, error_ac ) norm_frobenius = r8mat_norm_fro ( n, n, a ) write ( *, '(2x,a20,2x,i4,2x,g14.6,2x,g14.6,2x,g14.6)' ) & title, n, norm_frobenius, error_ab, error_ac c c KAHAN c title = 'KAHAN' n = 5 r8_lo = -5.0D+00 r8_hi = +5.0D+00 seed = 123456789 alpha = r8_uniform_ab ( r8_lo, r8_hi, seed ) call kahan_matrix ( alpha, n, n, a ) call kahan_inverse ( alpha, n, b ) call r8mat_inverse ( n, a, c ) call r8mat_is_inverse ( n, a, b, error_ab ) call r8mat_is_inverse ( n, a, c, error_ac ) norm_frobenius = r8mat_norm_fro ( n, n, a ) write ( *, '(2x,a20,2x,i4,2x,g14.6,2x,g14.6,2x,g14.6)' ) & title, n, norm_frobenius, error_ab, error_ac c c KERSHAW c title = 'KERSHAW' n = 4 call kershaw_matrix ( a ) call kershaw_inverse ( b ) call r8mat_inverse ( n, a, c ) call r8mat_is_inverse ( n, a, b, error_ab ) call r8mat_is_inverse ( n, a, c, error_ac ) norm_frobenius = r8mat_norm_fro ( n, n, a ) write ( *, '(2x,a20,2x,i4,2x,g14.6,2x,g14.6,2x,g14.6)' ) & title, n, norm_frobenius, error_ab, error_ac c c KERSHAWTRI c title = 'KERSHAWTRI' n = 5 x_n = ( n + 1 ) / 2 r8_lo = -5.0D+00 r8_hi = +5.0D+00 seed = 123456789 call r8vec_uniform_ab ( x_n, r8_lo, r8_hi, seed, x ) call kershawtri_matrix ( n, x, a ) call kershawtri_inverse ( n, x, b ) call r8mat_inverse ( n, a, c ) call r8mat_is_inverse ( n, a, b, error_ab ) call r8mat_is_inverse ( n, a, c, error_ac ) norm_frobenius = r8mat_norm_fro ( n, n, a ) write ( *, '(2x,a20,2x,i4,2x,g14.6,2x,g14.6,2x,g14.6)' ) & title, n, norm_frobenius, error_ab, error_ac c c KMS c title = 'KMS' n = 5 r8_lo = -5.0D+00 r8_hi = +5.0D+00 seed = 123456789 alpha = r8_uniform_ab ( r8_lo, r8_hi, seed ) call kms_matrix ( alpha, n, n, a ) call kms_inverse ( alpha, n, b ) call r8mat_inverse ( n, a, c ) call r8mat_is_inverse ( n, a, b, error_ab ) call r8mat_is_inverse ( n, a, c, error_ac ) norm_frobenius = r8mat_norm_fro ( n, n, a ) write ( *, '(2x,a20,2x,i4,2x,g14.6,2x,g14.6,2x,g14.6)' ) & title, n, norm_frobenius, error_ab, error_ac c c LAGUERRE c title = 'LAGUERRE' n = 5 call laguerre_matrix ( n, a ) call laguerre_inverse ( n, b ) call r8mat_inverse ( n, a, c ) call r8mat_is_inverse ( n, a, b, error_ab ) call r8mat_is_inverse ( n, a, c, error_ac ) norm_frobenius = r8mat_norm_fro ( n, n, a ) write ( *, '(2x,a20,2x,i4,2x,g14.6,2x,g14.6,2x,g14.6)' ) & title, n, norm_frobenius, error_ab, error_ac c c legendre_matrix c title = 'legendre_matrix' n = 5 call legendre_matrix ( n, a ) call legendre_inverse ( n, b ) call r8mat_inverse ( n, a, c ) call r8mat_is_inverse ( n, a, b, error_ab ) call r8mat_is_inverse ( n, a, c, error_ac ) norm_frobenius = r8mat_norm_fro ( n, n, a ) write ( *, '(2x,a20,2x,i4,2x,g14.6,2x,g14.6,2x,g14.6)' ) & title, n, norm_frobenius, error_ab, error_ac c c LEHMER c title = 'LEHMER' n = 5 call lehmer_matrix ( n, n, a ) call lehmer_inverse ( n, b ) call r8mat_inverse ( n, a, c ) call r8mat_is_inverse ( n, a, b, error_ab ) call r8mat_is_inverse ( n, a, c, error_ac ) norm_frobenius = r8mat_norm_fro ( n, n, a ) write ( *, '(2x,a20,2x,i4,2x,g14.6,2x,g14.6,2x,g14.6)' ) & title, n, norm_frobenius, error_ab, error_ac c c LESP c title = 'LESP' n = 5 call lesp_matrix ( n, n, a ) call lesp_inverse ( n, b ) call r8mat_inverse ( n, a, c ) call r8mat_is_inverse ( n, a, b, error_ab ) call r8mat_is_inverse ( n, a, c, error_ac ) norm_frobenius = r8mat_norm_fro ( n, n, a ) write ( *, '(2x,a20,2x,i4,2x,g14.6,2x,g14.6,2x,g14.6)' ) & title, n, norm_frobenius, error_ab, error_ac c c LIETZKE c title = 'LIETZKE' n = 5 call lietzke_matrix ( n, a ) call lietzke_inverse ( n, b ) call r8mat_inverse ( n, a, c ) call r8mat_is_inverse ( n, a, b, error_ab ) call r8mat_is_inverse ( n, a, c, error_ac ) norm_frobenius = r8mat_norm_fro ( n, n, a ) write ( *, '(2x,a20,2x,i4,2x,g14.6,2x,g14.6,2x,g14.6)' ) & title, n, norm_frobenius, error_ab, error_ac c c LINE_ADJ c N must be even. c title = 'LINE_ADJ' n = 6 call line_adj_matrix ( n, a ) call line_adj_inverse ( n, b ) call r8mat_inverse ( n, a, c ) call r8mat_is_inverse ( n, a, b, error_ab ) call r8mat_is_inverse ( n, a, c, error_ac ) norm_frobenius = r8mat_norm_fro ( n, n, a ) write ( *, '(2x,a20,2x,i4,2x,g14.6,2x,g14.6,2x,g14.6)' ) & title, n, norm_frobenius, error_ab, error_ac c c LOTKIN c title = 'LOTKIN' n = 5 call lotkin_matrix ( n, n, a ) call lotkin_inverse ( n, b ) call r8mat_inverse ( n, a, c ) call r8mat_is_inverse ( n, a, b, error_ab ) call r8mat_is_inverse ( n, a, c, error_ac ) norm_frobenius = r8mat_norm_fro ( n, n, a ) write ( *, '(2x,a20,2x,i4,2x,g14.6,2x,g14.6,2x,g14.6)' ) & title, n, norm_frobenius, error_ab, error_ac c c MAXIJ c title = 'MAXIJ' n = 5 call maxij_matrix ( n, n, a ) call maxij_inverse ( n, b ) call r8mat_inverse ( n, a, c ) call r8mat_is_inverse ( n, a, b, error_ab ) call r8mat_is_inverse ( n, a, c, error_ac ) norm_frobenius = r8mat_norm_fro ( n, n, a ) write ( *, '(2x,a20,2x,i4,2x,g14.6,2x,g14.6,2x,g14.6)' ) & title, n, norm_frobenius, error_ab, error_ac c c MILNES c title = 'MILNES' n = 5 r8_lo = -5.0D+00 r8_hi = +5.0D+00 seed = 123456789 call r8vec_uniform_ab ( n, r8_lo, r8_hi, seed, x ) call milnes_matrix ( n, n, x, a ) call milnes_inverse ( n, x, b ) call r8mat_inverse ( n, a, c ) call r8mat_is_inverse ( n, a, b, error_ab ) call r8mat_is_inverse ( n, a, c, error_ac ) norm_frobenius = r8mat_norm_fro ( n, n, a ) write ( *, '(2x,a20,2x,i4,2x,g14.6,2x,g14.6,2x,g14.6)' ) & title, n, norm_frobenius, error_ab, error_ac c c MINIJ c title = 'MINIJ' n = 5 call minij_matrix ( n, n, a ) call minij_inverse ( n, b ) call r8mat_inverse ( n, a, c ) call r8mat_is_inverse ( n, a, b, error_ab ) call r8mat_is_inverse ( n, a, c, error_ac ) norm_frobenius = r8mat_norm_fro ( n, n, a ) write ( *, '(2x,a20,2x,i4,2x,g14.6,2x,g14.6,2x,g14.6)' ) & title, n, norm_frobenius, error_ab, error_ac c c MOLER1 c title = 'MOLER1' n = 5 r8_lo = -5.0D+00 r8_hi = +5.0D+00 seed = 123456789 alpha = r8_uniform_ab ( r8_lo, r8_hi, seed ) call moler1_matrix ( alpha, n, n, a ) call moler1_inverse ( alpha, n, b ) call r8mat_inverse ( n, a, c ) call r8mat_is_inverse ( n, a, b, error_ab ) call r8mat_is_inverse ( n, a, c, error_ac ) norm_frobenius = r8mat_norm_fro ( n, n, a ) write ( *, '(2x,a20,2x,i4,2x,g14.6,2x,g14.6,2x,g14.6)' ) & title, n, norm_frobenius, error_ab, error_ac c c MOLER3 c title = 'MOLER3' n = 5 call moler3_matrix ( n, n, a ) call moler3_inverse ( n, b ) call r8mat_inverse ( n, a, c ) call r8mat_is_inverse ( n, a, b, error_ab ) call r8mat_is_inverse ( n, a, c, error_ac ) norm_frobenius = r8mat_norm_fro ( n, n, a ) write ( *, '(2x,a20,2x,i4,2x,g14.6,2x,g14.6,2x,g14.6)' ) & title, n, norm_frobenius, error_ab, error_ac c c ORTEGA c title = 'ORTEGA' n = 5 r8_lo = -5.0D+00 r8_hi = +5.0D+00 seed = 123456789 call r8vec_uniform_ab ( n, r8_lo, r8_hi, seed, v1 ) call r8vec_uniform_ab ( n, r8_lo, r8_hi, seed, v2 ) call r8vec_uniform_ab ( n, r8_lo, r8_hi, seed, v3 ) call ortega_matrix ( n, v1, v2, v3, a ) call ortega_inverse ( n, v1, v2, v3, b ) call r8mat_inverse ( n, a, c ) call r8mat_is_inverse ( n, a, b, error_ab ) call r8mat_is_inverse ( n, a, c, error_ac ) norm_frobenius = r8mat_norm_fro ( n, n, a ) write ( *, '(2x,a20,2x,i4,2x,g14.6,2x,g14.6,2x,g14.6)' ) & title, n, norm_frobenius, error_ab, error_ac c c ORTH_SYMM c title = 'ORTH_SYMM' n = 5 call orth_symm_matrix ( n, a ) call orth_symm_inverse ( n, b ) call r8mat_inverse ( n, a, c ) call r8mat_is_inverse ( n, a, b, error_ab ) call r8mat_is_inverse ( n, a, c, error_ac ) norm_frobenius = r8mat_norm_fro ( n, n, a ) write ( *, '(2x,a20,2x,i4,2x,g14.6,2x,g14.6,2x,g14.6)' ) & title, n, norm_frobenius, error_ab, error_ac c c OTO c title = 'OTO' n = 5 call oto_matrix ( n, n, a ) call oto_inverse ( n, b ) call r8mat_inverse ( n, a, c ) call r8mat_is_inverse ( n, a, b, error_ab ) call r8mat_is_inverse ( n, a, c, error_ac ) norm_frobenius = r8mat_norm_fro ( n, n, a ) write ( *, '(2x,a20,2x,i4,2x,g14.6,2x,g14.6,2x,g14.6)' ) & title, n, norm_frobenius, error_ab, error_ac c c PARTER c title = 'PARTER' n = 5 call parter_matrix ( n, n, a ) call parter_inverse ( n, b ) call r8mat_inverse ( n, a, c ) call r8mat_is_inverse ( n, a, b, error_ab ) call r8mat_is_inverse ( n, a, c, error_ac ) norm_frobenius = r8mat_norm_fro ( n, n, a ) write ( *, '(2x,a20,2x,i4,2x,g14.6,2x,g14.6,2x,g14.6)' ) & title, n, norm_frobenius, error_ab, error_ac c c PASCAL1 c title = 'PASCAL1' n = 5 call pascal1_matrix ( n, a ) call pascal1_inverse ( n, b ) call r8mat_inverse ( n, a, c ) call r8mat_is_inverse ( n, a, b, error_ab ) call r8mat_is_inverse ( n, a, c, error_ac ) norm_frobenius = r8mat_norm_fro ( n, n, a ) write ( *, '(2x,a20,2x,i4,2x,g14.6,2x,g14.6,2x,g14.6)' ) & title, n, norm_frobenius, error_ab, error_ac c c PASCAL2 c title = 'PASCAL2' n = 5 call pascal2_matrix ( n, a ) call pascal2_inverse ( n, b ) call r8mat_inverse ( n, a, c ) call r8mat_is_inverse ( n, a, b, error_ab ) call r8mat_is_inverse ( n, a, c, error_ac ) norm_frobenius = r8mat_norm_fro ( n, n, a ) write ( *, '(2x,a20,2x,i4,2x,g14.6,2x,g14.6,2x,g14.6)' ) & title, n, norm_frobenius, error_ab, error_ac c c PASCAL3 c title = 'PASCAL3' n = 5 r8_lo = -5.0D+00 r8_hi = +5.0D+00 seed = 123456789 alpha = r8_uniform_ab ( r8_lo, r8_hi, seed ) call pascal3_matrix ( n, alpha, a ) call pascal3_inverse ( n, alpha, b ) call r8mat_inverse ( n, a, c ) call r8mat_is_inverse ( n, a, b, error_ab ) call r8mat_is_inverse ( n, a, c, error_ac ) norm_frobenius = r8mat_norm_fro ( n, n, a ) write ( *, '(2x,a20,2x,i4,2x,g14.6,2x,g14.6,2x,g14.6)' ) & title, n, norm_frobenius, error_ab, error_ac c c spd_random c title = 'spd_random' n = 5 key = 123456789 call spd_random_matrix ( n, key, a ) call spd_random_inverse ( n, key, b ) call r8mat_inverse ( n, a, c ) call r8mat_is_inverse ( n, a, b, error_ab ) call r8mat_is_inverse ( n, a, c, error_ac ) norm_frobenius = r8mat_norm_fro ( n, n, a ) write ( *, '(2x,a20,2x,i4,2x,g14.6,2x,g14.6,2x,g14.6)' ) & title, n, norm_frobenius, error_ab, error_ac c c PEI c title = 'PEI' n = 5 r8_lo = -5.0D+00 r8_hi = +5.0D+00 seed = 123456789 alpha = r8_uniform_ab ( r8_lo, r8_hi, seed ) call pei_matrix ( alpha, n, a ) call pei_inverse ( alpha, n, b ) call r8mat_inverse ( n, a, c ) call r8mat_is_inverse ( n, a, b, error_ab ) call r8mat_is_inverse ( n, a, c, error_ac ) norm_frobenius = r8mat_norm_fro ( n, n, a ) write ( *, '(2x,a20,2x,i4,2x,g14.6,2x,g14.6,2x,g14.6)' ) & title, n, norm_frobenius, error_ab, error_ac c c PERMUTATION_RANDOM c title = 'PERMUTATION_RANDOM' n = 5 key = 123456789 call permutation_random_matrix ( n, key, a ) call permutation_random_inverse ( n, key, b ) call r8mat_inverse ( n, a, c ) call r8mat_is_inverse ( n, a, b, error_ab ) call r8mat_is_inverse ( n, a, c, error_ac ) norm_frobenius = r8mat_norm_fro ( n, n, a ) write ( *, '(2x,a20,2x,i4,2x,g14.6,2x,g14.6,2x,g14.6)' ) & title, n, norm_frobenius, error_ab, error_ac c c PLU c title = 'PLU' n = 5 seed = 123456789 do i = 1, n i4_lo = i i4_hi = n pivot(i) = i4_uniform_ab ( i4_lo, i4_hi, seed ) end do call plu_matrix ( n, pivot, a ) call plu_inverse ( n, pivot, b ) call r8mat_inverse ( n, a, c ) call r8mat_is_inverse ( n, a, b, error_ab ) call r8mat_is_inverse ( n, a, c, error_ac ) norm_frobenius = r8mat_norm_fro ( n, n, a ) write ( *, '(2x,a20,2x,i4,2x,g14.6,2x,g14.6,2x,g14.6)' ) & title, n, norm_frobenius, error_ab, error_ac c c RIS c title = 'RIS' n = 5 call ris_matrix ( n, a ) call ris_inverse ( n, b ) call r8mat_inverse ( n, a, c ) call r8mat_is_inverse ( n, a, b, error_ab ) call r8mat_is_inverse ( n, a, c, error_ac ) norm_frobenius = r8mat_norm_fro ( n, n, a ) write ( *, '(2x,a20,2x,i4,2x,g14.6,2x,g14.6,2x,g14.6)' ) & title, n, norm_frobenius, error_ab, error_ac c c RODMAN c title = 'RODMAN' n = 5 r8_lo = -5.0D+00 r8_hi = +5.0D+00 seed = 123456789 alpha = r8_uniform_ab ( r8_lo, r8_hi, seed ) call rodman_matrix ( n, n, alpha, a ) call rodman_inverse ( n, alpha, b ) call r8mat_inverse ( n, a, c ) call r8mat_is_inverse ( n, a, b, error_ab ) call r8mat_is_inverse ( n, a, c, error_ac ) norm_frobenius = r8mat_norm_fro ( n, n, a ) write ( *, '(2x,a20,2x,i4,2x,g14.6,2x,g14.6,2x,g14.6)' ) & title, n, norm_frobenius, error_ab, error_ac c c RUTIS1 c title = 'RUTIS1' n = 4 call rutis1_matrix ( a ) call rutis1_inverse ( b ) call r8mat_inverse ( n, a, c ) call r8mat_is_inverse ( n, a, b, error_ab ) call r8mat_is_inverse ( n, a, c, error_ac ) norm_frobenius = r8mat_norm_fro ( n, n, a ) write ( *, '(2x,a20,2x,i4,2x,g14.6,2x,g14.6,2x,g14.6)' ) & title, n, norm_frobenius, error_ab, error_ac c c RUTIS2 c title = 'RUTIS2' n = 4 call rutis2_matrix ( a ) call rutis2_inverse ( b ) call r8mat_inverse ( n, a, c ) call r8mat_is_inverse ( n, a, b, error_ab ) call r8mat_is_inverse ( n, a, c, error_ac ) norm_frobenius = r8mat_norm_fro ( n, n, a ) write ( *, '(2x,a20,2x,i4,2x,g14.6,2x,g14.6,2x,g14.6)' ) & title, n, norm_frobenius, error_ab, error_ac c c RUTIS3 c title = 'RUTIS3' n = 4 call rutis3_matrix ( a ) call rutis3_inverse ( b ) call r8mat_inverse ( n, a, c ) call r8mat_is_inverse ( n, a, b, error_ab ) call r8mat_is_inverse ( n, a, c, error_ac ) norm_frobenius = r8mat_norm_fro ( n, n, a ) write ( *, '(2x,a20,2x,i4,2x,g14.6,2x,g14.6,2x,g14.6)' ) & title, n, norm_frobenius, error_ab, error_ac c c RUTIS4 c title = 'RUTIS4' n = 5 call rutis4_matrix ( n, a ) call rutis4_inverse ( n, b ) call r8mat_inverse ( n, a, c ) call r8mat_is_inverse ( n, a, b, error_ab ) call r8mat_is_inverse ( n, a, c, error_ac ) norm_frobenius = r8mat_norm_fro ( n, n, a ) write ( *, '(2x,a20,2x,i4,2x,g14.6,2x,g14.6,2x,g14.6)' ) & title, n, norm_frobenius, error_ab, error_ac c c RUTIS5 c title = 'RUTIS5' n = 4 call rutis5_matrix ( a ) call rutis5_inverse ( b ) call r8mat_inverse ( n, a, c ) call r8mat_is_inverse ( n, a, b, error_ab ) call r8mat_is_inverse ( n, a, c, error_ac ) norm_frobenius = r8mat_norm_fro ( n, n, a ) write ( *, '(2x,a20,2x,i4,2x,g14.6,2x,g14.6,2x,g14.6)' ) & title, n, norm_frobenius, error_ab, error_ac c c SCHUR_BLOCK c title = 'SCHUR_BLOCK' n = 5 x_n = ( n + 1 ) / 2 y_n = n / 2 r8_lo = -5.0D+00 r8_hi = +5.0D+00 seed = 123456789 call r8vec_uniform_ab ( x_n, r8_lo, r8_hi, seed, x ) call r8vec_uniform_ab ( y_n, r8_lo, r8_hi, seed, y ) call schur_block_matrix ( n, x, y, a ) call schur_block_inverse ( n, x, y, b ) call r8mat_inverse ( n, a, c ) call r8mat_is_inverse ( n, a, b, error_ab ) call r8mat_is_inverse ( n, a, c, error_ac ) norm_frobenius = r8mat_norm_fro ( n, n, a ) write ( *, '(2x,a20,2x,i4,2x,g14.6,2x,g14.6,2x,g14.6)' ) & title, n, norm_frobenius, error_ab, error_ac c c SPLINE c title = 'SPLINE' n = 5 r8_lo = -5.0D+00 r8_hi = +5.0D+00 seed = 123456789 call r8vec_uniform_ab ( n - 1, r8_lo, r8_hi, seed, x ) call spline_matrix ( n, x, a ) call spline_inverse ( n, x, b ) call r8mat_inverse ( n, a, c ) call r8mat_is_inverse ( n, a, b, error_ab ) call r8mat_is_inverse ( n, a, c, error_ac ) norm_frobenius = r8mat_norm_fro ( n, n, a ) write ( *, '(2x,a20,2x,i4,2x,g14.6,2x,g14.6,2x,g14.6)' ) & title, n, norm_frobenius, error_ab, error_ac c c STIRLING c title = 'STIRLING' n = 5 call stirling_matrix ( n, n, a ) call stirling_inverse ( n, b ) call r8mat_inverse ( n, a, c ) call r8mat_is_inverse ( n, a, b, error_ab ) call r8mat_is_inverse ( n, a, c, error_ac ) norm_frobenius = r8mat_norm_fro ( n, n, a ) write ( *, '(2x,a20,2x,i4,2x,g14.6,2x,g14.6,2x,g14.6)' ) & title, n, norm_frobenius, error_ab, error_ac c c SWEET1 c title = 'SWEET1' n = 6 call sweet1_matrix ( a ) call sweet1_inverse ( b ) call r8mat_inverse ( n, a, c ) call r8mat_is_inverse ( n, a, b, error_ab ) call r8mat_is_inverse ( n, a, c, error_ac ) norm_frobenius = r8mat_norm_fro ( n, n, a ) write ( *, '(2x,a20,2x,i4,2x,g14.6,2x,g14.6,2x,g14.6)' ) & title, n, norm_frobenius, error_ab, error_ac c c SWEET2 c title = 'SWEET2' n = 6 call sweet2_matrix ( a ) call sweet2_inverse ( b ) call r8mat_inverse ( n, a, c ) call r8mat_is_inverse ( n, a, b, error_ab ) call r8mat_is_inverse ( n, a, c, error_ac ) norm_frobenius = r8mat_norm_fro ( n, n, a ) write ( *, '(2x,a20,2x,i4,2x,g14.6,2x,g14.6,2x,g14.6)' ) & title, n, norm_frobenius, error_ab, error_ac c c SWEET3 c title = 'SWEET3' n = 6 call sweet3_matrix ( a ) call sweet3_inverse ( b ) call r8mat_inverse ( n, a, c ) call r8mat_is_inverse ( n, a, b, error_ab ) call r8mat_is_inverse ( n, a, c, error_ac ) norm_frobenius = r8mat_norm_fro ( n, n, a ) write ( *, '(2x,a20,2x,i4,2x,g14.6,2x,g14.6,2x,g14.6)' ) & title, n, norm_frobenius, error_ab, error_ac c c SWEET4 c title = 'SWEET4' n = 13 call sweet4_matrix ( a ) call sweet4_inverse ( b ) call r8mat_inverse ( n, a, c ) call r8mat_is_inverse ( n, a, b, error_ab ) call r8mat_is_inverse ( n, a, c, error_ac ) norm_frobenius = r8mat_norm_fro ( n, n, a ) write ( *, '(2x,a20,2x,i4,2x,g14.6,2x,g14.6,2x,g14.6)' ) & title, n, norm_frobenius, error_ab, error_ac c c SUMMATION c title = 'SUMMATION' n = 5 call summation_matrix ( n, n, a ) call summation_inverse ( n, b ) call r8mat_inverse ( n, a, c ) call r8mat_is_inverse ( n, a, b, error_ab ) call r8mat_is_inverse ( n, a, c, error_ac ) norm_frobenius = r8mat_norm_fro ( n, n, a ) write ( *, '(2x,a20,2x,i4,2x,g14.6,2x,g14.6,2x,g14.6)' ) & title, n, norm_frobenius, error_ab, error_ac c c SYLVESTER_KAC c N must be even. c title = 'SYLVESTER_KAC' n = 6 call sylvester_kac_matrix ( n, a ) call sylvester_kac_inverse ( n, b ) call r8mat_inverse ( n, a, c ) call r8mat_is_inverse ( n, a, b, error_ab ) call r8mat_is_inverse ( n, a, c, error_ac ) norm_frobenius = r8mat_norm_fro ( n, n, a ) write ( *, '(2x,a20,2x,i4,2x,g14.6,2x,g14.6,2x,g14.6)' ) & title, n, norm_frobenius, error_ab, error_ac c c SYMM_RANDOM c title = 'SYMM_RANDOM' n = 5 r8_lo = -5.0D+00 r8_hi = +5.0D+00 seed = 123456789 call r8vec_uniform_ab ( n, r8_lo, r8_hi, seed, d ) key = 123456789 call symm_random_matrix ( n, d, key, a ) call symm_random_inverse ( n, d, key, b ) call r8mat_inverse ( n, a, c ) call r8mat_is_inverse ( n, a, b, error_ab ) call r8mat_is_inverse ( n, a, c, error_ac ) norm_frobenius = r8mat_norm_fro ( n, n, a ) write ( *, '(2x,a20,2x,i4,2x,g14.6,2x,g14.6,2x,g14.6)' ) & title, n, norm_frobenius, error_ab, error_ac c c TRI_UPPER c title = 'TRI_UPPER' n = 5 r8_lo = -5.0D+00 r8_hi = +5.0D+00 seed = 123456789 alpha = r8_uniform_ab ( r8_lo, r8_hi, seed ) call tri_upper_matrix ( alpha, n, a ) call tri_upper_inverse ( alpha, n, b ) call r8mat_inverse ( n, a, c ) call r8mat_is_inverse ( n, a, b, error_ab ) call r8mat_is_inverse ( n, a, c, error_ac ) norm_frobenius = r8mat_norm_fro ( n, n, a ) write ( *, '(2x,a20,2x,i4,2x,g14.6,2x,g14.6,2x,g14.6)' ) & title, n, norm_frobenius, error_ab, error_ac c c TRIS c title = 'TRIS' n = 5 r8_lo = -5.0D+00 r8_hi = +5.0D+00 seed = 123456789 alpha = r8_uniform_ab ( r8_lo, r8_hi, seed ) beta = r8_uniform_ab ( r8_lo, r8_hi, seed ) gam = r8_uniform_ab ( r8_lo, r8_hi, seed ) call tris_matrix ( n, n, alpha, beta, gam, a ) call tris_inverse ( n, alpha, beta, gam, b ) call r8mat_inverse ( n, a, c ) call r8mat_is_inverse ( n, a, b, error_ab ) call r8mat_is_inverse ( n, a, c, error_ac ) norm_frobenius = r8mat_norm_fro ( n, n, a ) write ( *, '(2x,a20,2x,i4,2x,g14.6,2x,g14.6,2x,g14.6)' ) & title, n, norm_frobenius, error_ab, error_ac c c TRIV c title = 'TRIV' n = 5 r8_lo = -5.0D+00 r8_hi = +5.0D+00 seed = 123456789 call r8vec_uniform_ab ( n - 1, r8_lo, r8_hi, seed, x ) call r8vec_uniform_ab ( n, r8_lo, r8_hi, seed, y ) call r8vec_uniform_ab ( n - 1, r8_lo, r8_hi, seed, z ) call triv_matrix ( n, x, y, z, a ) call triv_inverse ( n, x, y, z, b ) call r8mat_inverse ( n, a, c ) call r8mat_is_inverse ( n, a, b, error_ab ) call r8mat_is_inverse ( n, a, c, error_ac ) norm_frobenius = r8mat_norm_fro ( n, n, a ) write ( *, '(2x,a20,2x,i4,2x,g14.6,2x,g14.6,2x,g14.6)' ) & title, n, norm_frobenius, error_ab, error_ac c c TRIW c title = 'TRIW' n = 5 i4_lo = 0 i4_hi = n - 1 r8_lo = -5.0D+00 r8_hi = +5.0D+00 seed = 123456789 k = i4_uniform_ab ( i4_lo, i4_hi, seed ) alpha = r8_uniform_ab ( r8_lo, r8_hi, seed ) call triw_matrix ( alpha, k, n, a ) call triw_inverse ( alpha, k, n, b ) call r8mat_inverse ( n, a, c ) call r8mat_is_inverse ( n, a, b, error_ab ) call r8mat_is_inverse ( n, a, c, error_ac ) norm_frobenius = r8mat_norm_fro ( n, n, a ) write ( *, '(2x,a20,2x,i4,2x,g14.6,2x,g14.6,2x,g14.6)' ) & title, n, norm_frobenius, error_ab, error_ac c c UPSHIFT c title = 'UPSHIFT' n = 5 call upshift_matrix ( n, a ) call upshift_inverse ( n, b ) call r8mat_inverse ( n, a, c ) call r8mat_is_inverse ( n, a, b, error_ab ) call r8mat_is_inverse ( n, a, c, error_ac ) norm_frobenius = r8mat_norm_fro ( n, n, a ) write ( *, '(2x,a20,2x,i4,2x,g14.6,2x,g14.6,2x,g14.6)' ) & title, n, norm_frobenius, error_ab, error_ac c c VAND1 c title = 'VAND1' n = 5 r8_lo = -5.0D+00 r8_hi = +5.0D+00 seed = 123456789 call r8vec_uniform_ab ( n, r8_lo, r8_hi, seed, x ) call vand1_matrix ( n, x, a ) call vand1_inverse ( n, x, b ) call r8mat_inverse ( n, a, c ) call r8mat_is_inverse ( n, a, b, error_ab ) call r8mat_is_inverse ( n, a, c, error_ac ) norm_frobenius = r8mat_norm_fro ( n, n, a ) write ( *, '(2x,a20,2x,i4,2x,g14.6,2x,g14.6,2x,g14.6)' ) & title, n, norm_frobenius, error_ab, error_ac c c VAND2 c title = 'VAND2' n = 5 r8_lo = -5.0D+00 r8_hi = +5.0D+00 seed = 123456789 call r8vec_uniform_ab ( n, r8_lo, r8_hi, seed, x ) call vand2_matrix ( n, x, a ) call vand2_inverse ( n, x, b ) call r8mat_inverse ( n, a, c ) call r8mat_is_inverse ( n, a, b, error_ab ) call r8mat_is_inverse ( n, a, c, error_ac ) norm_frobenius = r8mat_norm_fro ( n, n, a ) write ( *, '(2x,a20,2x,i4,2x,g14.6,2x,g14.6,2x,g14.6)' ) & title, n, norm_frobenius, error_ab, error_ac c c WILK03 c title = 'WILK03' n = 3 call wilk03_matrix ( a ) call wilk03_inverse ( b ) call r8mat_inverse ( n, a, c ) call r8mat_is_inverse ( n, a, b, error_ab ) call r8mat_is_inverse ( n, a, c, error_ac ) norm_frobenius = r8mat_norm_fro ( n, n, a ) write ( *, '(2x,a20,2x,i4,2x,g14.6,2x,g14.6,2x,g14.6)' ) & title, n, norm_frobenius, error_ab, error_ac c c WILK04 c title = 'WILK04' n = 4 call wilk04_matrix ( a ) call wilk04_inverse ( b ) call r8mat_inverse ( n, a, c ) call r8mat_is_inverse ( n, a, b, error_ab ) call r8mat_is_inverse ( n, a, c, error_ac ) norm_frobenius = r8mat_norm_fro ( n, n, a ) write ( *, '(2x,a20,2x,i4,2x,g14.6,2x,g14.6,2x,g14.6)' ) & title, n, norm_frobenius, error_ab, error_ac c c WILK05 c title = 'WILK05' n = 5 call wilk05_matrix ( a ) call wilk05_inverse ( b ) call r8mat_inverse ( n, a, c ) call r8mat_is_inverse ( n, a, b, error_ab ) call r8mat_is_inverse ( n, a, c, error_ac ) norm_frobenius = r8mat_norm_fro ( n, n, a ) write ( *, '(2x,a20,2x,i4,2x,g14.6,2x,g14.6,2x,g14.6)' ) & title, n, norm_frobenius, error_ab, error_ac c c WILK21 c title = 'WILK21' n = 21 call wilk21_matrix ( n, a ) call wilk21_inverse ( n, b ) call r8mat_inverse ( n, a, c ) call r8mat_is_inverse ( n, a, b, error_ab ) call r8mat_is_inverse ( n, a, c, error_ac ) norm_frobenius = r8mat_norm_fro ( n, n, a ) write ( *, '(2x,a20,2x,i4,2x,g14.6,2x,g14.6,2x,g14.6)' ) & title, n, norm_frobenius, error_ab, error_ac c c WILSON c title = 'WILSON' n = 4 call wilson_matrix ( a ) call wilson_inverse ( b ) call r8mat_inverse ( n, a, c ) call r8mat_is_inverse ( n, a, b, error_ab ) call r8mat_is_inverse ( n, a, c, error_ac ) norm_frobenius = r8mat_norm_fro ( n, n, a ) write ( *, '(2x,a20,2x,i4,2x,g14.6,2x,g14.6,2x,g14.6)' ) & title, n, norm_frobenius, error_ab, error_ac return end subroutine test_llt ( ) c*********************************************************************72 c cc test_llt() tests LLT factors. c c Licensing: c c This code is distributed under the MIT license. c c Modified: c c 09 April 2015 c c Author: c c John Burkardt c implicit none integer n_max parameter ( n_max = 25 ) double precision a(n_max,n_max) double precision alpha double precision error_frobenius double precision l(n_max,n_max) integer m integer n double precision norm_a_frobenius double precision r8_hi double precision r8_lo double precision r8_uniform_ab double precision r8mat_norm_fro integer seed character * ( 20 ) title write ( *, '(a)' ) '' write ( *, '(a)' ) 'TEST_LLT' write ( *, '(a)' ) ' A = a test matrix of order M by M' write ( *, '(a)' ) & ' L is an M by N lower triangular Cholesky factor.' write ( *, '(a)' ) '' write ( *, '(a)' ) ' ||A|| = Frobenius norm of A.' write ( *, '(a)' ) ' ||A-LLT|| = Frobenius norm of A-L*L''.' write ( *, '(a)' ) '' write ( *, '(a)' ) ' Title M N' // & ' ||A|| ||A-LLT||' write ( *, '(a)' ) '' c c DIF2 c title = 'DIF2' m = 5 n = 5 call dif2_matrix ( m, n, a ) call dif2_llt ( n, l ) call r8mat_is_llt ( m, n, a, l, error_frobenius ) norm_a_frobenius = r8mat_norm_fro ( m, n, a ) write ( *, '(2x,a20,2x,i4,2x,i4,2x,g14.6,2x,g14.6)' ) & title, m, n, norm_a_frobenius, error_frobenius c c GIVENS c title = 'GIVENS' m = 5 n = 5 call givens_matrix ( m, n, a ) call givens_llt ( n, l ) call r8mat_is_llt ( m, n, a, l, error_frobenius ) norm_a_frobenius = r8mat_norm_fro ( m, n, a ) write ( *, '(2x,a20,2x,i4,2x,i4,2x,g14.6,2x,g14.6)' ) & title, m, n, norm_a_frobenius, error_frobenius c c KERSHAW c title = 'KERSHAW' m = 4 n = 4 call kershaw_matrix ( a ) call kershaw_llt ( l ) call r8mat_is_llt ( m, n, a, l, error_frobenius ) norm_a_frobenius = r8mat_norm_fro ( m, n, a ) write ( *, '(2x,a20,2x,i4,2x,i4,2x,g14.6,2x,g14.6)' ) & title, m, n, norm_a_frobenius, error_frobenius c c LEHMER c title = 'LEHMER' m = 5 n = 5 call lehmer_matrix ( n, n, a ) call lehmer_llt ( n, l ) call r8mat_is_llt ( m, n, a, l, error_frobenius ) norm_a_frobenius = r8mat_norm_fro ( m, n, a ) write ( *, '(2x,a20,2x,i4,2x,i4,2x,g14.6,2x,g14.6)' ) & title, m, n, norm_a_frobenius, error_frobenius c c MINIJ c title = 'MINIJ' m = 5 n = 5 call minij_matrix ( n, n, a ) call minij_llt ( n, l ) call r8mat_is_llt ( m, n, a, l, error_frobenius ) norm_a_frobenius = r8mat_norm_fro ( m, n, a ) write ( *, '(2x,a20,2x,i4,2x,i4,2x,g14.6,2x,g14.6)' ) & title, m, n, norm_a_frobenius, error_frobenius c c MOLER1 c title = 'MOLER1' m = 5 n = 5 r8_lo = -5.0D+00 r8_hi = +5.0D+00 seed = 123456789 alpha = r8_uniform_ab ( r8_lo, r8_hi, seed ) call moler1_matrix ( alpha, m, n, a ) call moler1_llt ( alpha, n, l ) call r8mat_is_llt ( m, n, a, l, error_frobenius ) norm_a_frobenius = r8mat_norm_fro ( m, n, a ) write ( *, '(2x,a20,2x,i4,2x,i4,2x,g14.6,2x,g14.6)' ) & title, m, n, norm_a_frobenius, error_frobenius c c MOLER3 c title = 'MOLER3' m = 5 n = 5 call moler3_matrix ( m, n, a ) call moler3_llt ( n, l ) call r8mat_is_llt ( m, n, a, l, error_frobenius ) norm_a_frobenius = r8mat_norm_fro ( m, n, a ) write ( *, '(2x,a20,2x,i4,2x,i4,2x,g14.6,2x,g14.6)' ) & title, m, n, norm_a_frobenius, error_frobenius c c OTO c title = 'OTO' m = 5 n = 5 call oto_matrix ( m, n, a ) call oto_llt ( n, l ) call r8mat_is_llt ( m, n, a, l, error_frobenius ) norm_a_frobenius = r8mat_norm_fro ( m, n, a ) write ( *, '(2x,a20,2x,i4,2x,i4,2x,g14.6,2x,g14.6)' ) & title, m, n, norm_a_frobenius, error_frobenius c c PASCAL2 c title = 'PASCAL2' m = 5 n = 5 call pascal2_matrix ( n, a ) call pascal2_llt ( n, l ) call r8mat_is_llt ( m, n, a, l, error_frobenius ) norm_a_frobenius = r8mat_norm_fro ( m, n, a ) write ( *, '(2x,a20,2x,i4,2x,i4,2x,g14.6,2x,g14.6)' ) & title, m, n, norm_a_frobenius, error_frobenius c c WILSON c title = 'WILSON' m = 4 n = 4 call wilson_matrix ( a ) call wilson_llt ( l ) call r8mat_is_llt ( m, n, a, l, error_frobenius ) norm_a_frobenius = r8mat_norm_fro ( m, n, a ) write ( *, '(2x,a20,2x,i4,2x,i4,2x,g14.6,2x,g14.6)' ) & title, m, n, norm_a_frobenius, error_frobenius return end subroutine test_null_left ( ) c*********************************************************************72 c cc test_null_left() tests left null vectors. c c Licensing: c c This code is distributed under the MIT license. c c Modified: c c 13 March 2015 c c Author: c c John Burkardt c implicit none integer n_max parameter ( n_max = 25 ) double precision a(n_max,n_max) double precision alpha double precision error_l2 double precision f1 double precision f2 integer m integer n double precision norm_a_frobenius double precision norm_x_l2 double precision r8_hi double precision r8_lo double precision r8_uniform_ab double precision r8mat_norm_fro double precision r8vec_norm_l2 integer seed character*20 title double precision x(n_max) write ( *, '(a)' ) ' ' write ( *, '(a)' ) 'TEST_NULL_LEFT' write ( *, '(a)' ) ' A = a test matrix of order M by N' write ( *, '(a)' ) & ' x = an M vector, candidate for a left null vector.' write ( *, '(a)' ) ' ' write ( *, '(a)' ) ' ||A|| = Frobenius norm of A.' write ( *, '(a)' ) ' ||x|| = L2 norm of x.' write ( *, '(a)' ) & ' ||A''*x||/||x|| = L2 norm of A''*x over L2 norm of x.' write ( *, '(a)' ) ' ' write ( *, '(a)' ) ' Title M N ' // & '||A|| ||x|| ||A''*x||/||x||' write ( *, '(a)' ) ' ' c c A123 c title = 'A123' m = 3 n = 3 call a123_matrix ( a ) call a123_null_left ( x ) call r8mat_is_null_left ( m, n, a, x, error_l2 ) norm_a_frobenius = r8mat_norm_fro ( m, n, a ) norm_x_l2 = r8vec_norm_l2 ( m, x ) write ( *, '(2x,a20,2x,i4,2x,i4,2x,g14.6,2x,g14.6,2x,g14.6)' ) & title, m, n, norm_a_frobenius, norm_x_l2, error_l2 c c CHEBY_DIFf1 c title = 'CHEBY_DIFF1' m = 5 n = m call cheby_diff1_matrix ( n, a ) call cheby_diff1_null_left ( m, n, x ) call r8mat_is_null_left ( m, n, a, x, error_l2 ) norm_a_frobenius = r8mat_norm_fro ( m, n, a ) norm_x_l2 = r8vec_norm_l2 ( m, x ) write ( *, '(2x,a20,2x,i4,2x,i4,2x,g14.6,2x,g14.6,2x,g14.6)' ) & title, m, n, norm_a_frobenius, norm_x_l2, error_l2 c c CREATION c title = 'CREATION' m = 5 n = m call creation_matrix ( m, n, a ) call creation_null_left ( m, n, x ) call r8mat_is_null_left ( m, n, a, x, error_l2 ) norm_a_frobenius = r8mat_norm_fro ( m, n, a ) norm_x_l2 = r8vec_norm_l2 ( m, x ) write ( *, '(2x,a20,2x,i4,2x,i4,2x,g14.6,2x,g14.6,2x,g14.6)' ) & title, m, n, norm_a_frobenius, norm_x_l2, error_l2 c c DIF1 c Only has null vectors for M odd. c title = 'DIF1' m = 5 n = m call dif1_matrix ( m, n, a ) call dif1_null_left ( m, n, x ) call r8mat_is_null_left ( m, n, a, x, error_l2 ) norm_a_frobenius = r8mat_norm_fro ( m, n, a ) norm_x_l2 = r8vec_norm_l2 ( m, x ) write ( *, '(2x,a20,2x,i4,2x,i4,2x,g14.6,2x,g14.6,2x,g14.6)' ) & title, m, n, norm_a_frobenius, norm_x_l2, error_l2 c c DIF1CYCLIC c title = 'DIF1CYCLIC' m = 5 n = m call dif1cyclic_matrix ( n, a ) call dif1cyclic_null_left ( m, n, x ) call r8mat_is_null_left ( m, n, a, x, error_l2 ) norm_a_frobenius = r8mat_norm_fro ( m, n, a ) norm_x_l2 = r8vec_norm_l2 ( m, x ) write ( *, '(2x,a20,2x,i4,2x,i4,2x,g14.6,2x,g14.6,2x,g14.6)' ) & title, m, n, norm_a_frobenius, norm_x_l2, error_l2 c c DIF2CYCLIC c title = 'DIF2CYCLIC' m = 5 n = m call dif2cyclic_matrix ( n, a ) call dif2cyclic_null_left ( m, n, x ) call r8mat_is_null_left ( m, n, a, x, error_l2 ) norm_a_frobenius = r8mat_norm_fro ( m, n, a ) norm_x_l2 = r8vec_norm_l2 ( m, x ) write ( *, '(2x,a20,2x,i4,2x,i4,2x,g14.6,2x,g14.6,2x,g14.6)' ) & title, m, n, norm_a_frobenius, norm_x_l2, error_l2 c c EBERLEIN c title = 'EBERLEIN' m = 5 n = 5 r8_lo = -5.0D+00 r8_hi = +5.0D+00 seed = 123456789 alpha = r8_uniform_ab ( r8_lo, r8_hi, seed ) call eberlein_matrix ( alpha, n, a ) call eberlein_null_left ( m, n, x ) call r8mat_is_null_left ( m, n, a, x, error_l2 ) norm_a_frobenius = r8mat_norm_fro ( m, n, a ) norm_x_l2 = r8vec_norm_l2 ( m, x ) write ( *, '(2x,a20,2x,i4,2x,i4,2x,g14.6,2x,g14.6,2x,g14.6)' ) & title, m, n, norm_a_frobenius, norm_x_l2, error_l2 c c FIBONACCI1 c title = 'FIBONACCI1' m = 5 n = m r8_lo = -5.0D+00 r8_hi = +5.0D+00 seed = 123456789 f1 = r8_uniform_ab ( r8_lo, r8_hi, seed ) f2 = r8_uniform_ab ( r8_lo, r8_hi, seed ) call fibonacci1_matrix ( n, f1, f2, a ) call fibonacci1_null_left ( m, n, f1, f2, x ) call r8mat_is_null_left ( m, n, a, x, error_l2 ) norm_a_frobenius = r8mat_norm_fro ( m, n, a ) norm_x_l2 = r8vec_norm_l2 ( m, x ) write ( *, '(2x,a20,2x,i4,2x,i4,2x,g14.6,2x,g14.6,2x,g14.6)' ) & title, m, n, norm_a_frobenius, norm_x_l2, error_l2 c c LAUCHLI c title = 'LAUCHLI' m = 6 n = m - 1 r8_lo = -5.0D+00 r8_hi = +5.0D+00 seed = 123456789 alpha = r8_uniform_ab ( r8_lo, r8_hi, seed ) call lauchli_matrix ( alpha, m, n, a ) call lauchli_null_left ( alpha, m, n, x ) call r8mat_is_null_left ( m, n, a, x, error_l2 ) norm_a_frobenius = r8mat_norm_fro ( m, n, a ) norm_x_l2 = r8vec_norm_l2 ( m, x ) write ( *, '(2x,a20,2x,i4,2x,i4,2x,g14.6,2x,g14.6,2x,g14.6)' ) & title, m, n, norm_a_frobenius, norm_x_l2, error_l2 c c LINE_ADJ c title = 'LINE_ADJ' m = 7 n = m call line_adj_matrix ( n, a ) call line_adj_null_left ( m, n, x ) call r8mat_is_null_left ( m, n, a, x, error_l2 ) norm_a_frobenius = r8mat_norm_fro ( m, n, a ) norm_x_l2 = r8vec_norm_l2 ( m, x ) write ( *, '(2x,a20,2x,i4,2x,i4,2x,g14.6,2x,g14.6,2x,g14.6)' ) & title, m, n, norm_a_frobenius, norm_x_l2, error_l2 c c MOLER2 c title = 'MOLER2' m = 5 n = 5 call moler2_matrix ( a ) call moler2_null_left ( x ) call r8mat_is_null_left ( m, n, a, x, error_l2 ) norm_a_frobenius = r8mat_norm_fro ( m, n, a ) norm_x_l2 = r8vec_norm_l2 ( m, x ) write ( *, '(2x,a20,2x,i4,2x,i4,2x,g14.6,2x,g14.6,2x,g14.6)' ) & title, m, n, norm_a_frobenius, norm_x_l2, error_l2 c c ONE c title = 'ONE' m = 5 n = 5 call one_matrix ( m, n, a ) call one_null_left ( m, n, x ) call r8mat_is_null_left ( m, n, a, x, error_l2 ) norm_a_frobenius = r8mat_norm_fro ( m, n, a ) norm_x_l2 = r8vec_norm_l2 ( m, x ) write ( *, '(2x,a20,2x,i4,2x,i4,2x,g14.6,2x,g14.6,2x,g14.6)' ) & title, m, n, norm_a_frobenius, norm_x_l2, error_l2 c c RING_ADJ c M must be a multiple of 4 for there to be a null vector. c title = 'RING_ADJ' m = 12 n = 12 call ring_adj_matrix ( n, a ) call ring_adj_null_left ( m, n, x ) call r8mat_is_null_left ( m, n, a, x, error_l2 ) norm_a_frobenius = r8mat_norm_fro ( m, n, a ) norm_x_l2 = r8vec_norm_l2 ( m, x ) write ( *, '(2x,a20,2x,i4,2x,i4,2x,g14.6,2x,g14.6,2x,g14.6)' ) & title, m, n, norm_a_frobenius, norm_x_l2, error_l2 c c ROSSER1 c title = 'ROSSER1' m = 8 n = 8 call rosser1_matrix ( a ) call rosser1_null_left ( x ) call r8mat_is_null_left ( m, n, a, x, error_l2 ) norm_a_frobenius = r8mat_norm_fro ( m, n, a ) norm_x_l2 = r8vec_norm_l2 ( m, x ) write ( *, '(2x,a20,2x,i4,2x,i4,2x,g14.6,2x,g14.6,2x,g14.6)' ) & title, m, n, norm_a_frobenius, norm_x_l2, error_l2 c c ZERO c title = 'ZERO' m = 5 n = 5 call zero_matrix ( m, n, a ) call zero_null_left ( m, n, x ) call r8mat_is_null_left ( m, n, a, x, error_l2 ) norm_a_frobenius = r8mat_norm_fro ( m, n, a ) norm_x_l2 = r8vec_norm_l2 ( m, x ) write ( *, '(2x,a20,2x,i4,2x,i4,2x,g14.6,2x,g14.6,2x,g14.6)' ) & title, m, n, norm_a_frobenius, norm_x_l2, error_l2 return end subroutine test_null_right ( ) c*********************************************************************72 c cc test_null_right() tests right null vectors. c c Licensing: c c This code is distributed under the MIT license. c c Modified: c c 13 March 2015 c c Author: c c John Burkardt c implicit none integer n_max parameter ( n_max = 70 ) double precision a(n_max,n_max) integer col_num double precision error_l2 double precision f1 double precision f2 integer m integer n double precision norm_a_frobenius double precision norm_x_l2 double precision r8_hi double precision r8_lo double precision r8_uniform_ab double precision r8mat_norm_fro double precision r8vec_norm_l2 integer row_num integer seed character*20 title double precision x(n_max) write ( *, '(a)' ) ' ' write ( *, '(a)' ) 'TEST_NULL_RIGHT' write ( *, '(a)' ) ' A = a test matrix of order M by N' write ( *, '(a)' ) & ' x = an N vector, candidate for a right null vector.' write ( *, '(a)' ) ' ' write ( *, '(a)' ) ' ||A|| = Frobenius norm of A.' write ( *, '(a)' ) ' ||x|| = L2 norm of x.' write ( *, '(a)' ) & ' ||A*x||/||x|| = L2 norm of A*x over L2 norm of x.' write ( *, '(a)' ) ' ' write ( *, '(a)' ) ' Title M N ' // & '||A|| ||x|| ||A*x||/||x||' write ( *, '(a)' ) ' ' c c A123 c title = 'A123' m = 3 n = 3 call a123_matrix ( a ) call a123_null_right ( x ) call r8mat_is_null_right ( m, n, a, x, error_l2 ) norm_a_frobenius = r8mat_norm_fro ( m, n, a ) norm_x_l2 = r8vec_norm_l2 ( n, x ) write ( *, '(2x,a20,2x,i4,2x,i4,2x,g14.6,2x,g14.6,2x,g14.6)' ) & title, m, n, norm_a_frobenius, norm_x_l2, error_l2 c c ARCHIMEDES c title = 'ARCHIMEDES' m = 7 n = 8 call archimedes_matrix ( a ) call archimedes_null_right ( x ) call r8mat_is_null_right ( m, n, a, x, error_l2 ) norm_a_frobenius = r8mat_norm_fro ( m, n, a ) norm_x_l2 = r8vec_norm_l2 ( n, x ) write ( *, '(2x,a20,2x,i4,2x,i4,2x,g14.6,2x,g14.6,2x,g14.6)' ) & title, m, n, norm_a_frobenius, norm_x_l2, error_l2 c c CHEBY_DIFf1 c title = 'CHEBY_DIFF1' m = 5 n = m call cheby_diff1_matrix ( n, a ) call cheby_diff1_null_right ( m, n, x ) call r8mat_is_null_right ( m, n, a, x, error_l2 ) norm_a_frobenius = r8mat_norm_fro ( m, n, a ) norm_x_l2 = r8vec_norm_l2 ( n, x ) write ( *, '(2x,a20,2x,i4,2x,i4,2x,g14.6,2x,g14.6,2x,g14.6)' ) & title, m, n, norm_a_frobenius, norm_x_l2, error_l2 c c CREATION c title = 'CREATION' m = 5 n = m call creation_matrix ( m, n, a ) call creation_null_right ( m, n, x ) call r8mat_is_null_right ( m, n, a, x, error_l2 ) norm_a_frobenius = r8mat_norm_fro ( m, n, a ) norm_x_l2 = r8vec_norm_l2 ( n, x ) write ( *, '(2x,a20,2x,i4,2x,i4,2x,g14.6,2x,g14.6,2x,g14.6)' ) & title, m, n, norm_a_frobenius, norm_x_l2, error_l2 c c DIF1 c Only has null vectors for N odd. c title = 'DIF1' m = 5 n = m call dif1_matrix ( m, n, a ) call dif1_null_right ( m, n, x ) call r8mat_is_null_right ( m, n, a, x, error_l2 ) norm_a_frobenius = r8mat_norm_fro ( m, n, a ) norm_x_l2 = r8vec_norm_l2 ( n, x ) write ( *, '(2x,a20,2x,i4,2x,i4,2x,g14.6,2x,g14.6,2x,g14.6)' ) & title, m, n, norm_a_frobenius, norm_x_l2, error_l2 c c DIF1CYCLIC c title = 'DIF1CYCLIC' m = 5 n = m call dif1cyclic_matrix ( n, a ) call dif1cyclic_null_right ( m, n, x ) call r8mat_is_null_right ( m, n, a, x, error_l2 ) norm_a_frobenius = r8mat_norm_fro ( m, n, a ) norm_x_l2 = r8vec_norm_l2 ( n, x ) write ( *, '(2x,a20,2x,i4,2x,i4,2x,g14.6,2x,g14.6,2x,g14.6)' ) & title, m, n, norm_a_frobenius, norm_x_l2, error_l2 c c DIF2CYCLIC c title = 'DIF2CYCLIC' m = 5 n = m call dif2cyclic_matrix ( n, a ) call dif2cyclic_null_right ( m, n, x ) call r8mat_is_null_right ( m, n, a, x, error_l2 ) norm_a_frobenius = r8mat_norm_fro ( m, n, a ) norm_x_l2 = r8vec_norm_l2 ( n, x ) write ( *, '(2x,a20,2x,i4,2x,i4,2x,g14.6,2x,g14.6,2x,g14.6)' ) & title, m, n, norm_a_frobenius, norm_x_l2, error_l2 c c FIBONACCI1 c title = 'FIBONACCI1' m = 5 n = m r8_lo = -5.0D+00 r8_hi = +5.0D+00 seed = 123456789 f1 = r8_uniform_ab ( r8_lo, r8_hi, seed ) f2 = r8_uniform_ab ( r8_lo, r8_hi, seed ) call fibonacci1_matrix ( n, f1, f2, a ) call fibonacci1_null_right ( m, n, f1, f2, x ) call r8mat_is_null_right ( m, n, a, x, error_l2 ) norm_a_frobenius = r8mat_norm_fro ( m, n, a ) norm_x_l2 = r8vec_norm_l2 ( n, x ) write ( *, '(2x,a20,2x,i4,2x,i4,2x,g14.6,2x,g14.6,2x,g14.6)' ) & title, m, n, norm_a_frobenius, norm_x_l2, error_l2 c c HAMMING c title = 'HAMMING' m = 5 n = ( 2 ** m ) - 1 call hamming_matrix ( m, n, a ) call hamming_null_right ( m, n, x ) call r8mat_is_null_right ( m, n, a, x, error_l2 ) norm_a_frobenius = r8mat_norm_fro ( m, n, a ) norm_x_l2 = r8vec_norm_l2 ( n, x ) write ( *, '(2x,a20,2x,i4,2x,i4,2x,g14.6,2x,g14.6,2x,g14.6)' ) & title, m, n, norm_a_frobenius, norm_x_l2, error_l2 c c LINE_ADJ c title = 'LINE_ADJ' m = 7 n = m call line_adj_matrix ( n, a ) call line_adj_null_right ( m, n, x ) call r8mat_is_null_right ( m, n, a, x, error_l2 ) norm_a_frobenius = r8mat_norm_fro ( m, n, a ) norm_x_l2 = r8vec_norm_l2 ( n, x ) write ( *, '(2x,a20,2x,i4,2x,i4,2x,g14.6,2x,g14.6,2x,g14.6)' ) & title, m, n, norm_a_frobenius, norm_x_l2, error_l2 c c MOLER2 c title = 'MOLER2' m = 5 n = 5 call moler2_matrix ( a ) call moler2_null_right ( x ) call r8mat_is_null_right ( m, n, a, x, error_l2 ) norm_a_frobenius = r8mat_norm_fro ( m, n, a ) norm_x_l2 = r8vec_norm_l2 ( n, x ) write ( *, '(2x,a20,2x,i4,2x,i4,2x,g14.6,2x,g14.6,2x,g14.6)' ) & title, m, n, norm_a_frobenius, norm_x_l2, error_l2 c c NEUMANN c title = 'NEUMANN' row_num = 5 col_num = 5 m = row_num * col_num n = row_num * col_num call neumann_matrix ( row_num, col_num, a ) call neumann_null_right ( row_num, col_num, x ) call r8mat_is_null_right ( m, n, a, x, error_l2 ) norm_a_frobenius = r8mat_norm_fro ( m, n, a ) norm_x_l2 = r8vec_norm_l2 ( n, x ) write ( *, '(2x,a20,2x,i4,2x,i4,2x,g14.6,2x,g14.6,2x,g14.6)' ) & title, m, n, norm_a_frobenius, norm_x_l2, error_l2 c c ONE c title = 'ONE' m = 5 n = 5 call one_matrix ( m, n, a ) call one_null_right ( m, n, x ) call r8mat_is_null_right ( m, n, a, x, error_l2 ) norm_a_frobenius = r8mat_norm_fro ( m, n, a ) norm_x_l2 = r8vec_norm_l2 ( n, x ) write ( *, '(2x,a20,2x,i4,2x,i4,2x,g14.6,2x,g14.6,2x,g14.6)' ) & title, m, n, norm_a_frobenius, norm_x_l2, error_l2 c c RING_ADJ c N must be a multiple of 4 for there to be a null vector. c title = 'RING_ADJ' m = 12 n = 12 call ring_adj_matrix ( n, a ) call ring_adj_null_right ( m, n, x ) call r8mat_is_null_right ( m, n, a, x, error_l2 ) norm_a_frobenius = r8mat_norm_fro ( m, n, a ) norm_x_l2 = r8vec_norm_l2 ( n, x ) write ( *, '(2x,a20,2x,i4,2x,i4,2x,g14.6,2x,g14.6,2x,g14.6)' ) & title, m, n, norm_a_frobenius, norm_x_l2, error_l2 c c ROSSER1 c title = 'ROSSER1' m = 8 n = 8 call rosser1_matrix ( a ) call rosser1_null_right ( x ) call r8mat_is_null_right ( m, n, a, x, error_l2 ) norm_a_frobenius = r8mat_norm_fro ( m, n, a ) norm_x_l2 = r8vec_norm_l2 ( n, x ) write ( *, '(2x,a20,2x,i4,2x,i4,2x,g14.6,2x,g14.6,2x,g14.6)' ) & title, m, n, norm_a_frobenius, norm_x_l2, error_l2 c c ZERO c title = 'ZERO' m = 5 n = 5 call zero_matrix ( m, n, a ) call zero_null_right ( m, n, x ) call r8mat_is_null_right ( m, n, a, x, error_l2 ) norm_a_frobenius = r8mat_norm_fro ( m, n, a ) norm_x_l2 = r8vec_norm_l2 ( n, x ) write ( *, '(2x,a20,2x,i4,2x,i4,2x,g14.6,2x,g14.6,2x,g14.6)' ) & title, m, n, norm_a_frobenius, norm_x_l2, error_l2 return end subroutine test_plu ( ) c*********************************************************************72 c cc TEST_PLU tests the PLU factors. c c Licensing: c c This code is distributed under the MIT license. c c Modified: c c 06 April 2015 c c Author: c c John Burkardt c implicit none integer m_max parameter ( m_max = 25 ) integer n_max parameter ( n_max = 25 ) double precision a(m_max,n_max) double precision alpha double precision error_frobenius integer i integer i4_hi integer i4_lo integer i4_uniform_ab double precision l(m_max,n_max) integer m integer n double precision norm_a_frobenius double precision p(m_max,n_max) integer pivot(n_max) double precision r8_hi double precision r8_lo double precision r8_uniform_ab double precision r8mat_norm_fro integer seed character * ( 20 ) title double precision u(m_max,n_max) double precision x(n_max) write ( *, '(a)' ) ' ' write ( *, '(a)' ) 'TEST_PLU' write ( *, '(a)' ) ' A = a test matrix of order M by N' write ( *, '(a)' ) ' P, L, U are the PLU factors.' write ( *, '(a)' ) ' ' write ( *, '(a)' ) ' ||A|| = Frobenius norm of A.' write ( *, '(a)' ) ' ||A-PLU|| = Frobenius norm of A-P*L*U.' write ( *, '(a)' ) ' ' write ( *, '(a)' ) ' Title M N ' & // '||A|| ||A-PLU||' write ( *, '(a)' ) ' ' c c A123 c title = 'A123' m = 3 n = 3 call a123_matrix ( a ) call a123_plu ( p, l, u ) call r8mat_is_plu ( m, n, a, p, l, u, error_frobenius ) norm_a_frobenius = r8mat_norm_fro ( m, n, a ) write ( *, '(2x,a20,2x,i4,2x,i4,2x,g14.6,2x,g14.6,2x,g14.6)' ) & title, m, n, norm_a_frobenius, error_frobenius c c BODEWIG c title = 'BODEWIG' m = 4 n = 4 call bodewig_matrix ( a ) call bodewig_plu ( p, l, u ) call r8mat_is_plu ( m, n, a, p, l, u, error_frobenius ) norm_a_frobenius = r8mat_norm_fro ( m, n, a ) write ( *, '(2x,a20,2x,i4,2x,i4,2x,g14.6,2x,g14.6,2x,g14.6)' ) & title, m, n, norm_a_frobenius, error_frobenius c c BORDERBAND c title = 'BORDERBAND' m = 5 n = 5 call borderband_matrix ( n, a ) call borderband_plu ( n, p, l, u ) call r8mat_is_plu ( m, n, a, p, l, u, error_frobenius ) norm_a_frobenius = r8mat_norm_fro ( m, n, a ) write ( *, '(2x,a20,2x,i4,2x,i4,2x,g14.6,2x,g14.6,2x,g14.6)' ) & title, m, n, norm_a_frobenius, error_frobenius c c DIF2 c title = 'DIF2' m = 5 n = 5 call dif2_matrix ( m, n, a ) call dif2_plu ( n, p, l, u ) call r8mat_is_plu ( m, n, a, p, l, u, error_frobenius ) norm_a_frobenius = r8mat_norm_fro ( m, n, a ) write ( *, '(2x,a20,2x,i4,2x,i4,2x,g14.6,2x,g14.6,2x,g14.6)' ) & title, m, n, norm_a_frobenius, error_frobenius c c GFPP c title = 'GFPP' m = 5 n = 5 r8_lo = -5.0D+00 r8_hi = +5.0D+00 seed = 123456789 alpha = r8_uniform_ab ( r8_lo, r8_hi, seed ) call gfpp_matrix ( n, alpha, a ) call gfpp_plu ( n, alpha, p, l, u ) call r8mat_is_plu ( m, n, a, p, l, u, error_frobenius ) norm_a_frobenius = r8mat_norm_fro ( m, n, a ) write ( *, '(2x,a20,2x,i4,2x,i4,2x,g14.6,2x,g14.6,2x,g14.6)' ) & title, m, n, norm_a_frobenius, error_frobenius c c GIVENS c title = 'GIVENS' m = 5 n = 5 call givens_matrix ( n, n, a ) call givens_plu ( n, p, l, u ) call r8mat_is_plu ( m, n, a, p, l, u, error_frobenius ) norm_a_frobenius = r8mat_norm_fro ( m, n, a ) write ( *, '(2x,a20,2x,i4,2x,i4,2x,g14.6,2x,g14.6,2x,g14.6)' ) & title, m, n, norm_a_frobenius, error_frobenius c c KMS c title = 'KMS' m = 5 n = 5 r8_lo = -5.0D+00 r8_hi = +5.0D+00 seed = 123456789 alpha = r8_uniform_ab ( r8_lo, r8_hi, seed ) call kms_matrix ( alpha, m, n, a ) call kms_plu ( alpha, n, p, l, u ) call r8mat_is_plu ( m, n, a, p, l, u, error_frobenius ) norm_a_frobenius = r8mat_norm_fro ( m, n, a ) write ( *, '(2x,a20,2x,i4,2x,i4,2x,g14.6,2x,g14.6,2x,g14.6)' ) & title, m, n, norm_a_frobenius, error_frobenius c c LEHMER c title = 'LEHMER' m = 5 n = 5 call lehmer_matrix ( n, n, a ) call lehmer_plu ( n, p, l, u ) call r8mat_is_plu ( m, n, a, p, l, u, error_frobenius ) norm_a_frobenius = r8mat_norm_fro ( m, n, a ) write ( *, '(2x,a20,2x,i4,2x,i4,2x,g14.6,2x,g14.6,2x,g14.6)' ) & title, m, n, norm_a_frobenius, error_frobenius c c MAXIJ c title = 'MAXIJ' m = 5 n = 5 call maxij_matrix ( n, n, a ) call maxij_plu ( n, p, l, u ) call r8mat_is_plu ( m, n, a, p, l, u, error_frobenius ) norm_a_frobenius = r8mat_norm_fro ( m, n, a ) write ( *, '(2x,a20,2x,i4,2x,i4,2x,g14.6,2x,g14.6,2x,g14.6)' ) & title, m, n, norm_a_frobenius, error_frobenius c c MINIJ c title = 'MINIJ' m = 5 n = 5 call minij_matrix ( n, n, a ) call minij_plu ( n, p, l, u ) call r8mat_is_plu ( m, n, a, p, l, u, error_frobenius ) norm_a_frobenius = r8mat_norm_fro ( m, n, a ) write ( *, '(2x,a20,2x,i4,2x,i4,2x,g14.6,2x,g14.6,2x,g14.6)' ) & title, m, n, norm_a_frobenius, error_frobenius c c MOLER1 c title = 'MOLER1' m = 5 n = 5 r8_lo = -5.0D+00 r8_hi = +5.0D+00 seed = 123456789 alpha = r8_uniform_ab ( r8_lo, r8_hi, seed ) call moler1_matrix ( alpha, n, n, a ) call moler1_plu ( alpha, n, p, l, u ) call r8mat_is_plu ( m, n, a, p, l, u, error_frobenius ) norm_a_frobenius = r8mat_norm_fro ( m, n, a ) write ( *, '(2x,a20,2x,i4,2x,i4,2x,g14.6,2x,g14.6,2x,g14.6)' ) & title, m, n, norm_a_frobenius, error_frobenius c c MOLER3 c title = 'MOLER3' m = 5 n = 5 call moler3_matrix ( m, n, a ) call moler3_plu ( n, p, l, u ) call r8mat_is_plu ( m, n, a, p, l, u, error_frobenius ) norm_a_frobenius = r8mat_norm_fro ( m, n, a ) write ( *, '(2x,a20,2x,i4,2x,i4,2x,g14.6,2x,g14.6,2x,g14.6)' ) & title, m, n, norm_a_frobenius, error_frobenius c c OTO c title = 'OTO' m = 5 n = 5 call oto_matrix ( m, n, a ) call oto_plu ( n, p, l, u ) call r8mat_is_plu ( m, n, a, p, l, u, error_frobenius ) norm_a_frobenius = r8mat_norm_fro ( m, n, a ) write ( *, '(2x,a20,2x,i4,2x,i4,2x,g14.6,2x,g14.6,2x,g14.6)' ) & title, m, n, norm_a_frobenius, error_frobenius c c PASCAL2 c title = 'PASCAL2' m = 5 n = 5 call pascal2_matrix ( n, a ) call pascal2_plu ( n, p, l, u ) call r8mat_is_plu ( m, n, a, p, l, u, error_frobenius ) norm_a_frobenius = r8mat_norm_fro ( m, n, a ) write ( *, '(2x,a20,2x,i4,2x,i4,2x,g14.6,2x,g14.6,2x,g14.6)' ) & title, m, n, norm_a_frobenius, error_frobenius c c PLU c title = 'PLU' n = 5 seed = 123456789 do i = 1, n i4_lo = i i4_hi = n pivot(i) = i4_uniform_ab ( i4_lo, i4_hi, seed ) end do call plu_matrix ( n, pivot, a ) call plu_plu ( n, pivot, p, l, u ) call r8mat_is_plu ( m, n, a, p, l, u, error_frobenius ) norm_a_frobenius = r8mat_norm_fro ( m, n, a ) write ( *, '(2x,a20,2x,i4,2x,i4,2x,g14.6,2x,g14.6,2x,g14.6)' ) & title, m, n, norm_a_frobenius, error_frobenius c c VAND2 c title = 'VAND2' m = 4 n = 4 r8_lo = -5.0D+00 r8_hi = +5.0D+00 seed = 123456789 call r8vec_uniform_ab ( m, r8_lo, r8_hi, seed, x ) call vand2_matrix ( m, x, a ) call vand2_plu ( m, x, p, l, u ) call r8mat_is_plu ( m, n, a, p, l, u, error_frobenius ) norm_a_frobenius = r8mat_norm_fro ( m, n, a ) write ( *, '(2x,a20,2x,i4,2x,i4,2x,g14.6,2x,g14.6,2x,g14.6)' ) & title, m, n, norm_a_frobenius, error_frobenius c c WILSON c title = 'WILSON' m = 4 n = 4 call wilson_matrix ( a ) call wilson_plu ( p, l, u ) call r8mat_is_plu ( m, n, a, p, l, u, error_frobenius ) norm_a_frobenius = r8mat_norm_fro ( m, n, a ) write ( *, '(2x,a20,2x,i4,2x,i4,2x,g14.6,2x,g14.6,2x,g14.6)' ) & title, m, n, norm_a_frobenius, error_frobenius return end subroutine test_solution ( ) c*********************************************************************72 c cc TEST_SOLUTION tests the linear solution computations. c c Licensing: c c This code is distributed under the MIT license. c c Modified: c c 08 March 2015 c c Author: c c John Burkardt c implicit none integer n_max parameter ( n_max = 20 ) double precision a(n_max,n_max) double precision b(n_max,n_max) double precision error_frobenius integer k integer m integer n integer ncol double precision norm_frobenius integer nrow double precision r8mat_norm_fro character*20 title double precision x(n_max) write ( *, '(a)' ) ' ' write ( *, '(a)' ) 'test_solution():' write ( *, '(a)' ) & ' Compute the Frobenius norm of the solution error:' write ( *, '(a)' ) ' A * X - B' write ( *, '(a)' ) & ' given MxN matrix A, NxK solution X, MxK right hand side B.' write ( *, '(a)' ) ' ' write ( *, '(a)' ) & ' Title M N' // & ' K ||A|| ||A*X-B||' write ( *, '(a)' ) ' ' c c A123 c title = 'A123' m = 3 n = 3 k = 1 call a123_matrix ( a ) call a123_rhs ( b ) call a123_solution ( x ) call r8mat_is_solution ( m, n, k, a, x, b, error_frobenius ) norm_frobenius = r8mat_norm_fro ( n, n, a ) write ( *, '(2x,a20,2x,i4,2x,i4,2x,i4,2x,g14.6,2x,g14.6)' ) & title, m, n, k, norm_frobenius, error_frobenius c c BODEWIG c title = 'BODEWIG' m = 4 n = 4 k = 1 call bodewig_matrix ( a ) call bodewig_rhs ( b ) call bodewig_solution ( x ) call r8mat_is_solution ( m, n, k, a, x, b, error_frobenius ) norm_frobenius = r8mat_norm_fro ( n, n, a ) write ( *, '(2x,a20,2x,i4,2x,i4,2x,i4,2x,g14.6,2x,g14.6)' ) & title, m, n, k, norm_frobenius, error_frobenius c c DIF2 c title = 'DIF2' m = 10 n = 10 k = 2 call dif2_matrix ( m, n, a ) call dif2_rhs ( m, k, b ) call dif2_solution ( n, k, x ) call r8mat_is_solution ( m, n, k, a, x, b, error_frobenius ) norm_frobenius = r8mat_norm_fro ( n, n, a ) write ( *, '(2x,a20,2x,i4,2x,i4,2x,i4,2x,g14.6,2x,g14.6)' ) & title, m, n, k, norm_frobenius, error_frobenius c c FRANK c title = 'FRANK' m = 10 n = 10 k = 2 call frank_matrix ( n, a ) call frank_rhs ( m, k, b ) call frank_solution ( n, k, x ) call r8mat_is_solution ( m, n, k, a, x, b, error_frobenius ) norm_frobenius = r8mat_norm_fro ( n, n, a ) write ( *, '(2x,a20,2x,i4,2x,i4,2x,i4,2x,g14.6,2x,g14.6)' ) & title, m, n, k, norm_frobenius, error_frobenius c c POISSON c title = 'POISSON' nrow = 4 ncol = 5 m = nrow * ncol n = nrow * ncol k = 1 call poisson_matrix ( nrow, ncol, a ) call poisson_rhs ( nrow, ncol, b ) call poisson_solution ( nrow, ncol, x ) call r8mat_is_solution ( m, n, k, a, x, b, error_frobenius ) norm_frobenius = r8mat_norm_fro ( n, n, a ) write ( *, '(2x,a20,2x,i4,2x,i4,2x,i4,2x,g14.6,2x,g14.6)' ) & title, m, n, k, norm_frobenius, error_frobenius c c WILK03 c title = 'WILK03' m = 3 n = 3 k = 1 call wilk03_matrix ( a ) call wilk03_rhs ( b ) call wilk03_solution ( x ) call r8mat_is_solution ( m, n, k, a, x, b, error_frobenius ) norm_frobenius = r8mat_norm_fro ( n, n, a ) write ( *, '(2x,a20,2x,i4,2x,i4,2x,i4,2x,g14.6,2x,g14.6)' ) & title, m, n, k, norm_frobenius, error_frobenius c c WILK04 c title = 'WILK04' m = 4 n = 4 k = 1 call wilk04_matrix ( a ) call wilk04_rhs ( b ) call wilk04_solution ( x ) call r8mat_is_solution ( m, n, k, a, x, b, error_frobenius ) norm_frobenius = r8mat_norm_fro ( n, n, a ) write ( *, '(2x,a20,2x,i4,2x,i4,2x,i4,2x,g14.6,2x,g14.6)' ) & title, m, n, k, norm_frobenius, error_frobenius c c WILSON c title = 'WILSON' m = 4 n = 4 k = 1 call wilson_matrix ( a ) call wilson_rhs ( b ) call wilson_solution ( x ) call r8mat_is_solution ( m, n, k, a, x, b, error_frobenius ) norm_frobenius = r8mat_norm_fro ( n, n, a ) write ( *, '(2x,a20,2x,i4,2x,i4,2x,i4,2x,g14.6,2x,g14.6)' ) & title, m, n, k, norm_frobenius, error_frobenius return end subroutine test_type ( ) c*********************************************************************72 c cc TEST_TYPE tests functions which test the type of a matrix. c c Licensing: c c This code is distributed under the MIT license. c c Modified: c c 16 March 2015 c c Author: c c John Burkardt c implicit none integer n_max parameter ( n_max = 101 ) ! ! The SAVE statement is there just to get the compiler to stop complaining ! about the array being too large to keep on the stack... ! double precision, save :: a(n_max,n_max) double precision error_frobenius integer key integer m integer n double precision norm_frobenius double precision r8mat_norm_fro character * ( 20 ) title write ( *, '(a)' ) '' write ( *, '(a)' ) 'test_type():' write ( *, '(a)' ) & ' Demonstrate functions which test the type of a matrix.' c c transition c write ( *, '(a)' ) '' write ( *, '(a)' ) ' Title M N ||A||' & // ' ||Transition Error||' write ( *, '(a)' ) '' title = 'bodewig' m = 4 n = 4 call bodewig_matrix ( a ) call r8mat_is_transition ( m, n, a, error_frobenius ) norm_frobenius = r8mat_norm_fro ( n, n, a ) write ( *, '(2x,a20,2x,i4,2x,i4,2x,g14.6,2x,g14.6)' ) & title, m, n, norm_frobenius, error_frobenius title = 'snakes' m = 101 n = 101 call snakes_matrix ( a ) call r8mat_is_transition ( m, n, a, error_frobenius ) norm_frobenius = r8mat_norm_fro ( n, n, a ) write ( *, '(2x,a20,2x,i4,2x,i4,2x,g14.6,2x,g14.6)' ) & title, m, n, norm_frobenius, error_frobenius title = 'transition_random'; m = 5 n = 5 key = 123456789 call transition_random_matrix ( n, key, a ) call r8mat_is_transition ( m, n, a, error_frobenius ) norm_frobenius = r8mat_norm_fro ( n, n, a ) write ( *, '(2x,a20,2x,i4,2x,i4,2x,g14.6,2x,g14.6)' ) & title, m, n, norm_frobenius, error_frobenius return end subroutine timestamp ( ) c*********************************************************************72 c cc timestamp() prints out the current YMDHMS date as a timestamp. c c Discussion: c c This Fortran77 version is made available for cases where the c Fortran90 version cannot be used. c c Licensing: c c This code is distributed under the MIT license. c c Modified: c c 12 January 2007 c c Author: c c John Burkardt c c Parameters: c c None c implicit none character * ( 8 ) ampm integer d character * ( 8 ) date integer h integer m integer mm character * ( 9 ) month(12) integer n integer s character * ( 10 ) time integer y save month data month / & 'January ', 'February ', 'March ', 'April ', & 'May ', 'June ', 'July ', 'August ', & 'September', 'October ', 'November ', 'December ' / call date_and_time ( date, time ) read ( date, '(i4,i2,i2)' ) y, m, d read ( time, '(i2,i2,i2,1x,i3)' ) h, n, s, mm if ( h .lt. 12 ) then ampm = 'AM' else if ( h .eq. 12 ) then if ( n .eq. 0 .and. s .eq. 0 ) then ampm = 'Noon' else ampm = 'PM' end if else h = h - 12 if ( h .lt. 12 ) then ampm = 'PM' else if ( h .eq. 12 ) then if ( n .eq. 0 .and. s .eq. 0 ) then ampm = 'Midnight' else ampm = 'AM' end if end if end if write ( *, & '(i2,1x,a,1x,i4,2x,i2,a1,i2.2,a1,i2.2,a1,i3.3,1x,a)' ) & d, month(m), y, h, ':', n, ':', s, '.', mm, ampm return end