subroutine a123 ( a ) c*********************************************************************72 c cc A123 returns the A123 matrix. c c Example: c c 1 2 3 c 4 5 6 c 7 8 9 c c Properties: c c A is integral. c c A is not symmetric. c c A is singular. c c Licensing: c c This code is distributed under the GNU LGPL license. c c Modified: c c 06 March 2015 c c Author: c c John Burkardt c c Parameters: c c Output, double precision A(3,3), the matrix. c implicit none double precision a(3,3) integer i integer j integer k k = 0 do i = 1, 3 do j = 1, 3 k = k + 1 a(i,j) = dble ( k ) end do end do return end subroutine a123_determinant ( value ) c*********************************************************************72 c cc A123_DETERMINANT returns the determinant of the A123 matrix. c c Licensing: c c This code is distributed under the GNU LGPL license. c c Modified: c c 06 March 2015 c c Author: c c John Burkardt c c Parameters: c c Output, double precision VALUE, the determinant. c implicit none double precision value value = 0.0D+00 return end subroutine a123_eigen_left ( a ) c*********************************************************************72 c cc A123_EIGEN_LEFT returns left eigenvectors of the A123 matrix. c c Licensing: c c This code is distributed under the GNU LGPL license. c c Modified: c c 13 March 2015 c c Author: c c John Burkardt c c Parameters: c c Output, double precision A(3,3), the eigenvectors. c implicit none double precision a(3,3) double precision a_save(3,3) save a_save data a_save / & -0.464547273387671D+00, & -0.882905959653586D+00, & 0.408248290463862D+00, & -0.570795531228578D+00, & -0.239520420054206D+00, & -0.816496580927726D+00, & -0.677043789069485D+00, & 0.403865119545174D+00, & 0.408248290463863D+00 / call r8mat_copy ( 3, 3, a_save, a ) return end subroutine a123_eigen_right ( a ) c*********************************************************************72 c cc A123_EIGEN_RIGHT returns right eigenvectors of the A123 matrix. c c Licensing: c c This code is distributed under the GNU LGPL license. c c Modified: c c 06 March 2015 c c Author: c c John Burkardt c c Parameters: c c Output, double precision A(3,3), the eigenvectors. c implicit none double precision a(3,3) double precision a_save(3,3) save a_save data a_save / & -0.231970687246286D+00, & -0.525322093301234D+00, & -0.818673499356181D+00, & -0.785830238742067D+00, & -0.086751339256628D+00, & 0.612327560228810D+00, & 0.408248290463864D+00, & -0.816496580927726D+00, & 0.408248290463863D+00 / call r8mat_copy ( 3, 3, a_save, a ) return end subroutine a123_eigenvalues ( lambda ) c*********************************************************************72 c cc A123_EIGENVALUES returns the eigenvalues of the A123 matrix. c c Licensing: c c This code is distributed under the GNU LGPL license. c c Modified: c c 06 March 2015 c c Author: c c John Burkardt c c Parameters: c c Output, double precision LAMBDA(3), the eigenvalues. c implicit none double precision lambda(3) double precision lambda_save(3) save lambda_save data lambda_save / & 16.116843969807043D+00, & -1.116843969807043D+00, & 0.0D+00 / call r8vec_copy ( 3, lambda_save, lambda ) return end subroutine a123_inverse ( b ) c*********************************************************************72 c cc A123_INVERSE returns the pseudo-inverse of the A123 matrix. c c Example: c c -0.638888888888888 -0.166666666666666 0.305555555555555 c -0.055555555555556 0.000000000000000 0.055555555555556 c 0.527777777777777 0.166666666666666 -0.194444444444444 c c Licensing: c c This code is distributed under the GNU LGPL license. c c Modified: c c 06 March 2015 c c Author: c c John Burkardt c c Parameters: c c Output, double precision B(3,3), the matrix. c implicit none double precision b(3,3) double precision b_save(3,3) save b_save data b_save / & -0.638888888888888D+00, & -0.055555555555556D+00, & 0.527777777777777D+00, & -0.166666666666666D+00, & 0.000000000000000D+00, & 0.166666666666666D+00, & 0.305555555555555D+00, & 0.055555555555556D+00, & -0.194444444444444D+00 / call r8mat_copy ( 3, 3, b_save, b ) return end subroutine a123_null_left ( x ) c*********************************************************************72 c cc A123_NULL_LEFT returns a left null vector of the A123 matrix. c c Licensing: c c This code is distributed under the GNU LGPL license. c c Modified: c c 06 March 2015 c c Author: c c John Burkardt c c Parameters: c c Output, double precision X(3), a left null vector. c implicit none double precision x(3) x(1) = 1.0D+00 x(2) = -2.0D+00 x(3) = 1.0D+00 return end subroutine a123_null_right ( x ) c*********************************************************************72 c cc A123_NULL_RIGHT returns a right null vector of the A123 matrix. c c Licensing: c c This code is distributed under the GNU LGPL license. c c Modified: c c 06 March 2015 c c Author: c c John Burkardt c c Parameters: c c Output, double precision X(3), a right null vector. c implicit none double precision x(3) x(1) = 1.0D+00 x(2) = -2.0D+00 x(3) = 1.0D+00 return end subroutine a123_plu ( p, l, u ) c*********************************************************************72 c cc A123_PLU returns the PLU factors of the A123 matrix. c c Licensing: c c This code is distributed under the GNU LGPL license. c c Modified: c c 06 March 2015 c c Author: c c John Burkardt c c Parameters: c c Output, double precision P(3,3), L(3,3), U(3,3), the PLU factors. c implicit none double precision l(3,3) double precision l_save(3,3) double precision p(3,3) double precision p_save(3,3) double precision u(3,3) double precision u_save(3,3) save l_save save p_save save u_save data l_save / & 1.0D+00, & 0.142857142857143D+00, & 0.571428571428571D+00, & 0.0D+00, & 1.00D+00, & 0.5D+00, & 0.0D+00, & 0.00D+00, & 1.0D+00 / data p_save / & 0.0D+00, & 0.0D+00, & 1.0D+00, & 1.0D+00, & 0.0D+00, & 0.0D+00, & 0.0D+00, & 1.0D+00, & 0.0D+00 / data u_save / & 7.0D+00, & 0.00D+00, & 0.0D+00, & 8.0D+00, & 0.857142857142857D+00, & 0.0D+00, & 9.0D+00, & 1.714285714285714D+00, & 0.0D+00 / call r8mat_copy ( 3, 3, l_save, l ) call r8mat_copy ( 3, 3, p_save, p ) call r8mat_copy ( 3, 3, u_save, u ) return end subroutine a123_qr ( q, r ) c*********************************************************************72 c cc A123_QR returns the QR factors of the A123 matrix. c c Licensing: c c This code is distributed under the GNU LGPL license. c c Modified: c c 06 March 2015 c c Author: c c John Burkardt c c Parameters: c c Output, double precision Q(3,3), R(3,3), the QR factors. c implicit none double precision q(3,3) double precision q_save(3,3) double precision r(3,3) double precision r_save(3,3) save q_save save r_save data q_save / & -0.123091490979333D+00, & -0.492365963917331D+00, & -0.861640436855329D+00, & 0.904534033733291D+00, & 0.301511344577763D+00, & -0.301511344577763D+00, & 0.408248290463862D+00, & -0.816496580927726D+00, & 0.408248290463863D+00 / data r_save / & -8.124038404635959D+00, & 0.0D+00, & 0.0D+00, & -9.601136296387955D+00, & 0.904534033733293D+00, & 0.0D+00, & -11.078234188139948D+00, & 1.809068067466585D+00, & 0.0D+00 / call r8mat_copy ( 3, 3, q_save, q ) call r8mat_copy ( 3, 3, r_save, r ) return end subroutine a123_rhs ( b ) c*********************************************************************72 c cc A123_RHS returns the A123 right hand side. c c Licensing: c c This code is distributed under the GNU LGPL license. c c Modified: c c 08 March 2015 c c Author: c c John Burkardt c c Parameters: c c Output, double precision B(3), the vector. c implicit none double precision b(3) double precision b_save(3) save b_save data b_save / & 10.0D+00, 28.0D+00, 46.0D+00 / call r8vec_copy ( 3, b_save, b ) return end subroutine a123_solution ( x ) c*********************************************************************72 c cc A123_SOLUTION returns the A123_SOLUTION c c Licensing: c c This code is distributed under the GNU LGPL license. c c Modified: c c 08 March 2015 c c Author: c c John Burkardt c c Parameters: c c Output, double precision X(3), the solution. c implicit none double precision x(3) double precision x_save(3) save x_save data x_save / & 3.0D+00, 2.0D+00, 1.0D+00 / call r8vec_copy ( 3, x_save, x ) return end subroutine a123_svd ( u, s, v ) c*********************************************************************72 c cc A123_SVD returns the SVD factors of the A123 matrix. c c Licensing: c c This code is distributed under the GNU LGPL license. c c Modified: c c 06 March 2015 c c Author: c c John Burkardt c c Parameters: c c Output, double precision U(3,3), S(3,3), V(3,3), the SVD factors. c implicit none double precision s(3,3) double precision s_save(3,3) double precision u(3,3) double precision u_save(3,3) double precision v(3,3) double precision v_save(3,3) save s_save save u_save save v_save data s_save / & 16.848103352614210D+00, & 0.0D+00, & 0.0D+00, & 0.0D+00, & 1.068369514554710D+00, & 0.0D+00, & 0.0D+00, & 0.0D+00, & 0.0D+00 / data u_save / & -0.214837238368397D+00, & -0.520587389464737D+00, & -0.826337540561078D+00, & 0.887230688346371D+00, & 0.249643952988297D+00, & -0.387942782369774D+00, & 0.408248290463863D+00, & -0.816496580927726D+00, & 0.408248290463863D+00 / data v_save / & -0.479671177877772D+00, & -0.572367793972062D+00, & -0.665064410066353D+00, & -0.776690990321560D+00, & -0.075686470104559D+00, & 0.625318050112443D+00, & -0.408248290463863D+00, & 0.816496580927726D+00, & -0.408248290463863D+00 / call r8mat_copy ( 3, 3, s_save, s ) call r8mat_copy ( 3, 3, u_save, u ) call r8mat_copy ( 3, 3, v_save, v ) return end subroutine aegerter ( n, a ) c*********************************************************************72 c cc AEGERTER returns the AEGERTER matrix. c c Formula: c c if ( I .eq. N ) c A(I,J) = J c else if ( J .eq. N ) c A(I,J) = I c else if ( I .eq. J ) c A(I,J) = 1 c else c A(I,J) = 0 c c Example: c c N = 5 c c 1 0 0 0 1 c 0 1 0 0 2 c 0 0 1 0 3 c 0 0 0 1 4 c 1 2 3 4 5 c c Properties: c c A is integral, therefore det ( A ) is integral, and c det ( A ) * inverse ( A ) is integral. c c A is symmetric: A' = A. c c Because A is symmetric, it is normal. c c Because A is normal, it is diagonalizable. c c A is border-banded. c c det ( A ) = N * ( - 2 * N * N + 3 * N + 5 ) / 6 c c A has N-2 eigenvalues equal to 1. c c The other two eigenvalues are c c ( N + 1 + sqrt ( ( N + 1 )^2 - 4 * det ( A ) ) ) / 2 c ( N + 1 - sqrt ( ( N + 1 )^2 - 4 * det ( A ) ) ) / 2 c c Licensing: c c This code is distributed under the GNU LGPL license. c c Modified: c c 30 July 2008 c c Author: c c John Burkardt c c Reference: c c MJ Aegerter, c Construction of a Set of Test Matrices, c Communications of the ACM, c Volume 2, Number 8, August 1959, pages 10-12. c c Parameters: c c Input, integer N, the order of the matrix. c c Output, double precision A(N,N), the matrix. c implicit none integer n double precision a(n,n) integer i integer j do j = 1, n do i = 1, n if ( i .eq. n ) then a(i,j) = dble ( j ) else if ( j .eq. n ) then a(i,j) = dble ( i ) else if ( i .eq. j ) then a(i,j) = 1.0D+00 else a(i,j) = 0.0D+00 end if end do end do return end subroutine aegerter_condition ( n, cond ) c*********************************************************************72 c cc AEGERTER_CONDITION returns the L1 condition of the AEGERTER matrix. c c Licensing: c c This code is distributed under the GNU LGPL license. c c Modified: c c 10 April 2012 c c Author: c c John Burkardt c c Parameters: c c Input, integer N, the order of the matrix. c c Output, double precision COND, the L1 condition number. c implicit none integer n double precision a(n,n) double precision a_norm double precision b(n,n) double precision b_norm double precision cond double precision r8mat_norm_l1 call aegerter ( n, a ) a_norm = r8mat_norm_l1 ( n, n, a ) call aegerter_inverse ( n, b ) b_norm = r8mat_norm_l1 ( n, n, b ) cond = a_norm * b_norm return end subroutine aegerter_determinant ( n, determ ) c*********************************************************************72 c cc AEGERTER_DETERMINANT returns the determinant of the AEGERTER matrix. c c Licensing: c c This code is distributed under the GNU LGPL license. c c Modified: c c 30 July 2008 c c Author: c c John Burkardt c c Parameters: c c Input, integer N, the order of the matrix. c c Output, double precision DETERM, the determinant. c implicit none double precision determ integer n determ = dble ( n - ( ( n - 1 ) * n * ( 2 * n - 1 ) ) / 6 ) return end subroutine aegerter_eigenvalues ( n, lambda ) c*********************************************************************72 c cc AEGERTER_EIGENVALUES returns the eigenvalues of the AEGERTER matrix. c c Licensing: c c This code is distributed under the GNU LGPL license. c c Modified: c c 30 July 2008 c c Author: c c John Burkardt c c Parameters: c c Input, integer N, the order of the matrix. c c Output, double precision LAMBDA(N), the eigenvalues. c implicit none integer n double precision determ integer i double precision lambda(n) double precision np1 determ = dble ( n - ( ( n - 1 ) * n * ( 2 * n - 1 ) ) / 6 ) np1 = dble ( n + 1 ) lambda(1) = & 0.5D+00 * ( np1 - sqrt ( np1 * np1 - 4.0D+00 * determ ) ) do i = 2, n - 1 lambda(i) = 1.0D+00 end do lambda(n) = & 0.5D+00 * ( np1 + sqrt ( np1 * np1 - 4.0D+00 * determ ) ) return end subroutine aegerter_inverse ( n, a ) c*********************************************************************72 c cc AEGERTER_INVERSE returns the inverse of the AEGERTER matrix. c c Licensing: c c This code is distributed under the GNU LGPL license. c c Modified: c c 30 July 2008 c c Author: c c John Burkardt c c Parameters: c c Input, integer N, the order of the matrix. c c Output, double precision A(N,N), the matrix. c implicit none integer n double precision a(n,n) integer i integer j do i = 1, n - 1 do j = 1, n - 1 if ( i .eq. j ) then a(i,j) = 1.0D+00 - dble ( i * j ) / dble ( n * n ) else a(i,j) = - dble ( i * j ) / dble ( n * n ) end if end do end do do i = 1, n - 1 a(i,n) = dble ( i ) / dble ( n * n ) end do do j = 1, n - 1 a(n,j) = dble ( j ) / dble ( n * n ) end do a(n,n) = - 1.0D+00 / dble ( n * n ) return end subroutine anticirculant ( m, n, x, a ) c*********************************************************************72 c cc ANTICIRCULANT returns an ANTICIRCULANT matrix. c c Formula: c c K = 1 + mod ( J + I - 2, N ) c A(I,J) = X(K) c c Example: c c M = 4, N = 5, X = ( 1, 2, 3, 4, 5 ) c c 1 2 3 4 5 c 2 3 4 5 1 c 3 4 5 1 2 c 4 5 1 2 3 c c M = 5, N = 4, X = ( 1, 2, 3, 4 ) c c 1 2 3 4 c 2 3 4 5 c 3 4 5 1 c 4 5 1 2 c 1 2 3 4 c c Properties: c c A is a special Hankel matrix in which the diagonals "wrap around". c c A is symmetric: A' = A. c c A is integral, therefore det ( A ) is integral, and c det ( A ) * inverse ( A ) is integral. c c Because A is symmetric, it is normal. c c Because A is normal, it is diagonalizable. c c Licensing: c c This code is distributed under the GNU LGPL license. c c Modified: c c 13 August 2008 c c Author: c c John Burkardt c c Parameters: c c Input, integer M, N, the order of the matrix. c c Input, double precision X(N), the vector that defines A. c c Output, double precision A(M,N), the matrix. c implicit none integer m integer n double precision a(m,n) integer i integer j integer k double precision x(n) do j = 1, n do i = 1, m k = 1 + mod ( j + i - 2, n ) a(i,j) = x(k) end do end do return end subroutine anticirculant_determinant ( n, x, determ ) c*********************************************************************72 c cc ANTICIRCULANT_DETERMINANT returns the determinant of the ANTICIRCULANT matrix. c c Licensing: c c This code is distributed under the GNU LGPL license. c c Modified: c c 13 August 2008 c c Author: c c John Burkardt c c Parameters: c c Input, integer N, the order of the matrix. c c Input, double precision X(N), the values in the first row of A. c c Output, double precision DETERM, the determinant. c implicit none integer n double precision determ integer i integer j double complex lambda(n) double precision r8_mop double complex w(n) double precision x(n) call c8vec_unity ( n, w ) do i = 1, n lambda(i) = x(n) end do do i = n-1, 1, -1 do j = 1, n lambda(j) = lambda(j) * w(j) + x(i) end do end do c c First eigenvalue is "special". c determ = dble ( lambda(1) ) c c Eigenvalues 2, 3 through ( N + 1 ) / 2 are paired with complex conjugates. c do i = 2, ( n + 1 ) / 2 determ = determ * ( abs ( lambda(i) ) ) ** 2 end do c c If N is even, there is another unpaired eigenvalue. c if ( mod ( n, 2 ) .eq. 0 ) then determ = determ * dble ( lambda((n/2)+1) ) end if c c This is actually the determinant of the CIRCULANT matrix. c We have to perform ( N - 1 ) / 2 row interchanges to get c to the anticirculant matrix. c determ = r8_mop ( ( n - 1 ) / 2 ) * determ return end subroutine antihadamard ( n, a ) c*********************************************************************72 c cc ANTIHADAMARD returns an approximate ANTIHADAMARD matrix. c c Discussion: c c An Anti-Hadamard matrix is one whose elements are all 0 or 1, c and for which the Frobenius norm of the inverse is as large as c possible. This routine returns a matrix for which the Frobenius norm c of the inverse is large, though not necessarily maximal. c c Formula: c c if ( I = J ) c A(I,J) = 1 c else if ( I < J and mod ( I + J, 2 ) = 1 ) c A(I,J) = 1 c else c A(I,J) = 0 c c Example: c c N = 5 c c 1 1 0 1 0 c 0 1 1 0 1 c 0 0 1 1 0 c 0 0 0 1 1 c 0 0 0 0 1 c c Properties: c c A is generally not symmetric: A' /= A. c c A is Toeplitz: constant along diagonals. c c A is upper triangular. c c A is integral, therefore det ( A ) is integral, and c det ( A ) * inverse ( A ) is integral. c c A is a zero-one matrix. c c det ( A ) = 1. c c A is unimodular. c c LAMBDA(1:N) = 1. c c Licensing: c c This code is distributed under the GNU LGPL license. c c Modified: c c 13 August 2008 c c Author: c c John Burkardt c c Reference: c c Ronald Graham, Neal Sloane, c Anti-Hadamard Matrices, c Linear Algebra and Applications, c Volume 62, November 1984, pages 113-137. c c Parameters: c c Input, integer N, the order of the matrix. c c Output, double precision A(N,N), the matrix. c implicit none integer n double precision a(n,n) integer i integer j do j = 1, n do i = 1, n if ( j .lt. i ) then a(i,j) = 0.0D+00 else if ( i .eq. j ) then a(i,j) = 1.0D+00 else if ( mod ( i + j, 2 ) .eq. 1 ) then a(i,j) = 1.0D+00 else a(i,j) = 0.0D+00 end if end do end do return end subroutine antihadamard_determinant ( n, determ ) c*********************************************************************72 c cc ANTIHADAMARD_DETERMINANT returns the determinant of the ANTIHADAMARD matrix. c c Licensing: c c This code is distributed under the GNU LGPL license. c c Modified: c c 13 August 2008 c c Author: c c John Burkardt c c Parameters: c c Input, integer N, the order of the matrix. c c Output, double precision DETERM, the determinant. c implicit none double precision determ integer n determ = 1.0D+00 return end subroutine antisymm_random ( n, key, a ) c*********************************************************************72 c cc ANTISYMM_RANDOM returns an ANTISYMMETRIC matrix. c c Example: c c N = 5 c c 0.0000 -0.1096 0.0813 0.9248 -0.0793 c 0.1096 0.0000 0.1830 0.1502 0.8244 c -0.0813 -0.1830 0.0000 0.0899 -0.2137 c -0.9248 -0.1502 -0.0899 0.0000 -0.4804 c 0.0793 -0.8244 0.2137 0.4804 0.0000 c c Properties: c c A is generally not symmetric: A' /= A. c c A is antisymmetric: A' = -A. c c Because A is antisymmetric, it is normal. c c Because A is normal, it is diagonalizable. c c The diagonal of A is zero. c c All the eigenvalues of A are imaginary. c c if N is odd, then det ( A ) = 0. c c Licensing: c c This code is distributed under the GNU LGPL license. c c Modified: c c 28 January 2015 c c Author: c c John Burkardt c c Parameters: c c Input, integer N, the order of the matrix. c c Input, integer KEY, a positive integer that selects the data. c c Output, double precision A(N,N), the matrix. c implicit none integer n double precision a(n,n) integer i integer j integer key double precision r8_hi double precision r8_lo double precision r8_uniform_ab integer seed do i = 1, n a(i,i) = 0.0D+00 end do r8_lo = -1.0D+00 r8_hi = +1.0D+00 seed = key do i = 1, n do j = i + 1, n a(i,j) = r8_uniform_ab ( r8_lo, r8_hi, seed ) a(j,i) = - a(i,j) end do end do return end subroutine archimedes ( a ) c*********************************************************************72 c cc ARCHIMEDES returns the ARCHIMEDES matrix. c c Formula: c c 6 -5 0 -6 0 0 0 0 c 0 20 -9 -20 0 0 0 0 c -13 0 42 -42 0 0 0 0 c 0 -7 0 0 12 -7 0 0 c 0 0 -9 0 0 20 -9 0 c 0 0 0 -11 0 0 30 -11 c -13 0 0 0 -13 0 0 42 c c Discussion: c c "The sun god had a herd of cattle, consisting of bulls and cows, c one part of which was white, a second black, a third spotted, and c a fourth brown. Among the bulls, the number of white ones was c one half plus one third the number of the black greater than c the brown; the number of the black, one quarter plus one fifth c the number of the spotted greater than the brown; the number of c the spotted, one sixth and one seventh the number of the white c greater than the brown. Among the cows, the number of white ones c was one third plus one quarter of the total black cattle; the number c of the black, one quarter plus one fifth the total of the spotted c cattle; the number of spotted, one fifth plus one sixth the total c of the brown cattle; the number of the brown, one sixth plus one c seventh the total of the white cattle. What was the composition c of the herd?" c c The 7 relations involving the 8 numbers W, X, Y, Z, w, x, y, z, c have the form: c c W = ( 5/ 6) * X + Z c X = ( 9/20) * Y + Z c Y = (13/42) * W + Z c w = ( 7/12) * ( X + x ) c x = ( 9/20) * ( Y + y ) c y = (11/30) * ( Z + z ) c z = (13/42) * ( W + w ) c c These equations may be multiplied through to an integral form c that is embodied in the above matrix. c c A more complicated second part of the problem imposes additional c constraints (W+X must be square, Y+Z must be a triangular number). c c Properties: c c A is integral: int ( A ) = A. c c A has full row rank. c c It is desired to know a solution X in positive integers of c c A * X = 0. c c The null space of A is spanned by multiples of the null vector: c c [ 10,366,482 ] c [ 7,460,514 ] c [ 7,358,060 ] c [ 4,149,387 ] c [ 7,206,360 ] c [ 4,893,246 ] c [ 3,515,820 ] c [ 5,439,213 ] c c and this is the smallest positive integer solution of the c equation A * X = 0. c c Thus, for the "simple" part of Archimedes's problem, the total number c of cattle of the Sun is 50,389,082. c c Licensing: c c This code is distributed under the GNU LGPL license. c c Modified: c c 13 August 2008 c c Author: c c John Burkardt c c Reference: c c Eric Weisstein, c CRC Concise Encyclopedia of Mathematics, c CRC Press, 2002, c Second edition, c ISBN: 1584883472, c LC: QA5.W45 c c Parameters: c c Output, double precision A(7,8), the matrix. c implicit none double precision a(7,8) double precision a_save(7,8) save a_save c c Note that the matrix entries are listed by column. c data a_save / & 6.0D+00, 0.0D+00, -13.0D+00, 0.0D+00, 0.0D+00, & 0.0D+00, -13.0D+00, & -5.0D+00, 20.0D+00, 0.0D+00, -7.0D+00, 0.0D+00, & 0.0D+00, 0.0D+00, & 0.0D+00, -9.0D+00, 42.0D+00, 0.0D+00, -9.0D+00, & 0.0D+00, 0.0D+00, & -6.0D+00, -20.0D+00, -42.0D+00, 0.0D+00, 0.0D+00, & -11.0D+00, 0.0D+00, & 0.0D+00, 0.0D+00, 0.0D+00, 12.0D+00, 0.0D+00, & 0.0D+00, -13.0D+00, & 0.0D+00, 0.0D+00, 0.0D+00, -7.0D+00, 20.0D+00, & 0.0D+00, 0.0D+00, & 0.0D+00, 0.0D+00, 0.0D+00, 0.0D+00, -9.0D+00, & 30.0D+00, 0.0D+00, & 0.0D+00, 0.0D+00, 0.0D+00, 0.0D+00, 0.0D+00, & -11.0D+00, 42.0D+00 / call r8mat_copy ( 7, 8, a_save, a ) return end subroutine archimedes_null_right ( x ) c*********************************************************************72 c cc ARCHIMEDES_NULL_RIGHT returns a right null vector for the ARCHIMEDES matrix. c c Licensing: c c This code is distributed under the GNU LGPL license. c c Modified: c c 13 August 2008 c c Author: c c John Burkardt c c Parameters: c c Output, double precision X(8), the null vector. c implicit none double precision x(8) double precision x_save(8) save x_save data x_save / & 10366482.0D+00, 7460514.0D+00, 7358060.0D+00, 4149387.0D+00, & 7206360.0D+00, 4893246.0D+00, 3515820.0D+00, 5439213.0D+00 / call r8vec_copy ( 8, x_save, x ) return end subroutine bab ( n, alpha, beta, a ) c*********************************************************************72 c cc BAB returns the BAB matrix. c c Discussion: c c The name is meant to suggest the pattern "B A B" formed by c the nonzero entries in a general row of the matrix. c c Example: c c N = 5 c ALPHA = 5, BETA = 2 c c 5 2 . . . c 2 5 2 . . c . 2 5 2 . c . . 2 5 2 c . . . 2 5 c c Properties: c c A is banded, with bandwidth 3. c c A is tridiagonal. c c Because A is tridiagonal, it has property A (bipartite). c c A is Toeplitz: constant along diagonals. c c A is symmetric: A' = A. c c Because A is symmetric, it is normal. c c Because A is normal, it is diagonalizable. c c A is persymmetric: A(I,J) = A(N+1-J,N+1-I). c c The family of matrices is nested as a function of N. c c Licensing: c c This code is distributed under the GNU LGPL license. c c Modified: c c 14 August 2008 c c Author: c c John Burkardt c c Reference: c c CM da Fonseca, J Petronilho, c Explicit Inverses of Some Tridiagonal Matrices, c Linear Algebra and Its Applications, c Volume 325, 2001, pages 7-21. c c Parameters: c c Input, integer N, the order of the matrix. c c Input, double precision ALPHA, BETA, the parameters. c c Output, double precision A(N,N), the matrix. c implicit none integer n double precision a(n,n) double precision alpha double precision beta integer i integer j do j = 1, n do i = 1, n a(i,j) = 0.0D+00 end do end do do i = 1, n a(i,i) = alpha end do do i = 1, n - 1 a(i,i+1) = beta a(i+1,i) = beta end do return end subroutine bab_condition ( n, alpha, beta, cond ) c*********************************************************************72 c cc BAB_CONDITION returns the L1 condition of the BAB matrix. c c Licensing: c c This code is distributed under the GNU LGPL license. c c Modified: c c 08 April 2012 c c Author: c c John Burkardt c c Parameters: c c Input, integer N, the order of the matrix. c c Input, double precision ALPHA, BETA, the parameters. c c Output, double precision COND, the L1 condition number. c implicit none integer n double precision a(n,n) double precision a_norm double precision alpha double precision b(n,n) double precision b_norm double precision beta double precision cond double precision r8mat_norm_l1 call bab ( n, alpha, beta, a ) a_norm = r8mat_norm_l1 ( n, n, a ) call bab_inverse ( n, alpha, beta, b ) b_norm = r8mat_norm_l1 ( n, n, b ) cond = a_norm * b_norm return end subroutine bab_determinant ( n, alpha, beta, determ ) c*********************************************************************72 c cc BAB_DETERMINANT returns the determinant of the BAB matrix. c c Licensing: c c This code is distributed under the GNU LGPL license. c c Modified: c c 14 August 2008 c c Author: c c John Burkardt c c Parameters: c c Input, integer N, the order of the matrix. c c Input, double precision ALPHA, BETA, the parameters. c c Output, double precision DETERM, the determinant. c implicit none integer n double precision alpha double precision beta double precision determ double precision determ_nm1 double precision determ_nm2 integer i determ_nm1 = alpha if ( n .eq. 1 ) then determ = determ_nm1 return end if determ_nm2 = determ_nm1 determ_nm1 = alpha * alpha - beta * beta if ( n .eq. 2 ) then determ = determ_nm1 return end if do i = n - 2, 1, -1 determ = alpha * determ_nm1 - beta * beta * determ_nm2 determ_nm2 = determ_nm1 determ_nm1 = determ end do return end subroutine bab_eigen_right ( n, alpha, beta, a ) c*********************************************************************72 c cc BAB_EIGEN_RIGHT returns right eigenvectors of the BAB matrix. c c Licensing: c c This code is distributed under the GNU LGPL license. c c Modified: c c 06 April 2015 c c Author: c c John Burkardt c c Parameters: c c Input, integer N, the order of the matrix. c c Input, double precision ALPHA, BETA, the parameters. c c Output, double precision A(N,N), the right eigenvector matrix. c implicit none integer n double precision a(n,n) double precision alpha double precision angle double precision beta integer i integer j double precision r8_pi parameter ( r8_pi = 3.141592653589793D+00 ) do j = 1, n do i = 1, n angle = dble ( i * j ) * r8_pi / dble ( n + 1 ) a(i,j) = sqrt ( 2.0D+00 / dble ( n + 1 ) ) * sin ( angle ) end do end do return end subroutine bab_eigenvalues ( n, alpha, beta, lambda ) c*********************************************************************72 c cc BAB_EIGENVALUES returns the eigenvalues of the BAB matrix. c c Licensing: c c This code is distributed under the GNU LGPL license. c c Modified: c c 14 August 2008 c c Author: c c John Burkardt c c Parameters: c c Input, integer N, the order of the matrix. c c Input, double precision ALPHA, BETA, the parameters. c c Output, double precision LAMBDA(N), the eigenvalues. c implicit none integer n double precision alpha double precision angle double precision beta integer i double precision lambda(n) double precision r8_pi parameter ( r8_pi = 3.141592653589793D+00 ) do i = 1, n angle = dble ( i ) * r8_pi / dble ( n + 1 ) lambda(i) = alpha + 2.0D+00 * beta * cos ( angle ) end do return end subroutine bab_inverse ( n, alpha, beta, a ) c*********************************************************************72 c cc BAB_INVERSE returns the inverse of the BAB matrix. c c Licensing: c c This code is distributed under the GNU LGPL license. c c Modified: c c 14 August 2008 c c Author: c c John Burkardt c c Parameters: c c Input, integer N, the order of the matrix. c c Input, double precision ALPHA, BETA, the parameters. c c Output, double precision A(N,N), the matrix. c implicit none integer n double precision a(n,n) double precision alpha double precision beta integer i integer j double precision r8_mop double precision u(0:n) double precision x if ( beta .eq. 0.0D+00 ) then if ( alpha .eq. 0.0D+00 ) then write ( *, '(a)' ) ' ' write ( *, '(a)' ) 'BAB_INVERSE - Fatal error!' write ( *, '(a)' ) ' ALPHA = BETA = 0.' stop 1 end if do j = 1, n do i = 1, n a(i,j) = 0.0D+00 end do end do do i = 1, n a(i,i) = 1.0D+00 / alpha end do else x = 0.5D+00 * alpha / beta call cheby_u_polynomial ( n, x, u ) do i = 1, n do j = 1, i a(i,j) = r8_mop ( i + j ) * u(j-1) * u(n-i) / u(n) / beta end do do j = i + 1, n a(i,j) = r8_mop ( i + j ) * u(i-1) * u(n-j) / u(n) / beta end do end do end if return end subroutine balanc ( nm, n, a, low, igh, scale ) c*********************************************************************72 c cc BALANC balances a real matrix before eigenvalue calculations. c c Discussion: c c This routine is a translation of the ALGOL procedure BALANCE, c num. math. 13, 293-304(1969) by Parlett and Reinsch. c handbook for auto. comp., vol.ii-linear algebra, 315-326(1971). c c This routine balances a real matrix and isolates c eigenvalues whenever possible. c c Suppose that the principal submatrix in rows LOW through IGH c has been balanced, that P(J) denotes the index interchanged c with J during the permutation step, and that the elements c of the diagonal matrix used are denoted by D(I,J). Then c SCALE(J) = P(J), for J = 1,...,LOW-1 c = D(J,J), J = LOW,...,IGH c = P(J) J = IGH+1,...,N. c the order in which the interchanges are made is N to IGH+1, c then 1 to LOW-1. c c Note that 1 is returned for IGH if IGH is zero formally. c c Parameters: c c Input, integer NM, the row dimension of two-dimensional c array parameters as declared in the calling program c dimension statement. c c Input, integer N, the order of the matrix. c c Input/output, double precision A(NM,N). On input, the matrix to be c balanced. On output, the balanced matrix. c c Output, integer LOW, IGH, such that A(I,J) is equal to zero if c (1) I is greater than J and c (2) J=1,...,LOW-1 or I=IGH+1,...,N. c c Output, double precision SCALE(N), information determining the c permutations and scaling factors used. c integer i,j,k,l,m,n,jj,nm,igh,low,iexc double precision a(nm,n),scale(n) double precision c,f,g,r,s,b2,radix logical noconv radix = 16.0d0 b2 = radix * radix k = 1 l = n go to 100 c c In-line procedure for row and column exchange. c 20 scale(m) = j if (j .eq. m) go to 50 do i = 1, l f = a(i,j) a(i,j) = a(i,m) a(i,m) = f end do do i = k, n f = a(j,i) a(j,i) = a(m,i) a(m,i) = f end do 50 go to (80,130), iexc c c Search for rows isolating an eigenvalue and push them down. c 80 if (l .eq. 1) go to 280 l = l - 1 c c For J = L step -1 until 1 do. c 100 do 120 jj = 1, l j = l + 1 - jj do 110 i = 1, l if (i .eq. j) go to 110 if (a(j,i) .ne. 0.0d0) go to 120 110 continue m = l iexc = 1 go to 20 120 continue go to 140 c c Search for columns isolating an eigenvalue and push them left. c 130 k = k + 1 140 do 170 j = k, l do 150 i = k, l if (i .eq. j) go to 150 if (a(i,j) .ne. 0.0d0) go to 170 150 continue m = k iexc = 2 go to 20 170 continue c c Now balance the submatrix in rows K to L. c do i = k, l scale(i) = 1.0d0 end do c c Iterative loop for norm reduction. c 190 noconv = .false. do 270 i = k, l c = 0.0d0 r = 0.0d0 do 200 j = k, l if (j .eq. i) go to 200 c = c + dabs(a(j,i)) r = r + dabs(a(i,j)) 200 continue c c Guard against zero C or R due to underflow. c if (c .eq. 0.0d0 .or. r .eq. 0.0d0) go to 270 g = r / radix f = 1.0d0 s = c + r 210 if (c .ge. g) go to 220 f = f * radix c = c * b2 go to 210 220 g = r * radix 230 if (c .lt. g) go to 240 f = f / radix c = c / b2 go to 230 c c Now balance. c 240 continue if ((c + r) / f .ge. 0.95d0 * s) go to 270 g = 1.0d0 / f scale(i) = scale(i) * f noconv = .true. do j = k, n a(i,j) = a(i,j) * g end do do j = 1, l a(j,i) = a(j,i) * f end do 270 continue if (noconv) go to 190 280 low = k igh = l return end subroutine bauer ( a ) c*********************************************************************72 c cc BAUER returns the BAUER matrix. c c Example: c c -74 80 18 -11 -4 -8 c 14 -69 21 28 0 7 c 66 -72 -5 7 1 4 c -12 66 -30 -23 3 -3 c 3 8 -7 -4 1 0 c 4 -12 4 4 0 1 c c Properties: c c The matrix is integral. c c The inverse matrix is integral. c c The matrix is ill-conditioned. c c The determinant is 1. c c Licensing: c c This code is distributed under the GNU LGPL license. c c Modified: c c 28 March 2015 c c Author: c c John Burkardt c c Reference: c c Virginia Klema, Alan Laub, c The Singular Value Decomposition: Its Computation and Some Applications, c IEEE Transactions on Automatic Control, c Volume 25, Number 2, April 1980. c c Parameters: c c Output, double precision A(6,6), the matrix. c implicit none integer n parameter ( n = 6 ) double precision a(n,n) double precision a_save(n,n) c c Note that the matrix entries are listed by column. c save a_save data a_save / & -74.0D+00, 14.0D+00, 66.0D+00, & -12.0D+00, 3.0D+00, 4.0D+00, & 80.0D+00, -69.0D+00, -72.0D+00, & 66.0D+00, 8.0D+00, -12.0D+00, & 18.0D+00, 21.0D+00, -5.0D+00, & -30.0D+00, -7.0D+00, 4.0D+00, & -11.0D+00, 28.0D+00, 7.0D+00, & -23.0D+00, -4.0D+00, 4.0D+00, & -4.0D+00, 0.0D+00, 1.0D+00, & 3.0D+00, 1.0D+00, 0.0D+00, & -8.0D+00, 7.0D+00, 4.0D+00, & -3.0D+00, 0.0D+00, 1.0D+00 / call r8mat_copy ( n, n, a_save, a ) return end subroutine bauer_condition ( value ) c*********************************************************************72 c cc BAUER_CONDITION returns the L1 condition of the BAUER matrix. c c Licensing: c c This code is distributed under the GNU LGPL license. c c Modified: c c 28 March 2015 c c Author: c c John Burkardt c c Parameters: c c Output, double precision VALUE, the L1 condition. c implicit none double precision a_norm double precision b_norm double precision value a_norm = 307.0D+00 b_norm = 27781.0D+00 value = a_norm * b_norm return end subroutine bauer_determinant ( value ) c*********************************************************************72 c cc BAUER_DETERMINANT returns the determinant of the BAUER matrix. c c Licensing: c c This code is distributed under the GNU LGPL license. c c Modified: c c 28 March 2015 c c Author: c c John Burkardt c c Parameters: c c Output, double precision VALUE, the determinant. c implicit none double precision value value = 1.0D+00 return end subroutine bauer_inverse ( a ) c*********************************************************************72 c cc BAUER_INVERSE returns the inverse of the BAUER matrix. c c Licensing: c c This code is distributed under the GNU LGPL license. c c Modified: c c 28 March 2015 c c Author: c c John Burkardt c c Parameters: c c Output, double precision A(6,6), the matrix. c implicit none integer n parameter ( n = 6 ) double precision a(n,n) double precision a_save(n,n) c c Note that the matrix entries are listed by column. c save a_save data a_save / & 1.0D00, 0.0D00, -2.0D00, & 15.0D00, 43.0D00, -56.0D00, & 0.0D00, 1.0D00, 2.0D00, & -12.0D00, -42.0D00, 52.0D00, & -7.0D00, 7.0D00, 29.0D00, & -192.0D00, -600.0D00, 764.0D00, & -40.0D00, 35.0D00, 155.0D00, & -1034.0D00, -3211.0D00, 4096.0D00, & 131.0D00, -112.0D00, -502.0D00, & 3354.0D00, 10406.0D00, -13276.0D00, & -84.0D00, 70.0D00, 319.0D00, & -2130.0D00, -6595.0D00, 8421.0D00 / call r8mat_copy ( n, n, a_save, a ) return end subroutine bernstein ( n, a ) c*********************************************************************72 c cc BERNSTEIN returns the BERNSTEIN matrix. c c Discussion: c c The Bernstein matrix of order N is an NxN matrix A which can be used to c transform a vector of power basis coefficients C representing a polynomial c P(X) to a corresponding Bernstein basis coefficient vector B: c c B = A * C c c The N power basis vectors are ordered as (1,X,X^2,...X^(N-1)) and the N c Bernstein basis vectors as ((1-X)^(N-1), X*(1_X)^(N-2),...,X^(N-1)). c c Example: c c N = 5 c c 1 -4 6 -4 1 c 0 4 -12 12 -4 c 0 0 6 -12 6 c 0 0 0 4 -4 c 0 0 0 0 1 c c Licensing: c c This code is distributed under the GNU LGPL license. c c Modified: c c 10 July 2011 c c Author: c c John Burkardt c c Parameters: c c Input, integer N, the order of the matrix. c c Output, double precision A(N,N), the Bernstein matrix. c implicit none integer n double precision a(n,n) integer i integer i0 integer j integer j0 integer n0 double precision r8_choose double precision r8_mop do j = 1, n do i = 1, n a(i,j) = 0.0D+00 end do end do n0 = n - 1 do j0 = 0, n0 do i0 = 0, j0 a(i0+1,j0+1) = r8_mop ( j0 - i0 ) & * r8_choose ( n0 - i0, j0 - i0 ) * r8_choose ( n0, i0 ) end do end do return end subroutine bernstein_determinant ( n, value ) c*********************************************************************72 c cc BERNSTEIN_DETERMINANT returns the determinant of the BERNSTEIN matrix. c c Licensing: c c This code is distributed under the GNU LGPL license. c c Modified: c c 13 March 2015 c c Author: c c John Burkardt c c Parameters: c c Input, integer N, the order of the matrix. c c Output, double precision VALUE, the determinant. c implicit none integer i integer n double precision r8_choose double precision value value = 1.0D+00 do i = 0, n - 1 value = value * r8_choose ( n - 1, i ) end do return end subroutine bernstein_inverse ( n, a ) c*********************************************************************72 c cc BERNSTEIN_INVERSE returns the inverse BERNSTEIN matrix. c c Discussion: c c The inverse Bernstein matrix of order N is an NxN matrix A which can c be used to transform a vector of Bernstein basis coefficients B c representing a polynomial P(X) to a corresponding power basis c coefficient vector C: c c C = A * B c c The N power basis vectors are ordered as (1,X,X^2,...X^(N-1)) and the N c Bernstein basis vectors as ((1-X)^(N-1), X*(1_X)^(N-2),...,X^(N-1)). c c Example: c c N = 5 c c 1.0000 1.0000 1.0000 1.0000 1.0000 c 0 0.2500 0.5000 0.7500 1.0000 c 0 0 0.1667 0.5000 1.0000 c 0 0 0 0.2500 1.0000 c 0 0 0 0 1.0000 c c Licensing: c c This code is distributed under the GNU LGPL license. c c Modified: c c 10 July 2011 c c Author: c c John Burkardt c c Parameters: c c Input, integer N, the order of the matrix. c c Output, double precision A(N,N), the inverse Bernstein matrix. c implicit none integer n double precision a(n,n) integer i integer i0 integer j integer j0 integer n0 double precision r8_choose do j = 1, n do i = 1, n a(i,j) = 0.0D+00 end do end do n0 = n - 1 do j0 = 0, n0 do i0 = 0, j0 a(i0+1,j0+1) = r8_choose ( j0, i0 ) / r8_choose ( n0, i0 ) end do end do return end subroutine bimarkov_random ( n, key, a ) c*********************************************************************72 c cc BIMARKOV_RANDOM returns a BIMARKOV matrix. c c Discussion: c c A Bimarkov matrix is also known as a doubly stochastic matrix. c c Example: c c N = 5 c c 1/5 1/5 1/5 1/5 1/5 c 1/2 1/2 0 0 0 c 1/6 1/6 2/3 0 0 c 1/12 1/12 1/12 3/4 0 c 1/20 1/20 1/20 1/20 4/5 c c Properties: c c A is generally not symmetric: A' /= A. c c 0 <= A(I,J) <= 1.0D+00 for every I and J. c c A has constant row sum 1. c c Because it has a constant row sum of 1, c A has an eigenvalue of 1 c and a right eigenvector of ( 1, 1, 1, ..., 1 ). c c A has constant column sum 1. c c Because it has a constant column sum of 1, c A has an eigenvalue of 1 c and a left eigenvector of ( 1, 1, 1, ..., 1 ). c c All the eigenvalues of A have modulus 1. c c The eigenvalue 1 lies on the boundary of all the Gershgorin c row or column sum disks. c c Every doubly stochastic matrix is a combination c A = w1 * P1 + w2 * P2 + ... + wk * Pk c of permutation matrices, with positive weights w that sum to 1. c (Birkhoff's theorem, see Horn and Johnson.) c c A is a Markov matrix. c c A is a transition matrix. c c Licensing: c c This code is distributed under the GNU LGPL license. c c Modified: c c 14 August 2008 c c Author: c c John Burkardt c c Reference: c c Roger Horn, Charles Johnson, c Matrix Analysis, c Cambridge, 1985, c ISBN: 0-521-38632-2, c LC: QA188.H66. c c Parameters: c c Input, integer N, the order of the matrix. c c Input, integer KEY, a positive integer that selects the data. c c Output, double precision A(N,N), the matrix. c implicit none integer n double precision a(n,n) integer i integer j integer key c c Get a random orthogonal matrix. c call orth_random ( n, key, a ) c c Square each entry. c do j = 1, n do i = 1, n a(i,j) = a(i,j) ** 2 end do end do return end subroutine bis ( alpha, beta, m, n, a ) c*********************************************************************72 c cc BIS returns the BIS matrix. c c Discussion: c c The BIS matrix is a bidiagonal scalar matrix. c c Formula: c c if ( I = J ) c A(I,J) = ALPHA c else if ( J = I + 1 ) c A(I,J) = BETA c else c A(I,J) = 0 c c Example: c c ALPHA = 7, BETA = 2, M = 5, N = 4 c c 7 2 0 0 c 0 7 2 0 c 0 0 7 2 c 0 0 0 7 c 0 0 0 0 c c Properties: c c A is bidiagonal. c c Because A is bidiagonal, it has property A (bipartite). c c A is upper triangular. c c A is banded with bandwidth 2. c c A is Toeplitz: constant along diagonals. c c A is generally not symmetric: A' /= A. c c A is nonsingular if and only if ALPHA is nonzero. c c det ( A ) = ALPHA^N. c c LAMBDA(1:N) = ALPHA. c c A is persymmetric: A(I,J) = A(N+1-J,N+1-I). c c The family of matrices is nested as a function of N. c c Licensing: c c This code is distributed under the GNU LGPL license. c c Modified: c c 15 August 2008 c c Author: c c John Burkardt c c Parameters: c c Input, double precision ALPHA, BETA, the scalars which define the c diagonal and first superdiagonal of the matrix. c c Input, integer M, N, the order of the matrix. c c Output, double precision A(M,N), the matrix. c implicit none integer m integer n double precision a(m,n) double precision alpha double precision beta integer i integer j do j = 1, n do i = 1, m if ( j .eq. i ) then a(i,j) = alpha else if ( j .eq. i + 1 ) then a(i,j) = beta else a(i,j) = 0.0D+00 end if end do end do return end subroutine bis_condition ( alpha, beta, n, cond ) c*********************************************************************72 c cc BIS_CONDITION returns the L1 condition of the BIS matrix. c c Licensing: c c This code is distributed under the GNU LGPL license. c c Modified: c c 19 January 2015 c c Author: c c John Burkardt c c Parameters: c c Input, double precision ALPHA, BETA, the scalars which define the c diagonal and first superdiagonal of the matrix. c c Input, integer N, the order of the matrix. c c Output, double precision COND, the L1 condition of the matrix. c implicit none integer n double precision a_norm double precision alpha double precision b_norm double precision ba double precision beta double precision cond a_norm = abs ( alpha ) + abs ( beta ) ba = abs ( beta / alpha ) b_norm = ( ba ** n - 1.0D+00 ) / ( ba - 1.0D+00 ) / abs ( alpha ) cond = a_norm * b_norm return end subroutine bis_determinant ( alpha, beta, n, determ ) c*********************************************************************72 c cc BIS_DETERMINANT returns the determinant of the BIS matrix. c c Licensing: c c This code is distributed under the GNU LGPL license. c c Modified: c c 15 August 2008 c c Author: c c John Burkardt c c Parameters: c c Input, double precision ALPHA, BETA, the scalars which define the c diagonal and first superdiagonal of the matrix. c c Input, integer N, the order of the matrix. c c Output, double precision DETERM, the determinant of the matrix. c implicit none integer n double precision alpha double precision beta double precision determ determ = alpha**n return end subroutine bis_eigenvalues ( alpha, beta, n, lambda ) c*********************************************************************72 c cc BIS_EIGENVALUES returns the eigenvalues of the BIS matrix. c c Licensing: c c This code is distributed under the GNU LGPL license. c c Modified: c c 15 August 2008 c c Author: c c John Burkardt c c Parameters: c c Input, double precision ALPHA, BETA, the scalars which define the c diagonal and first superdiagonal of the matrix. c c Input, integer N, the order of the matrix. c c Output, double precision LAMBDA(N), the eigenvalues of the matrix. c implicit none integer n double precision alpha double precision beta integer i double precision lambda(n) do i = 1, n lambda(i) = alpha end do return end subroutine bis_inverse ( alpha, beta, n, a ) c*********************************************************************72 c cc BIS_INVERSE returns the inverse of the BIS matrix. c c Formula: c c if ( I <= J ) c A(I,J) = (-BETA)^(J-I) / ALPHA^(J+1-I) c else c A(I,J) = 0 c c Example: c c ALPHA = 7.0, BETA = 2.0, N = 4 c c 0.1429 -0.0408 0.0117 -0.0033 c 0 0.1429 -0.0408 0.0117 c 0 0 0.1429 -0.0408 c 0 0 0 0.1429 c c Properties: c c A is generally not symmetric: A' /= A. c c A is upper triangular c c A is Toeplitz: constant along diagonals. c c A is persymmetric: A(I,J) = A(N+1-J,N+1-I). c c det ( A ) = (1/ALPHA)^N. c c LAMBDA(1:N) = 1 / ALPHA. c c The family of matrices is nested as a function of N. c c Licensing: c c This code is distributed under the GNU LGPL license. c c Modified: c c 15 August 2008 c c Author: c c John Burkardt c c Parameters: c c Input, double precision ALPHA, BETA, the scalars which define the c diagonal and first superdiagonal of the matrix. c c Input, integer N, the order of the matrix. c c Output, double precision A(N,N), the matrix. c implicit none integer n double precision a(n,n) double precision alpha double precision beta integer i integer j if ( alpha .eq. 0.0D+00 ) then write ( *, '(a)' ) ' ' write ( *, '(a)' ) 'BIS_INVERSE - Fatal error!' write ( *, '(a)' ) ' The input parameter ALPHA was 0.' stop 1 end if do j = 1, n do i = 1, n if ( i .le. j ) then a(i,j) = ( - beta / alpha ) ** ( j - i ) / alpha else a(i,j) = 0.0D+00 end if end do end do return end subroutine biw ( n, a ) c*********************************************************************72 c cc BIW returns the BIW matrix. c c Discussion: c c BIW is a bidiagonal matrix of Wilkinson. Originally, this matrix c was considered for N = 100. c c Formula: c c if ( I == J ) c A(I,J) = 0.5 + I / ( 10 * N ) c else if ( J == I+1 ) c A(I,J) = -1.0 c else c A(I,J) = 0 c c Example: c c N = 5 c c 0.52 -1.00 0.00 0.00 0.00 c 0.00 0.54 -1.00 0.00 0.00 c 0.00 0.00 0.56 -1.00 0.00 c 0.00 0.00 0.00 0.58 -1.00 c 0.00 0.00 0.00 0.00 0.60 c c Licensing: c c This code is distributed under the GNU LGPL license. c c Modified: c c 29 March 2015 c c Author: c c John Burkardt c c Parameters: c c Input, integer N, the order of the matrix. c c Output, double precision A(N,N), the matrix. c implicit none integer n double precision a(n,n) integer i integer j do j = 1, n do i = 1, n a(i,j) = 0.0D+00 end do end do do i = 1, n a(i,i) = 0.5D+00 + dble ( i ) / dble ( 10 * n ) end do do i = 1, n - 1 a(i,i+1) = - 1.0D+00 end do return end subroutine biw_condition ( n, value ) c*********************************************************************72 c cc BIW_CONDITION computes the L1 condition of the BIW matrix. c c Licensing: c c This code is distributed under the GNU LGPL license. c c Modified: c c 11 April 2015 c c Author: c c John Burkardt c c Parameters: c c Input, integer N, the order of the matrix. c c Output, double precision VALUE, the L1 condition. c implicit none double precision a_norm double precision aii double precision b_norm double precision bij integer i integer j integer n double precision value if ( n .eq. 1 ) then a_norm = 0.6D+00 else a_norm = 1.6D+00 end if b_norm = 0.0D+00 j = n do i = n, 1, -1 aii = 0.5D+00 + dble ( i ) / dble ( 10 * n ) if ( i .eq. j ) then bij = 1.0D+00 / aii else if ( i .lt. j ) then bij = bij / aii end if b_norm = b_norm + abs ( bij ) end do value = a_norm * b_norm return end subroutine biw_determinant ( n, value ) c*********************************************************************72 c cc BIW_DETERMINANT computes the determinant of the BIW matrix. c c Licensing: c c This code is distributed under the GNU LGPL license. c c Modified: c c 29 March 2015 c c Author: c c John Burkardt c c Parameters: c c Input, integer N, the order of the matrix. c c Output, double precision VALUE, the determinant. c implicit none integer n integer i double precision value value = 1.0D+00 do i = 1, n value = value * ( 0.5D+00 + dble ( i ) / dble ( 10 * n ) ) end do return end subroutine biw_inverse ( n, b ) c*********************************************************************72 c cc BIW_INVERSE returns the inverse of the BIW matrix. c c Licensing: c c This code is distributed under the GNU LGPL license. c c Modified: c c 29 March 2015 c c Author: c c John Burkardt c c Parameters: c c Input, integer N, the order of the matrix. c c Output, double precision B(N,N), the matrix. c implicit none integer n double precision aii double precision aiip1 double precision b(n,n) integer i integer j do j = n, 1, -1 do i = n, 1, -1 aii = 0.5D+00 + dble ( i ) / dble ( 10 * n ) aiip1 = -1.0D+00 if ( i .eq. j ) then b(i,j) = 1.0D+00 / aii else if ( i .lt. j ) then b(i,j) = - aiip1 * b(i+1,j) / aii else b(i,j) = 0.0D+00 end if end do end do return end subroutine bodewig ( a ) c*********************************************************************72 c cc BODEWIG returns the BODEWIG matrix. c c Example: c c 2 1 3 4 c 1 -3 1 5 c 3 1 6 -2 c 4 5 -2 -1 c c Properties: c c A is integral, therefore det ( A ) is integral, and c det ( A ) * inverse ( A ) is integral. c c A is symmetric: A' = A. c c det ( A ) = 568. c c Licensing: c c This code is distributed under the GNU LGPL license. c c Modified: c c 15 August 2008 c c Author: c c John Burkardt c c Reference: c c Joan Westlake, c A Handbook of Numerical Matrix Inversion and Solution of c Linear Equations, c John Wiley, 1968, c ISBN13: 978-0471936756, c LC: QA263.W47. c c Parameters: c c Output, double precision A(4,4), the matrix. c implicit none double precision a(4,4) double precision a_save(4,4) save a_save c c Note that the matrix entries are listed by column. c data a_save / & 2.0D+00, 1.0D+00, 3.0D+00, 4.0D+00, & 1.0D+00, -3.0D+00, 1.0D+00, 5.0D+00, & 3.0D+00, 1.0D+00, 6.0D+00, -2.0D+00, & 4.0D+00, 5.0D+00, -2.0D+00, -1.0D+00 / call r8mat_copy ( 4, 4, a_save, a ) return end subroutine bodewig_condition ( cond ) c*********************************************************************72 c cc BODEWIG_CONDITION returns the L1 condition of the BODEWIG matrix. c c Licensing: c c This code is distributed under the GNU LGPL license. c c Modified: c c 10 April 2012 c c Author: c c John Burkardt c c Parameters: c c Output, double precision COND, the L1 condition. c implicit none double precision cond cond = 10.436619718309862D+00 return end subroutine bodewig_determinant ( determ ) c*********************************************************************72 c cc BODEWIG_DETERMINANT returns the determinant of the BODEWIG matrix. c c Licensing: c c This code is distributed under the GNU LGPL license. c c Modified: c c 15 August 2008 c c Author: c c John Burkardt c c Parameters: c c Output, double precision DETERM, the determinant. c implicit none double precision determ determ = 568.0D+00 return end subroutine bodewig_eigenvalues ( lambda ) c*********************************************************************72 c cc BODEWIG_EIGENVALUES returns the eigenvalues of the BODEWIG matrix. c c Licensing: c c This code is distributed under the GNU LGPL license. c c Modified: c c 15 August 2008 c c Author: c c John Burkardt c c Parameters: c c Output, double precision LAMBDA(4), the eigenvalues. c implicit none double precision lambda(4) double precision lambda_save(4) save lambda_save data lambda_save / & -8.028578352396531D+00, & 7.932904717870018D+00, & 5.668864372830019D+00, & -1.573190738303506D+00 / call r8vec_copy ( 4, lambda_save, lambda ) return end subroutine bodewig_inverse ( a ) c*********************************************************************72 c cc BODEWIG_INVERSE returns the inverse of the BODEWIG matrix. c c Licensing: c c This code is distributed under the GNU LGPL license. c c Modified: c c 15 August 2008 c c Author: c c John Burkardt c c Parameters: c c Output, double precision A(4,4), the matrix. c implicit none double precision a(4,4) double precision a_save(4,4) integer i integer j save a_save c c Note that the matrix entries are listed by column. c data a_save / & -139.0D+00, 165.0D+00, 79.0D+00, 111.0D+00, & 165.0D+00, -155.0D+00, -57.0D+00, -1.0D+00, & 79.0D+00, -57.0D+00, 45.0D+00, -59.0D+00, & 111.0D+00, -1.0D+00, -59.0D+00, -11.0D+00 / call r8mat_copy ( 4, 4, a_save, a ) do j = 1, 4 do i = 1, 4 a(i,j) = a(i,j) / 568.0D+00 end do end do return end subroutine bodewig_plu ( p, l, u ) c*********************************************************************72 c cc BODEWIG_PLU returns the PLU factors of the BODEWIG matrix. c c Licensing: c c This code is distributed under the GNU LGPL license. c c Modified: c c 26 June 2011 c c Author: c c John Burkardt c c Parameters: c c Output, double precision P(4,4), L(4,4), U(4,4), the PLU factors. c implicit none double precision l(4,4) double precision l_save(4,4) double precision p(4,4) double precision p_save(4,4) double precision u(4,4) double precision u_save(4,4) save l_save save p_save save u_save c c Note that the matrix entries are listed by column. c data l_save / & 1.0D+00, 0.25D+00, & 0.75D+00, 0.50D+00, & 0.0D+00, 1.00D+00, & 0.647058823529412D+00, 0.352941176470588D+00, & 0.0D+00, 0.00D+00, & 1.0D+00, 0.531531531531532D+00, & 0.0D+00, 0.00D+00, & 0.0D+00, 1.0D+00 / data p_save / & 0.0D+00, 0.0D+00, 0.0D+00, 1.0D+00, & 0.0D+00, 1.0D+00, 0.0D+00, 0.0D+00, & 0.0D+00, 0.0D+00, 1.0D+00, 0.0D+00, & 1.0D+00, 0.0D+00, 0.0D+00, 0.0D+00 / data u_save / & 4.0D+00, 0.00D+00, & 0.0D+00, 0.0D+00, & 5.0D+00, -4.25D+00, & 0.00D+00, 0.0D+00, & -2.0D+00, 1.50D+00, & 6.529411764705882D+00, 0.0D+00, & -1.0D+00, 5.25D+00, & -4.647058823529412D+00, 5.117117117117118D+00 / call r8mat_copy ( 4, 4, l_save, l ) call r8mat_copy ( 4, 4, p_save, p ) call r8mat_copy ( 4, 4, u_save, u ) return end subroutine bodewig_rhs ( b ) c*********************************************************************72 c cc BODEWIG_RHS returns the BODEWIG right hand side. c c Licensing: c c This code is distributed under the GNU LGPL license. c c Modified: c c 15 August 2008 c c Author: c c John Burkardt c c Parameters: c c Output, double precision B(4), the right hand side vector. c implicit none double precision b(4) double precision b_save(4) save b_save data b_save / & 29.0D+00, 18.0D+00, 15.0D+00, 4.0D+00 / call r8vec_copy ( 4, b_save, b ) return end subroutine bodewig_eigen_right ( a ) c*********************************************************************72 c cc BODEWIG_EIGEN_RIGHT returns right eigenvectors of the BODEWIG matrix. c c Licensing: c c This code is distributed under the GNU LGPL license. c c Modified: c c 15 August 2008 c c Author: c c John Burkardt c c Parameters: c c Output, double precision A(4,4), the right eigenvector matrix. c implicit none double precision a(4,4) double precision a_save(4,4) save a_save c c Note that the matrix entries are listed by column. c data a_save / & 0.263462395147524D+00, & 0.659040718046439D+00, & -0.199633529128396D+00, & -0.675573350827063D+00, & 0.560144509774526D+00, & 0.211632763260098D+00, & 0.776708263894565D+00, & 0.195381612446620D+00, & 0.378702689441644D+00, & 0.362419048574935D+00, & -0.537935161097828D+00, & 0.660198809976478D+00, & -0.688047939843040D+00, & 0.624122855455373D+00, & 0.259800864702728D+00, & 0.263750269148100D+00 / call r8mat_copy ( 4, 4, a_save, a ) return end subroutine bodewig_solution ( x ) c*********************************************************************72 c cc BODEWIG_SOLUTION returns the BODEWIG_SOLUTION c c Licensing: c c This code is distributed under the GNU LGPL license. c c Modified: c c 15 August 2008 c c Author: c c John Burkardt c c Parameters: c c Output, double precision X(4), the solution. c implicit none double precision x(4) double precision x_save(4) save x_save data x_save / & 1.0D+00, 2.0D+00, 3.0D+00, 4.0D+00 / call r8vec_copy ( 4, x_save, x ) return end subroutine boothroyd ( n, a ) c*********************************************************************72 c cc BOOTHROYD returns the BOOTHROYD matrix. c c Formula: c c A(I,J) = C(N+I-1,I-1) * C(N-1,N-J) * N / ( I + J - 1 ) c c Example: c c N = 5 c c 5 10 10 5 1 c 15 40 45 24 5 c 35 105 126 70 15 c 70 224 280 160 35 c 126 420 540 315 70 c c Properties: c c A is not symmetric. c c A is positive definite. c c det ( A ) = 1. c c The eigenvalues are real, and come in pairs whose product is 1. c When N is odd, there is one unpaired eigenvalue equal to 1. c c The inverse matrix has the same entries, but with alternating sign. c c Licensing: c c This code is distributed under the GNU LGPL license. c c Modified: c c 16 August 2008 c c Author: c c John Burkardt c c Reference: c c John Boothroyd, c Algorithm 274: c Generation of Hilbert Derived Test Matrix, c Communications of the ACM, c Volume 9, Number 1, January 1966, page 11. c c Parameters: c c Input, integer N, the order of the matrix. c c Output, double precision A(N,N), the matrix. c implicit none integer n double precision a(n,n) integer i integer j double precision r8_choose do j = 1, n do i = 1, n a(i,j) = r8_choose ( n + i - 1, i - 1 ) & * r8_choose ( n - 1, n - j ) & * dble ( n ) / dble ( i + j - 1 ) end do end do return end subroutine boothroyd_condition ( n, value ) c*********************************************************************72 c cc BOOTHROYD_CONDITION returns the L1 condition of the BOOTHROYD matrix. c c Licensing: c c This code is distributed under the GNU LGPL license. c c Modified: c c 04 April 2015 c c Author: c c John Burkardt c c Parameters: c c Input, integer N, the order of the matrix. c c Output, double precision VALUE, the L1 condition. c implicit none double precision a_norm double precision b_norm integer i integer j integer n double precision r8_choose double precision s double precision value a_norm = 0.0D+00 do j = 1, n s = 0.0D+00 do i = 1, n s = s + r8_choose ( n + i - 1, i - 1 ) & * r8_choose ( n - 1, n - j ) & * dble ( n ) / dble ( i + j - 1 ) end do a_norm = max ( a_norm, s ) end do b_norm = a_norm value = a_norm * b_norm return end subroutine boothroyd_determinant ( n, value ) c*********************************************************************72 c cc BOOTHROYD_DETERMINANT returns the determinant of the BOOTHROYD matrix. c c Licensing: c c This code is distributed under the GNU LGPL license. c c Modified: c c 16 August 2008 c c Author: c c John Burkardt c c Parameters: c c Input, integer N, the order of the matrix. c c Output, double precision VALUE, the determinant. c implicit none integer n double precision value value = 1.0D+00 return end subroutine boothroyd_inverse ( n, a ) c*********************************************************************72 c cc BOOTHROYD_INVERSE returns the inverse of the BOOTHROYD matrix. c c Example: c c N = 5 c c 5 -10 10 -5 1 c -15 40 -45 24 -5 c 35 -105 126 -70 15 c -70 224 -280 160 -35 c 126 -420 540 -315 70 c c Licensing: c c This code is distributed under the GNU LGPL license. c c Modified: c c 16 August 2008 c c Author: c c John Burkardt c c Parameters: c c Input, integer N, the order of the matrix. c c Output, double precision A(N,N), the matrix. c implicit none integer n double precision a(n,n) integer i integer j double precision r8_choose double precision r8_mop do j = 1, n do i = 1, n a(i,j) = r8_mop ( i + j ) * r8_choose ( n + i - 1, i - 1 ) & * r8_choose ( n - 1, n - j ) & * dble ( n ) / dble ( i + j - 1 ) end do end do return end subroutine borderband ( n, a ) c*********************************************************************72 c cc BORDERBAND returns the BORDERBAND matrix. c c Formula: c c If ( I = J ) c A(I,I) = 1 c else if ( I = N ) c A(N,J) = 2^(1-J) c else if ( J = N ) c A(I,N) = 2^(1-I) c else c A(I,J) = 0 c c Example: c c N = 5 c c 1 0 0 0 1 c 0 1 0 0 1/2 c 0 0 1 0 1/4 c 0 0 0 1 1/8 c 1 1/2 1/4 1/8 1 c c Properties: c c A is symmetric: A' = A. c c A is border-banded. c c A has N-2 eigenvalues of 1. c c det ( A ) = 1 - sum ( 1 <= I <= N-1 ) 2^(2-2*I) c c For N = 2, A is singular. c c Licensing: c c This code is distributed under the GNU LGPL license. c c Modified: c c 16 August 2008 c c Author: c c John Burkardt c c Parameters: c c Input, integer N, the order of the matrix. c c Output, double precision A(N,N), the matrix. c implicit none integer n double precision a(n,n) integer i integer j do j = 1, n do i = 1, n if ( i .eq. j ) then a(i,j) = 1.0D+00 else if ( j .eq. n ) then a(i,j) = 2.0D+00 ** ( 1 - i ) else if ( i .eq. n ) then a(i,j) = 2.0D+00 ** ( 1 - j ) else a(i,j) = 0.0D+00 end if end do end do return end subroutine borderband_determinant ( n, determ ) c*********************************************************************72 c cc BORDERBAND_DETERMINANT returns the determinant of the BORDERBAND matrix. c c Licensing: c c This code is distributed under the GNU LGPL license. c c Modified: c c 16 August 2008 c c Author: c c John Burkardt c c Parameters: c c Input, integer N, the order of the matrix. c c Output, double precision DETERM, the determinant. c implicit none double precision determ integer i integer n determ = 0.0D+00 do i = 1, n - 1 determ = determ - 2.0D+00 ** ( 2 - 2 * i ) end do determ = determ + 1.0D+00 return end subroutine borderband_inverse ( n, a ) c*********************************************************************72 c cc BORDERBAND_INVERSE returns the inverse of the BORDERBAND matrix. c c Licensing: c c This code is distributed under the GNU LGPL license. c c Modified: c c 25 March 2015 c c Author: c c John Burkardt c c Parameters: c c Input, integer N, the order of the matrix. c c Output, double precision A(N,N), the inverse matrix. c implicit none integer n double precision a(n,n) double precision l(n,n) double precision l_inverse(n,n) double precision p(n,n) double precision p_inverse(n,n) double precision pl_inverse(n,n) double precision u(n,n) double precision u_inverse(n,n) call borderband_plu ( n, p, l, u ) call r8mat_transpose ( n, n, p, p_inverse ) call tri_l1_inverse ( n, l, l_inverse ) call tri_u_inverse ( n, u, u_inverse ) call r8mat_mm ( n, n, n, l_inverse, p_inverse, pl_inverse ) call r8mat_mm ( n, n, n, u_inverse, pl_inverse, a ) return end subroutine borderband_plu ( n, p, l, u ) c*********************************************************************72 c cc BORDERBAND_PLU returns the PLU factors of the BORDERBAND matrix. c c Licensing: c c This code is distributed under the GNU LGPL license. c c Modified: c c 10 June 2011 c c Author: c c John Burkardt c c Parameters: c c Input, integer N, the order of the matrix. c c Output, double precision P(N,N), L(N,N), U(N,N), the PLU factors. c implicit none integer n integer i integer j integer k double precision l(n,n) double precision p(n,n) double precision u(n,n) do j = 1, n do i = 1, n if ( i .eq. j ) then p(i,j) = 1.0D+00 else p(i,j) = 0.0D+00 end if end do end do do j = 1, n do i = 1, n if ( i .eq. j ) then l(i,j) = 1.0D+00 else if ( i .eq. n ) then l(i,j) = 2.0D+00 ** ( 1 - j ) else l(i,j) = 0.0D+00 end if end do end do do j = 1, n do i = 1, n if ( i .eq. n .and. j .eq. n ) then u(i,j) = 0.0D+00 do k = 2, n - 1 u(i,j) = u(i,j) - 2.0D+00 ** ( 2 - 2 * k ) end do else if ( i .eq. j ) then u(i,j) = 1.0D+00 else if ( j .eq. n ) then u(i,j) = 2.0D+00 ** ( 1 - i ) else u(i,j) = 0.0D+00 end if end do end do return end subroutine bvec_next_grlex ( n, bvec ) c*********************************************************************72 c cc BVEC_NEXT_GRLEX generates the next binary vector in GRLEX order. c c Discussion: c c N = 3 c c Input Output c ----- ------ c 0 0 0 => 0 0 1 c 0 0 1 => 0 1 0 c 0 1 0 => 1 0 0 c 1 0 0 => 0 1 1 c 0 1 1 => 1 0 1 c 1 0 1 => 1 1 0 c 1 1 0 => 1 1 1 c 1 1 1 => 0 0 0 c c Licensing: c c This code is distributed under the GNU LGPL license. c c Modified: c c 13 March 2015 c c Author: c c John Burkardt c c Parameters: c c Input, integer N, the dimension. c c Input, integer BVEC(N), the binary vector whose c successor is desired. c c Output, integer BVEC(N), the successor to the input vector. c implicit none integer n integer bvec(n) integer i integer o integer s integer z c c Initialize locations of 0 and 1. c if ( bvec(1) .eq. 0 ) then z = 1 o = 0 else z = 0 o = 1 end if c c Moving from right to left, search for a "1", preceded by a "0". c do i = n, 2, -1 if ( bvec(i) .eq. 1 ) then o = i if ( bvec(i-1) .eq. 0 ) then z = i - 1 go to 10 end if end if end do 10 continue c c BVEC = 0 c if ( o .eq. 0 ) then bvec(n) = 1 c c 01 never occurs. So for sure, B(1) = 1. c else if ( z .eq. 0 ) then s = sum ( bvec(1:n) ) if ( s .eq. n ) then bvec(1:n) = 0 else bvec(1:n-s-1) = 0 bvec(n-s:n) = 1 end if c c Found the rightmost "01" string. c Replace it by "10". c Shift following 1's to the right. c else bvec(z) = 1 bvec(o) = 0 s = sum ( bvec(o+1:n) ) bvec(o+1:n-s) = 0 bvec(n+1-s:n) = 1 end if return end function c8_i ( ) c*********************************************************************72 c cc C8_I returns the value of the imaginary unit, i. c c Licensing: c c This code is distributed under the GNU LGPL license. c c Modified: c c 17 August 2008 c c Author: c c John Burkardt c c Parameters: c c Output, double complex C8_I, the value of complex i. c implicit none double complex c8_i c8_i = dcmplx ( 0.0D+00, 1.0D+00 ) return end function c8_le_l2 ( x, y ) c*********************************************************************72 c cc C8_LE_L2 := X <= Y for complex values, and the L2 norm. c c Discussion: c c The L2 norm can be defined here as: c c value = sqrt ( ( real (X) )^2 + ( imag (X) )^2 ) c c Licensing: c c This code is distributed under the GNU LGPL license. c c Modified: c c 17 August 2008 c c Author: c c John Burkardt c c Parameters: c c Input, double complex X, Y, the values to be compared. c c Output, logical C8_LE_L2, is TRUE if X <= Y. c implicit none logical c8_le_l2 logical value double complex x double complex y if ( ( dreal ( x ) ) ** 2 + ( dimag ( x ) ) ** 2 .le. & ( dreal ( y ) ) ** 2 + ( dimag ( y ) ) ** 2 ) then value = .true. else value = .false. end if c8_le_l2 = value return end function c8_normal_01 ( seed ) c*********************************************************************72 c cc C8_NORMAL_01 returns a unit pseudonormal C8. c c Licensing: c c This code is distributed under the GNU LGPL license. c c Modified: c c 17 July 2006 c c Author: c c John Burkardt c c Parameters: c c Input/output, integer SEED, a seed for the random number generator. c c Output, double complex C8_NORMAL_01, a sample of the PDF. c implicit none double complex c8_normal_01 double precision r8_pi parameter ( r8_pi = 3.141592653589793D+00 ) double precision r8_uniform_01 integer seed double precision v1 double precision v2 double precision x_c double precision x_r v1 = r8_uniform_01 ( seed ) v2 = r8_uniform_01 ( seed ) x_r = sqrt ( - 2.0D+00 * log ( v1 ) ) & * cos ( 2.0D+00 * r8_pi * v2 ) x_c = sqrt ( - 2.0D+00 * log ( v1 ) ) & * sin ( 2.0D+00 * r8_pi * v2 ) c8_normal_01 = cmplx ( x_r, x_c ) return end function c8_one ( ) c*********************************************************************72 c cc C8_ONE returns the value of complex 1. c c Licensing: c c This code is distributed under the GNU LGPL license. c c Modified: c c 17 August 2008 c c Author: c c John Burkardt c c Parameters: c c Output, double complex C8_ONE, the value of complex 1. c implicit none double complex c8_one c8_one = dcmplx ( 1.0D+00, 0.0D+00 ) return end subroutine c8_swap ( x, y ) c*********************************************************************72 c cc C8_SWAP swaps two C8's. c c Discussion: c c A C8 is a double complex value. c c Licensing: c c This code is distributed under the GNU LGPL license. c c Modified: c c 27 October 2007 c c Author: c c John Burkardt c c Parameters: c c Input/output, double complex X, Y. On output, the values of X and c Y have been interchanged. c implicit none double complex x double complex y double complex z z = x x = y y = z return end function c8_uniform_01 ( seed ) c*********************************************************************72 c cc C8_UNIFORM_01 returns a unit pseudorandom C8. c c Discussion: c c A C8 is a complex double precision value. c c The angle should be uniformly distributed between 0 and 2 * PI, c the square root of the radius uniformly distributed between 0 and 1. c c This results in a uniform distribution of values in the unit circle. c c Licensing: c c This code is distributed under the GNU LGPL license. c c Modified: c c 27 February 2006 c c Author: c c John Burkardt c c Reference: c c Paul Bratley, Bennett Fox, Linus Schrage, c A Guide to Simulation, c Second Edition, c Springer, 1987, c ISBN: 0387964673, c LC: QA76.9.C65.B73. c c Bennett Fox, c Algorithm 647: c Implementation and Relative Efficiency of Quasirandom c Sequence Generators, c ACM Transactions on Mathematical Software, c Volume 12, Number 4, December 1986, pages 362-376. c c Pierre L'Ecuyer, c Random Number Generation, c in Handbook of Simulation, c edited by Jerry Banks, c Wiley, 1998, c ISBN: 0471134031, c LC: T57.62.H37. c c Peter Lewis, Allen Goodman, James Miller, c A Pseudo-Random Number Generator for the System/360, c IBM Systems Journal, c Volume 8, Number 2, 1969, pages 136-143. c c Parameters: c c Input/output, integer SEED, the "seed" value, which should NOT be 0. c On output, SEED has been updated. c c Output, double complex Z_UNIFORM_01, a pseudorandom complex value. c implicit none integer i4_huge parameter ( i4_huge = 2147483647 ) integer k double precision r8_pi parameter ( r8_pi = 3.141592653589793D+00 ) double precision r integer seed double precision theta double complex c8_uniform_01 if ( seed .eq. 0 ) then write ( *, '(a)' ) ' ' write ( *, '(a)' ) 'C8_UNIFORM_01 - Fatal error!' write ( *, '(a)' ) ' Input value of SEED = 0.' stop 1 end if k = seed / 127773 seed = 16807 * ( seed - k * 127773 ) - k * 2836 if ( seed .lt. 0 ) then seed = seed + i4_huge end if r = sqrt ( dble ( seed ) * 4.656612875D-10 ) k = seed / 127773 seed = 16807 * ( seed - k * 127773 ) - k * 2836 if ( seed .lt. 0 ) then seed = seed + i4_huge end if theta = 2.0D+00 * r8_pi * ( dble ( seed ) * 4.656612875D-10 ) c8_uniform_01 = r * dcmplx ( cos ( theta ), sin ( theta ) ) return end function c8_zero ( ) c*********************************************************************72 c cc C8_ZERO returns the value of complex 0. c c Licensing: c c This code is distributed under the GNU LGPL license. c c Modified: c c 17 August 2008 c c Author: c c John Burkardt c c Parameters: c c Output, double complex C8_ZERO, the value of complex 0. c implicit none double complex c8_zero c8_zero = dcmplx ( 0.0D+00, 0.0D+00 ) return end subroutine c8mat_house ( n, x, a ) c*********************************************************************72 c cc C8MAT_HOUSE constructs a complex Householder elementary reflector matrix. c c Discussion: c c A = I - ( 2 * X * hermitian ( X ) ) / ( conjg ( X ) * X ) c c Example: c c N = 5, X = ( 1, 1, 1, 0, -1 ) c c 1/2 -1/2 -1/2 0 1/2 c -1/2 1/2 -1/2 0 1/2 c -1/2 -1/2 1/2 0 1/2 c 0 0 0 1 0 c 1/2 1/2 1/2 0 1/2 c c Properties: c c A is hermitian: hermitian ( A ) = A. c c Because A is hermitian, it is normal. c c Because A is normal, it is diagonalizable. c c A is unitary: hermitian ( A ) * A = A * hermitian ( A ) = I. c c inverse ( A ) = A. c c det ( A ) = -1. c c LAMBDA(1) = -1. c c If X is the vector used to define A, then X is an eigenvector c of A associated with the eigenvalue of -1. c c Licensing: c c This code is distributed under the GNU LGPL license. c c Modified: c c 10 June 2011 c c Author: c c John Burkardt c c Parameters: c c Input, integer N, the order of the matrix. c c Input, double complex X(N), the vector that defines the c Householder matrix. c c Output, double complex A(N,N), the matrix. c implicit none integer n double complex a(n,n) integer i integer j double complex x(n) double precision xdot call c8mat_identity ( n, a ) xdot = 0.0D+00 do i = 1, n xdot = xdot + conjg ( x(i) ) * x(i) end do if ( 0.0D+00 .lt. xdot ) then do j = 1, n do i = 1, n a(i,j) = a(i,j) - 2.0D+00 * x(i) * conjg ( x(j) ) / xdot end do end do end if return end subroutine c8mat_house_axh ( n, a, v, ah ) c*********************************************************************72 c cc C8MAT_HOUSE_AXH computes A*H where H is a compact Householder matrix. c c Discussion: c c The Householder matrix H(V) is defined by c c H(V) = I - 2 * v * hermitian ( v ) / ( hermitian ( v ) * v ) c c This routine is not particularly efficient. c c Licensing: c c This code is distributed under the GNU LGPL license. c c Modified: c c 22 June 2011 c c Author: c c John Burkardt c c Parameters: c c Input, integer N, the order of the matrix. c c Input, double complex A(N,N), the matrix. c c Input, double complex V(N), a vector defining a Householder matrix. c c Output, double complex AH(N,N), the product A*H. c implicit none integer n double complex a(n,n) double complex ah(n,n) double complex ah_temp(n,n) double precision c8vec_norm_squared integer i integer j integer k double complex v(n) double precision v_normsq v_normsq = c8vec_norm_squared ( n, v ) c c Compute A * hermitian ( H ) = A * H c do j = 1, n do i = 1, n ah_temp(i,j) = a(i,j) do k = 1, n ah_temp(i,j) = ah_temp(i,j) & - 2.0D+00 * a(i,k) * v(k) * dconjg ( v(j) ) / v_normsq end do end do end do c c Copy the temporary result into AH. c Doing it this way means the user can identify the input arguments A and AH. c do j = 1, n do i = 1, n ah(i,j) = ah_temp(i,j) end do end do return end subroutine c8mat_house_form ( n, v, h ) c*********************************************************************72 c cc C8MAT_HOUSE_FORM constructs a Householder matrix from its compact form. c c Discussion: c c H(v) = I - 2 * v * hermitian ( v ) / ( hermitian ( v ) * v ) c c Licensing: c c This code is distributed under the GNU LGPL license. c c Modified: c c 22 June 2011 c c Author: c c John Burkardt c c Parameters: c c Input, integer N, the order of the matrix. c c Input, double complex V(N), the vector defining the c Householder matrix. c c Output, double complex H(N,N), the Householder matrix. c implicit none integer n double precision beta double precision c8vec_norm_squared double complex h(n,n) integer i integer j double complex v(n) beta = c8vec_norm_squared ( n, v ) call c8mat_identity ( n, h ) do j = 1, n do i = 1, n h(i,j) = h(i,j) - 2.0D+00 * v(i) * dconjg ( v(j) ) / beta end do end do return end subroutine c8mat_identity ( n, a ) c*********************************************************************72 c cc C8MAT_IDENTITY sets a C8MAT to the identity. c c Licensing: c c This code is distributed under the GNU LGPL license. c c Modified: c c 22 August 2008 c c Author: c c John Burkardt c c Parameters: c c Input, integer N, the order of the matrix. c c Output, double complex A(N,N), the matrix. c implicit none integer n double complex a(n,n) integer i integer j do j = 1, n do i = 1, n if ( i .eq. j ) then a(i,j) = dcmplx ( 1.0D+00, 0.0D+00 ) else a(i,j) = dcmplx ( 0.0D+00, 0.0D+00 ) end if end do end do return end subroutine c8mat_print ( m, n, a, title ) c*********************************************************************72 c cc C8MAT_PRINT prints a C8MAT. c c Discussion: c c A C8MAT is a matrix of C8's. c c Licensing: c c This code is distributed under the GNU LGPL license. c c Modified: c c 07 December 2008 c c Author: c c John Burkardt c c Parameters: c c Input, integer M, N, the number of rows and columns c in the matrix. c c Input, double complex A(M,N), the matrix. c c Input, character * ( * ) TITLE, a title. c implicit none integer m integer n double complex a(m,n) character * ( * ) title call c8mat_print_some ( m, n, a, 1, 1, m, n, title ) return end subroutine c8mat_print_some ( m, n, a, ilo, jlo, ihi, jhi, & title ) c*********************************************************************72 c cc C8MAT_PRINT_SOME prints some of a C8MAT. c c Discussion: c c A C8MAT is a matrix of C8's. c c Licensing: c c This code is distributed under the GNU LGPL license. c c Modified: c c 21 June 2010 c c Author: c c John Burkardt c c Parameters: c c Input, integer M, N, the number of rows and columns c in the matrix. c c Input, double complex A(M,N), the matrix. c c Input, integer ILO, JLO, IHI, JHI, the first row and c column, and the last row and column to be printed. c c Input, character * ( * ) TITLE, a title. c implicit none integer incx parameter ( incx = 4 ) integer m integer n double complex a(m,n) character * ( 20 ) ctemp(incx) integer i integer i2hi integer i2lo integer ihi integer ilo integer inc integer j integer j2 integer j2hi integer j2lo integer jhi integer jlo character * ( * ) title double complex zero zero = dcmplx ( 0.0D+00, 0.0D+00 ) write ( *, '(a)' ) ' ' write ( *, '(a)' ) trim ( title ) c c Print the columns of the matrix, in strips of INCX. c do j2lo = jlo, min ( jhi, n ), incx j2hi = j2lo + incx - 1 j2hi = min ( j2hi, n ) j2hi = min ( j2hi, jhi ) inc = j2hi + 1 - j2lo write ( *, '(a)' ) ' ' do j = j2lo, j2hi j2 = j + 1 - j2lo write ( ctemp(j2), '(i10,10x)' ) j end do write ( *, '(a,4a20)' ) ' Col: ', ( ctemp(j2), j2 = 1, inc ) write ( *, '(a)' ) ' Row' write ( *, '(a)' ) ' ---' c c Determine the range of the rows in this strip. c i2lo = max ( ilo, 1 ) i2hi = min ( ihi, m ) do i = i2lo, i2hi c c Print out (up to) INCX entries in row I, that lie in the current strip. c do j2 = 1, inc j = j2lo - 1 + j2 if ( a(i,j) .eq. zero ) then ctemp(j2) = ' 0.0 ' else if ( dimag ( a(i,j) ) .eq. 0.0D+00 ) then write ( ctemp(j2), '(g10.3,10x)' ) dreal ( a(i,j) ) else write ( ctemp(j2), '(2g10.3)' ) a(i,j) end if end do write ( *, '(i5,a,4a20)' ) i, ':', ( ctemp(j2), j2 = 1, inc ) end do end do return end subroutine c8mat_uniform_01 ( m, n, seed, c ) c*********************************************************************72 c cc C8MAT_UNIFORM_01 returns a unit pseudorandom C8MAT. c c Discussion: c c A C8MAT is a matrix of complex double precision values. c c The angles should be uniformly distributed between 0 and 2 * PI, c the square roots of the radius uniformly distributed between 0 and 1. c c This results in a uniform distribution of values in the unit circle. c c Licensing: c c This code is distributed under the GNU LGPL license. c c Modified: c c 05 March 2006 c c Author: c c John Burkardt c c Reference: c c Paul Bratley, Bennett Fox, Linus Schrage, c A Guide to Simulation, c Second Edition, c Springer, 1987, c ISBN: 0387964673, c LC: QA76.9.C65.B73. c c Bennett Fox, c Algorithm 647: c Implementation and Relative Efficiency of Quasirandom c Sequence Generators, c ACM Transactions on Mathematical Software, c Volume 12, Number 4, December 1986, pages 362-376. c c Pierre L'Ecuyer, c Random Number Generation, c in Handbook of Simulation, c edited by Jerry Banks, c Wiley, 1998, c ISBN: 0471134031, c LC: T57.62.H37. c c Peter Lewis, Allen Goodman, James Miller, c A Pseudo-Random Number Generator for the System/360, c IBM Systems Journal, c Volume 8, Number 2, 1969, pages 136-143. c c Parameters: c c Input, integer M, N, the number of rows and columns in the matrix. c c Input/output, integer SEED, the "seed" value, which should NOT be 0. c On output, SEED has been updated. c c Output, double complex C(M,N), the pseudorandom complex matrix. c implicit none integer m integer n double complex c(m,n) integer i integer i4_huge parameter ( i4_huge = 2147483647 ) integer j double precision r integer k double precision r8_pi parameter ( r8_pi = 3.141592653589793D+00 ) integer seed double precision theta if ( seed .eq. 0 ) then write ( *, '(a)' ) ' ' write ( *, '(a)' ) 'C4MAT_UNIFORM_01 - Fatal error!' write ( *, '(a)' ) ' Input value of SEED = 0.' stop 1 end if do j = 1, n do i = 1, m k = seed / 127773 seed = 16807 * ( seed - k * 127773 ) - k * 2836 if ( seed .lt. 0 ) then seed = seed + i4_huge end if r = sqrt ( dble ( seed ) * 4.656612875D-10 ) k = seed / 127773 seed = 16807 * ( seed - k * 127773 ) - k * 2836 if ( seed .lt. 0 ) then seed = seed + i4_huge end if theta = 2.0D+00 * r8_pi * ( dble ( seed ) * 4.656612875D-10 ) c(i,j) = r * dcmplx ( cos ( theta ), sin ( theta ) ) end do end do return end subroutine c8vec_house_column ( n, a, k, v ) c*********************************************************************72 c cc C8VEC_HOUSE_COLUMN defines a Householder premultiplier that "packs" a column. c c Discussion: c c The routine returns a vector V that defines a Householder c premultiplier matrix H(V) that zeros out the subdiagonal entries of c column K of the matrix A. c c H(V) = I - 2 * v * conjg ( v ) c c Licensing: c c This code is distributed under the GNU LGPL license. c c Modified: c c 22 June 2011 c c Author: c c John Burkardt c c Parameters: c c Input, integer N, the order of the matrix A. c c Input, double complex A(N), column K of the matrix A. c c Input, integer K, the column of the matrix to be modified. c c Output, double complex V(N), a vector of unit L2 norm which defines a c unitary Householder premultiplier matrix H with the property c that the K-th column of H * A is zero below the diagonal. c implicit none integer n double complex a(n) double precision c8vec_norm_l2 integer i integer k double precision s double complex v(n) do i = 1, n v(i) = dcmplx ( 0.0D+00, 0.0D+00 ) end do if ( k .lt. 1 .or. n .le. k ) then return end if s = c8vec_norm_l2 ( n + 1 - k, a(k) ) if ( s .eq. 0.0D+00 ) then return end if v(k) = a(k) + s * a(k) / cdabs ( a(k) ) do i = k + 1, n v(i) = a(i) end do s = c8vec_norm_l2 ( n + 1 - k, v(k) ) do i = k, n v(i) = v(i) / s end do return end function c8vec_norm_l2 ( n, a ) c*********************************************************************72 c cc C8VEC_NORM_L2 returns the L2 norm of a C8VEC. c c Discussion: c c A C8VEC is a vector of C8's c c The vector L2 norm is defined as: c c C8VEC_NORM_L2 = sqrt ( sum ( 1 <= I <= N ) conjg ( A(I) ) * A(I) ). c c Licensing: c c This code is distributed under the GNU LGPL license. c c Modified: c c 07 December 2008 c c Author: c c John Burkardt c c Parameters: c c Input, integer N, the number of entries in A. c c Input, double complex A(N), the vector whose L2 norm is desired. c c Output, double precision C8VEC_NORM_L2, the L2 norm of A. c implicit none integer n double complex a(n) double precision c8vec_norm_l2 integer i c8vec_norm_l2 = 0.0D+00 do i = 1, n c8vec_norm_l2 = c8vec_norm_l2 + dconjg ( a(i) ) * a(i) end do c8vec_norm_l2 = dsqrt ( c8vec_norm_l2 ) return end function c8vec_norm_squared ( n, a ) c*********************************************************************72 c cc C8VEC_NORM_SQUARED returns the square of the L2 norm of a C8VEC. c c Discussion: c c A C8VEC is a vector of C8's. c c The square of the vector L2 norm is defined as: c c C8VEC_NORM_SQUARED = sum ( 1 <= I <= N ) conjg ( A(I) ) * A(I). c c Licensing: c c This code is distributed under the GNU LGPL license. c c Modified: c c 22 June 2011 c c Author: c c John Burkardt c c Parameters: c c Input, integer N, the number of entries in A. c c Input, double complex A(N), the vector whose L2 norm is desired. c c Output, double precision C8VEC_NORM_SQUARED, the L2 norm of A. c implicit none integer n double complex a(n) integer i double precision c8vec_norm_squared c8vec_norm_squared = 0.0D+00 do i = 1, n c8vec_norm_squared = c8vec_norm_squared + dconjg ( a(i) ) * a(i) end do return end subroutine c8vec_print ( n, a, title ) c*********************************************************************72 c cc C8VEC_PRINT prints a C8VEC, with an optional title. c c Discussion: c c A C8VEC is a vector of C8's c c Licensing: c c This code is distributed under the GNU LGPL license. c c Modified: c c 07 December 2008 c c Author: c c John Burkardt c c Parameters: c c Input, integer N, the number of components of the vector. c c Input, double complex A(N), the vector to be printed. c c Input, character*(*) TITLE, a title. c implicit none integer n double complex a(n) integer i character*(*) title write ( *, '(a)' ) ' ' write ( *, '(a)' ) trim ( title ) write ( *, '(a)' ) ' ' do i = 1, n write ( *, '(2x,i8,a,1x,2g14.6)' ) i, ':', a(i) end do return end subroutine c8vec_print_some ( n, x, i_lo, i_hi, title ) c*********************************************************************72 c cc C8VEC_PRINT_SOME prints some of a C8VEC. c c Discussion: c c A C8VEC is a vector of C8's. c c Licensing: c c This code is distributed under the GNU LGPL license. c c Modified: c c 18 October 2006 c c Author: c c John Burkardt c c Parameters: c c Input, integer N, the number of entries of the vector. c c Input, double complex X(N), the vector to be printed. c c Input, integer I_LO, I_HI, the first and last entries c to print. c c Input, character*(*) TITLE, a title. c implicit none integer n integer i integer i_hi integer i_lo character*(*) title double complex x(n) write ( *, '(a)' ) ' ' write ( *, '(a)' ) trim ( title ) write ( *, '(a)' ) ' ' do i = max ( 1, i_lo ), min ( n, i_hi ) write ( *, '(2x,i8,a,1x,2g14.6)' ) i, ':', x(i) end do return end subroutine c8vec_sort_a_l2 ( n, x ) c*********************************************************************72 c cc C8VEC_SORT_A_L2 ascending sorts a C8VEC by L2 norm. c c Discussion: c c A C8VEC is a vector of C8's. c c The L2 norm of A+Bi is sqrt ( A^2 + B^2 ). c c Licensing: c c This code is distributed under the GNU LGPL license. c c Modified: c c 07 December 2008 c c Author: c c John Burkardt c c Parameters: c c Input, integer N, the number of entries in the array. c c Input/output, double complex X(N). c On input, an unsorted array. c On output, X has been sorted. c implicit none integer n logical c8_le_l2 integer i integer indx integer isgn integer j double complex x(n) if ( n .le. 1 ) then return end if i = 0 indx = 0 isgn = 0 j = 0 10 continue call sort_heap_external ( n, indx, i, j, isgn ) if ( 0 .lt. indx ) then call c8_swap ( x(i), x(j) ) else if ( indx .lt. 0 ) then if ( c8_le_l2 ( x(i), x(j) ) ) then isgn = -1 else isgn = +1 end if else if ( indx .eq. 0 ) then go to 20 end if go to 10 20 continue return end subroutine c8vec_uniform_01 ( n, seed, c ) c*********************************************************************72 c cc C8VEC_UNIFORM_01 returns a unit pseudorandom C8VEC. c c Discussion: c c A C8VEC is a vector of complex double precision values. c c The angles should be uniformly distributed between 0 and 2 * PI, c the square roots of the radius uniformly distributed between 0 and 1. c c This results in a uniform distribution of values in the unit circle. c c Licensing: c c This code is distributed under the GNU LGPL license. c c Modified: c c 05 March 2006 c c Author: c c John Burkardt c c Reference: c c Paul Bratley, Bennett Fox, Linus Schrage, c A Guide to Simulation, c Second Edition, c Springer, 1987, c ISBN: 0387964673, c LC: QA76.9.C65.B73. c c Bennett Fox, c Algorithm 647: c Implementation and Relative Efficiency of Quasirandom c Sequence Generators, c ACM Transactions on Mathematical Software, c Volume 12, Number 4, December 1986, pages 362-376. c c Pierre L'Ecuyer, c Random Number Generation, c in Handbook of Simulation, c edited by Jerry Banks, c Wiley, 1998, c ISBN: 0471134031, c LC: T57.62.H37. c c Peter Lewis, Allen Goodman, James Miller, c A Pseudo-Random Number Generator for the System/360, c IBM Systems Journal, c Volume 8, Number 2, 1969, pages 136-143. c c Parameters: c c Input, integer N, the number of values to compute. c c Input/output, integer SEED, the "seed" value, which should NOT be 0. c On output, SEED has been updated. c c Output, double complex C(N), the pseudorandom complex vector. c implicit none integer n double complex c(n) integer i integer i4_huge parameter ( i4_huge = 2147483647 ) integer k double precision r8_pi parameter ( r8_pi = 3.141592653589793D+00 ) double precision r integer seed double precision theta if ( seed .eq. 0 ) then write ( *, '(a)' ) ' ' write ( *, '(a)' ) 'C8VEC_UNIFORM_01 - Fatal error!' write ( *, '(a)' ) ' Input value of SEED = 0.' stop 1 end if do i = 1, n k = seed / 127773 seed = 16807 * ( seed - k * 127773 ) - k * 2836 if ( seed .lt. 0 ) then seed = seed + i4_huge end if r = sqrt ( dble ( seed ) * 4.656612875D-10 ) k = seed / 127773 seed = 16807 * ( seed - k * 127773 ) - k * 2836 if ( seed .lt. 0 ) then seed = seed + i4_huge end if theta = 2.0D+00 * r8_pi * ( dble ( seed ) * 4.656612875D-10 ) c(i) = r * dcmplx ( cos ( theta ), sin ( theta ) ) end do return end subroutine c8vec_unity ( n, a ) c*********************************************************************72 c cc C8VEC_UNITY returns the N roots of unity. c c Discussion: c c A C8VEC is a vector of double complex values. c c X(1:N) = exp ( 2 * PI * (0:N-1) / N ) c c X(1:N)^N = ( (1,0), (1,0), ..., (1,0) ). c c Licensing: c c This code is distributed under the GNU LGPL license. c c Modified: c c 27 October 2007 c c Author: c c John Burkardt c c Parameters: c c Input, integer N, the number of elements of A. c c Output, double complex A(N), the N roots of unity. c implicit none integer n double complex a(n) integer i double precision r8_pi parameter ( r8_pi = 3.141592653589793D+00 ) double precision theta do i = 1, n theta = r8_pi * dble ( 2 * ( i - 1 ) ) / dble ( n ) a(i) = dcmplx ( dcos ( theta ), dsin ( theta ) ) end do return end subroutine carry ( n, alpha, a ) c*********************************************************************72 c cc CARRY returns the CARRY matrix. c c Discussion: c c We assume that arithmetic is being done in base ALPHA. We are adding c a column of N digits base ALPHA, as part of adding N random numbers. c We know the carry digit, between 0 and N-1, that is being carried into the c column sum (the incarry digit), and we want to know the probability of c the various carry digits 0 through N-1 (the outcarry digit) that could c be carried out of the column sum. c c The carry matrix summarizes this data. The entry A(I,J) represents c the probability that, given that the incarry digit is I-1, the c outcarry digit will be J-1. c c Formula: c c A(I,J) = ( 1 / ALPHA )^N * sum ( 0 <= K <= J-1 - floor ( I-1 / ALPHA ) ) c (-1)^K * C(N+1,K) * C(N-I+(J-K)*ALPHA, N ) c c Example: c c ALPHA = 10, N = 4 c c 0.0715 0.5280 0.3795 0.0210 c 0.0495 0.4840 0.4335 0.0330 c 0.0330 0.4335 0.4840 0.0495 c 0.0210 0.3795 0.5280 0.0715 c c Properties: c c A is generally not symmetric: A' /= A. c c A is a Markov matrix. c c A is centrosymmetric: A(I,J) = A(N+1-I,N+1-J). c c LAMBDA(I) = 1 / ALPHA^(I-1) c c det ( A ) = 1 / ALPHA^((N*(N-1))/2) c c The eigenvectors do not depend on ALPHA. c c A is generally not normal: A' * A /= A * A'. c c Licensing: c c This code is distributed under the GNU LGPL license. c c Modified: c c 18 August 2008 c c Author: c c John Burkardt c c Reference: c c John Holte, c Carries, Combinatorics, and an Amazing Matrix, c The American Mathematical Monthly, c Volume 104, Number 2, February 1997, pages 138-149. c c Parameters: c c Input, integer N, the order of the matrix. c c Input, integer ALPHA, the numeric base being used c in the addition. c c Output, double precision A(N,N), the matrix. c implicit none integer n double precision a(n,n) integer alpha double precision c1 double precision c2 integer i integer j integer k double precision r8_choose double precision r8_mop double precision temp do j = 1, n do i = 1, n temp = 0.0D+00 do k = 0, j - 1 - ( i - 1 ) / alpha c1 = r8_choose ( n + 1, k ) c2 = r8_choose ( n - i + ( j - k ) * alpha, n ) temp = temp + r8_mop ( k ) * c1 * c2 end do a(i,j) = temp / dble ( alpha**n ) end do end do return end subroutine carry_determinant ( n, alpha, determ ) c*********************************************************************72 c cc CARRY_DETERMINANT returns the determinant of the CARRY matrix. c c Licensing: c c This code is distributed under the GNU LGPL license. c c Modified: c c 18 August 2008 c c Author: c c John Burkardt c c Parameters: c c Input, integer N, the order of the matrix. c c Input, integer ALPHA, the numeric base being used c in the addition. c c Output, double precision DETERM, the determinant. c implicit none integer n integer alpha double precision determ integer power power = ( n * ( n - 1 ) ) / 2 determ = 1.0D+00 / dble ( alpha ** power ) return end subroutine carry_eigen_left ( n, alpha, a ) c*********************************************************************72 c cc CARRY_EIGEN_LEFT returns the left eigenvectors of the CARRY matrix. c c Formula: c c A(I,J) = sum ( 0 <= K <= J-1 ) c (-1)^K * C(N+1,K) * ( J - K )^(N+1-I) c c Example: c c N = 4 c c 1 11 11 1 c 1 3 -3 -1 c 1 -1 -1 1 c 1 -3 3 -1 c c Properties: c c A is generally not symmetric: A' /= A. c c Column 1 is all 1's, and column N is (-1)^(I+1). c c The top row is proportional to a row of Eulerian numbers, and c can be normalized to represent the stationary probablities c for the carrying process when adding N random numbers. c c The bottom row is proportional to a row of Pascal's triangle, c with alternating signs. c c The product of the left and right eigenvector matrices of c order N is N! times the identity. c c Licensing: c c This code is distributed under the GNU LGPL license. c c Modified: c c 18 August 2008 c c Author: c c John Burkardt c c Reference: c c John Holte, c Carries, Combinatorics, and an Amazing Matrix, c The American Mathematical Monthly, c Volume 104, Number 2, February 1997, pages 138-149. c c Parameters: c c Input, integer N, the order of the matrix. c c Input, integer ALPHA, the numeric base being used c in the addition. c c Output, double precision A(N,N), the matrix. c implicit none integer n double precision a(n,n) double precision alpha integer i integer j integer k double precision r8_choose double precision r8_mop do j = 1, n do i = 1, n a(i,j) = 0.0D+00 end do end do do j = 1, n do i = 1, n do k = 0, j-1 a(i,j) = a(i,j) + r8_mop ( k ) * r8_choose ( n + 1, k ) & * ( j - k ) ** ( n + 1 - i ) end do end do end do return end subroutine carry_eigen_right ( n, alpha, a ) c*********************************************************************72 c cc CARRY_EIGEN_RIGHT returns right eigenvectors of the CARRY matrix. c c Discussion: c c A(I,J) = sum ( N+1-J) <= K <= N ) c S1(N,K) * C(K,N+1-J) ( N - I )^(K-N+J-1) c c where S1(N,K) is a signed Sterling number of the first kind. c c Example: c c N = 4 c c 1 6 11 6 c 1 2 -1 -2 c 1 -2 -1 2 c 1 -6 11 -6 c c Properties: c c A is generally not symmetric: A' /= A. c c The first column is all 1's. c c The last column is reciprocals of binomial coefficients with c alternating sign multiplied by (N-1)!. c c The top and bottom rows are the unsigned and signed Stirling numbers c of the first kind. c c The entries in the J-th column are a degree (J-1) polynomial c in the row index I. (Column 1 is constant, the first difference c in column 2 is constant, the second difference in column 3 is c constant, and so on.) c c Licensing: c c This code is distributed under the GNU LGPL license. c c Modified: c c 18 August 2008 c c Author: c c John Burkardt c c Reference: c c John Holte, c Carries, Combinatorics, and an Amazing Matrix, c The American Mathematical Monthly, c Volume 104, Number 2, February 1997, pages 138-149.. c c Parameters: c c Input, integer N, the order of the matrix. c c Input, integer ALPHA, the numeric base being used c in the addition. c c Output, double precision A(N,N), the matrix. c implicit none integer n double precision a(n,n) double precision alpha integer i integer j integer k double precision r8_choose double precision s1(n,n) call stirling ( n, n, s1 ) do j = 1, n do i = 1, n a(i,j) = 0.0D+00 end do end do do j = 1, n do i = 1, n do k = n + 1 - j, n if ( n - i .eq. 0 .and. k - n + j - 1 .eq. 0 ) then a(i,j) = a(i,j) + s1(n,k) * r8_choose ( k, n + 1 - j ) else a(i,j) = a(i,j) + s1(n,k) * r8_choose ( k, n + 1 - j ) & * ( n - i ) ** ( k - n + j - 1 ) end if end do end do end do return end subroutine carry_eigenvalues ( n, alpha, lambda ) c*********************************************************************72 c cc CARRY_EIGENVALUES returns the eigenvalues of the CARRY matrix. c c Licensing: c c This code is distributed under the GNU LGPL license. c c Modified: c c 18 August 2008 c c Author: c c John Burkardt c c Parameters: c c Input, integer N, the order of the matrix. c c Input, integer ALPHA, the numeric base being used c in the addition. c c Output, double precision LAMBDA(N), the eigenvalues. c implicit none integer n integer alpha integer i double precision lambda(n) do i = 1, n lambda(i) = 1.0D+00 / dble ( alpha ** ( i - 1 ) ) end do return end subroutine carry_inverse ( n, alpha, a ) c*********************************************************************72 c cc CARRY_INVERSE returns the inverse of the CARRY matrix. c c Licensing: c c This code is distributed under the GNU LGPL license. c c Modified: c c 18 August 2008 c c Author: c c John Burkardt c c Parameters: c c Input, integer N, the order of the matrix. c c Input, integer ALPHA, the numeric base being used c in the addition. c c Output, double precision A(N,N), the matrix. c implicit none integer n double precision a(n,n) integer alpha double precision d(n) double precision d_inv(n,n) double precision dv(n,n) integer i integer j integer k double precision r8_factorial double precision t double precision u(n,n) double precision v(n,n) call carry_eigen_left ( n, alpha, v ) call carry_eigenvalues ( n, alpha, d ) do i = 1, n d(i) = 1.0D+00 / d(i) end do call diagonal ( n, n, d, d_inv ) call carry_eigen_right ( n, alpha, u ) do j = 1, n do i = 1, n dv(i,j) = 0.0D+00 do k = 1, n dv(i,j) = dv(i,j) + d_inv(i,k) * v(k,j) end do end do end do do j = 1, n do i = 1, n a(i,j) = 0.0D+00 do k = 1, n a(i,j) = a(i,j) + u(i,k) * dv(k,j) end do end do end do t = r8_factorial ( n ) do j = 1, n do i = 1, n a(i,j) = a(i,j) / t end do end do return end subroutine cauchy ( n, x, y, a ) c*********************************************************************72 c cc CAUCHY returns the CAUCHY matrix. c c Formula: c c A(I,J) = 1.0D+00 / ( X(I) + Y(J) ) c c Example: c c N = 5, X = ( 1, 3, 5, 8, 7 ), Y = ( 2, 4, 6, 10, 9 ) c c 1/3 1/5 1/7 1/11 1/10 c 1/5 1/7 1/9 1/13 1/12 c 1/7 1/9 1/11 1/15 1/14 c 1/10 1/12 1/14 1/18 1/17 c 1/9 1/11 1/13 1/17 1/16 c c or, in decimal form, c c 0.333333 0.200000 0.142857 0.0909091 0.100000 c 0.200000 0.142857 0.111111 0.0769231 0.0833333 c 0.142857 0.111111 0.0909091 0.0666667 0.0714286 c 0.100000 0.0833333 0.0714286 0.0555556 0.0588235 c 0.111111 0.0909091 0.0769231 0.0588235 0.0625000 c c Properties: c c A is generally not symmetric: A' /= A. c c A is totally positive if 0 < X(1) < ... < X(N) and 0 < Y1 < ... < Y(N). c c A will be singular if any X(I) equals X(J), or c any Y(I) equals Y(J), or if any X(I)+Y(J) equals zero. c c A is generally not normal: A' * A /= A * A'. c c The Hilbert matrix is a special case of the Cauchy matrix. c c The Parter matrix is a special case of the Cauchy matrix. c c The Ris or "ding-dong" matrix is a special case of the Cauchy matrix. c c det ( A ) = product ( 1 <= I < J <= N ) ( X(J) - X(I) )* ( Y(J) - Y(I) ) c / product ( 1 <= I <= N, 1 <= J <= N ) ( X(I) + Y(J) ) c c The inverse of A is c c INVERSE(A)(I,J) = product ( 1 <= K <= N ) [ (X(J)+Y(K)) * (X(K)+Y(I)) ] / c [ (X(J)+Y(I)) * product ( 1 <= K <= N, K /= J ) (X(J)-X(K)) c * product ( 1 <= K <= N, K /= I ) (Y(I)-Y(K)) ] c c The family of matrices is nested as a function of N. c c Licensing: c c This code is distributed under the GNU LGPL license. c c Modified: c c 18 August 2008 c c Author: c c John Burkardt c c Reference: c c Reference: c c Robert Gregory, David Karney, c A Collection of Matrices for Testing Computational Algorithms, c Wiley, 1969, c ISBN: 0882756494, c LC: QA263.G68. c c Nicholas Higham, c Accuracy and Stability of Numerical Algorithms, c SIAM, 1996. c c Donald Knuth, c The Art of Computer Programming, c Volume 1, Fundamental Algorithms, Second Edition c Addison-Wesley, Reading, Massachusetts, 1973, page 36. c c Olga Taussky, Marvin Marcus, c Eigenvalues of finite matrices, c in Survey of Numerical Analysis, c Edited by John Todd, c McGraw-Hill, pages 279-313, 1962. c c Evgeny Tyrtyshnikov, c Cauchy-Toeplitz matrices and some applications, c Linear Algebra and Applications, c Volume 149, 1991, pages 1-18. c c Parameters: c c Input, integer N, the order of the matrix. c c Input, double precision X(N), Y(N), vectors that determine A. c c Output, double precision A(N,N), the matrix. c implicit none integer n double precision a(n,n) integer i integer j double precision x(n) double precision y(n) do j = 1, n do i = 1, n if ( x(i) + y(j) .eq. 0.0D+00 ) then write ( *, '(a)' ) ' ' write ( *, '(a)' ) 'CAUCHY - Fatal error!' write ( *, '(a)' ) ' The denominator X(I)+Y(J) was zero' write ( *, '(a,i8)' ) ' for I = ', i write ( *, '(a,g14.6)' ) ' X(I)=', x(i) write ( *, '(a,i8)' ) ' and J = ', j write ( *, '(a,g14.6)' ) ' Y(J)=', y(j) stop 1 end if a(i,j) = 1.0D+00 / ( x(i) + y(j) ) end do end do return end subroutine cauchy_determinant ( n, x, y, determ ) c*********************************************************************72 c cc CAUCHY_DETERMINANT returns the determinant of the CAUCHY matrix. c c Licensing: c c This code is distributed under the GNU LGPL license. c c Modified: c c 18 August 2008 c c Author: c c John Burkardt c c Parameters: c c Input, integer N, the order of the matrix. c c Input, double precision X(N), Y(N), vectors that determine A. c c Output, double precision DETERM, the determinant. c implicit none integer n double precision bottom double precision determ integer i integer j double precision top double precision x(n) double precision y(n) top = 1.0D+00 do i = 1, n do j = i + 1, n top = top * ( x(j) - x(i) ) * ( y(j) - y(i) ) end do end do bottom = 1.0D+00 do j = 1, n do i = 1, n bottom = bottom * ( x(i) + y(j) ) end do end do determ = top / bottom return end subroutine cauchy_inverse ( n, x, y, a ) c*********************************************************************72 c cc CAUCHY_INVERSE returns the inverse of the CAUCHY matrix. c c Formula: c c A(I,J) = product ( 1 <= K <= N ) [(X(J)+Y(K))*(X(K)+Y(I))] / c [ (X(J)+Y(I)) * product ( 1 <= K <= N, K /= J ) (X(J)-X(K)) c * product ( 1 <= K <= N, K /= I ) (Y(I)-Y(K)) ] c c Example: c c N = 5, X = ( 1, 3, 5, 8, 7 ), Y = ( 2, 4, 6, 10, 9 ) c c 241.70 -2591.37 9136.23 10327.50 -17092.97 c -2382.19 30405.38 -116727.19 -141372.00 229729.52 c 6451.76 -89667.70 362119.56 459459.00 -737048.81 c 10683.11 -161528.55 690983.38 929857.44 -1466576.75 c -14960.00 222767.98 -942480.06 -1253376.00 1983696.00 c c Properties: c c A is generally not symmetric: A' /= A. c c The sum of the entries of A equals the sum of the entries of X and Y. c c Licensing: c c This code is distributed under the GNU LGPL license. c c Modified: c c 18 August 2008 c c Author: c c John Burkardt c c Reference: c c Donald Knuth, c The Art of Computer Programming, c Volume 1, Fundamental Algorithms, Second Edition, c Addison-Wesley, Reading, Massachusetts, 1973, page 36. c c Parameters: c c Input, integer N, the order of the matrix. c c Input, double precision X(N), Y(N), vectors that determine A. c The following conditions on X and Y must hold: c c X(I)+Y(J) must not be zero for any I and J; c X(I) must never equal X(J); c Y(I) must never equal Y(J). c c Output, double precision A(N,N), the matrix. c implicit none integer n double precision a(n,n) double precision bot1 double precision bot2 integer i integer j integer k double precision top double precision x(n) double precision y(n) c c Check the data. c do j = 1, n do i = 1, n if ( x(i) + y(j) .eq. 0.0D+00 ) then write ( *, '(a)' ) ' ' write ( *, '(a)' ) 'CAUCHY_INVERSE - Fatal error!' write ( *, '(a)' ) ' The denominator X(I)+Y(J) was zero' write ( *, '(a,i8)' ) ' for I = ', i write ( *, '(a,i8)' ) ' and J = ', j stop 1 end if if ( i .ne. j .and. x(i) .eq. x(j) ) then write ( *, '(a)' ) ' ' write ( *, '(a)' ) 'CAUCHY_INVERSE - Fatal error!' write ( *, '(a)' ) ' X(I) equals X(J)' write ( *, '(a,i8)' ) ' for I = ', i write ( *, '(a,i8)' ) ' and J = ', j stop 1 end if if ( i .ne. j .and. y(i) .eq. y(j) ) then write ( *, '(a)' ) ' ' write ( *, '(a)' ) 'CAUCHY_INVERSE - Fatal error!' write ( *, '(a)' ) ' Y(I) equals Y(J)' write ( *, '(a,i8)' ) ' for I = ', i write ( *, '(a,i8)' ) ' and J = ', j stop 1 end if end do end do do j = 1, n do i = 1, n top = 1.0D+00 bot1 = 1.0D+00 bot2 = 1.0D+00 do k = 1, n top = top * ( x(j) + y(k) ) * ( x(k) + y(i) ) if ( k .ne. j ) then bot1 = bot1 * ( x(j) - x(k) ) end if if ( k .ne. i ) then bot2 = bot2 * ( y(i) - y(k) ) end if end do a(i,j) = top / ( ( x(j) + y(i) ) * bot1 * bot2 ) end do end do return end subroutine cheby_diff1 ( n, a ) c*********************************************************************72 c cc CHEBY_DIFF1 returns the CHEBY_DIFF1 matrix. c c Example: c c N = 6 c c 8.5000 -10.4721 2.8944 -1.5279 1.1056 -0.5000 c 2.6180 -1.1708 -2.0000 0.8944 -0.6810 0.2764 c -0.7236 2.0000 -0.1708 1.6180 0.8944 -0.3820 c 0.3820 -0.8944 1.6180 0.1708 -2.0000 0.7236 c -0.2764 0.6180 -0.8944 2.0000 1.1708 -2.6180 c 0.5000 -1.1056 1.5279 -2.8944 10.4721 -8.5000 c c Properties: c c If N is odd, then det ( A ) = 0. c c Licensing: c c This code is distributed under the GNU LGPL license. c c Modified: c c 19 August 2008 c c Author: c c John Burkardt c c Reference: c c Lloyd Trefethen, c Spectral Methods in MATLAB, c SIAM, 2000, page 54. c c Parameters: c c Input, integer N, the order of the matrix. c c Output, double precision A(N,N), the matrix. c implicit none integer n double precision a(n,n) double precision c(n) integer i integer j double precision r8_mop double precision r8_pi parameter ( r8_pi = 3.141592653589793D+00 ) double precision x(n) if ( n .le. 0 ) then return end if if ( n .eq. 1 ) then a(1,1) = 1.0D+00 return end if c(1) = 2.0D+00 do i = 2, n - 1 c(i) = 1.0D+00 end do c(n) = 2.0D+00 c c Get the Chebyshev points. c do i = 1, n x(i) = cos ( r8_pi * dble ( i - 1 ) / dble ( n - 1 ) ) end do do j = 1, n do i = 1, n if ( i .ne. j ) then a(i,j) = r8_mop ( i + j ) & * c(i) / ( c(j) * ( x(i) - x(j) ) ) else if ( i .eq. 1 ) then a(i,i) = dble ( 2 * ( n - 1 ) * ( n - 1 ) + 1 ) / 6.0D+00 else if ( i .eq. n ) then a(i,i) = - dble ( 2 * ( n - 1 ) * ( n - 1 ) + 1 ) / 6.0D+00 else a(i,i) = - 0.5D+00 * x(i) / ( 1.0D+00 - x(i) * x(i) ) end if end do end do return end subroutine cheby_diff1_null_left ( m, n, x ) c*********************************************************************72 c cc CHEBY_DIFF1_NULL_LEFT returns a left null vector of the CHEBY_DIFF1 matrix. c c Discussion: c c The matrix only has a (nonzero) null vector when N is odd. c c Licensing: c c This code is distributed under the GNU LGPL license. c c Modified: c c 13 March 2015 c c Author: c c John Burkardt c c Parameters: c c Input, integer M, N, the order of the matrix. c c Output, double precision X(M), the null vector. c implicit none integer m integer n integer i double precision t double precision x(m) if ( mod ( m, 2 ) .eq. 1 ) then x(1) = 1.0D+00 t = -2.0D+00 do i = 2, m - 1 x(i) = t t = -t end do x(m) = 1.0D+00 else do i = 1, m x(i) = 0.0D+00 end do end if return end subroutine cheby_diff1_null_right ( m, n, x ) c*********************************************************************72 c cc CHEBY_DIFF1_NULL_RIGHT returns a right null vector of the CHEBY_DIFF1 matrix. c c Discussion: c c The matrix only has a (nonzero) null vector when N is odd. c c Licensing: c c This code is distributed under the GNU LGPL license. c c Modified: c c 19 August 2008 c c Author: c c John Burkardt c c Parameters: c c Input, integer M, N, the order of the matrix. c c Output, double precision X(N), the null vector. c implicit none integer m integer n integer i double precision x(n) if ( mod ( n, 2 ) .eq. 1 ) then do i = 1, n x(i) = 1.0D+00 end do else do i = 1, n x(i) = 0.0D+00 end do end if return end subroutine cheby_t ( n, a ) c*********************************************************************72 c cc CHEBY_T returns the CHEBY_T matrix. c c Discussion c c CHEBY_T is the Chebyshev T matrix, associated with the Chebyshev c "T" polynomials, or Chebyshev polynomials of the first kind. c c Example: c c N = 11 c c 1 . . . . . . . . . . c . 1 . . . . . . . . . c -1 . 2 . . . . . . . . c . -3 . 4 . . . . . . . c 1 . -8 . 8 . . . . . . c . 5 . -20 . 16 . . . . . c -1 . 18 . -48 . 32 . . . . c . -7 . 56 . -112 . 64 . . . c 1 . -32 . 160 . -256 . 128 . . c . 9 . -120 . 432 . -576 . 256 . c -1 . 50 . -400 . 1120 . -1280 . 512 c c Properties: c c A is generally not symmetric: A' /= A. c c A is integral, therefore det ( A ) is integral, and c det ( A ) * inverse ( A ) is integral. c c A is reducible. c c A is lower triangular. c c Each row of A sums to 1. c c det ( A ) = 2^( (N-1) * (N-2) / 2 ) c c A is not normal: A' * A /= A * A'. c c For I = 1: c c LAMBDA(1) = 1 c c For 1 < I c c LAMBDA(I) = 2^(I-2) c c The family of matrices is nested as a function of N. c c Licensing: c c This code is distributed under the GNU LGPL license. c c Modified: c c 19 August 2008 c c Author: c c John Burkardt c c Parameters: c c Input, integer N, the order of the matrix. c c Output, double precision A(N,N), the matrix. c implicit none integer n double precision a(n,n) integer i integer j if ( n .le. 0 ) then return end if do j = 1, n do i = 1, n a(i,j) = 0.0D+00 end do end do a(1,1) = 1.0D+00 if ( n .eq. 1 ) then return end if a(2,2) = 1.0D+00 if ( n .eq. 2 ) then return end if do i = 3, n do j = 1, n if ( j .eq. 1 ) then a(i,j) = - a(i-2,j) else a(i,j) = 2.0D+00 * a(i-1,j-1) - a(i-2,j) end if end do end do return end subroutine cheby_t_determinant ( n, determ ) c*********************************************************************72 c cc CHEBY_T_DETERMINANT returns the determinant of the CHEBY_T matrix. c c Licensing: c c This code is distributed under the GNU LGPL license. c c Modified: c c 19 August 2008 c c Author: c c John Burkardt c c Parameters: c c Input, integer N, the order of the matrix. c c Output, double precision DETERM, the determinant. c implicit none double precision determ integer n integer power power = ( ( n - 1 ) * ( n - 2 ) ) / 2 determ = dble ( 2 ** power ) return end subroutine cheby_t_eigenvalues ( n, lambda ) c*********************************************************************72 c cc CHEBY_T_EIGENVALUES returns the eigenvalues of the CHEBY_T matrix. c c Licensing: c c This code is distributed under the GNU LGPL license. c c Modified: c c 30 August 2008 c c Author: c c John Burkardt c c Parameters: c c Input, integer N, the order of the matrix. c c Output, double precision LAMBDA(N), the eigenvalues. c implicit none integer n integer i double precision lambda(n) lambda(1) = 1.0D+00 do i = 2, n lambda(i) = 2.0D+00 ** ( i - 2 ) end do return end subroutine cheby_t_inverse ( n, a ) c*********************************************************************72 c cc CHEBY_T_INVERSE returns the inverse of the CHEBY_T matrix. c c Example: c c N = 11 c c 1 . . . . . . . . . . c . 1 . . . . . . . . . c 1 . 1 . . . . . . . . / 2 c . 3 . 1 . . . . . . . / 4 c 3 . 4 . 1 . . . . . . / 8 c . 10 . 5 . 1 . . . . . / 16 c 10 . 15 . 6 . 1 . . . . / 32 c . 35 . 21 . 7 . 1 . . . / 64 c 35 . 56 . 28 . 8 . 1 . . / 128 c . 126 . 84 . 36 . 9 . 1 . / 256 c 126 . 210 . 120 . 45 . 10 . 1 / 512 c c Licensing: c c This code is distributed under the GNU LGPL license. c c Modified: c c 19 August 2008 c c Author: c c John Burkardt c c Parameters: c c Input, integer N, the order of the matrix. c c Output, double precision A(N,N), the matrix. c implicit none integer n double precision a(n,n) integer i integer j if ( n .le. 0 ) then return end if do j = 1, n do i = 1, n a(i,j) = 0.0D+00 end do end do a(1,1) = 1.0D+00 if ( n .eq. 1 ) then return end if a(2,2) = 1.0D+00 if ( n .eq. 2 ) then return end if do i = 3, n do j = 1, n if ( j .eq. 1 ) then a(i,j) = a(i-1,j+1) / 2.0D+00 else if ( j .eq. 2 ) then a(i,j) = ( 2.0D+00 * a(i-1,j-1) + a(i-1,j+1) ) / 2.0D+00 else if ( j .lt. n ) then a(i,j) = ( a(i-1,j-1) + a(i-1,j+1) ) / 2.0D+00 else a(i,j) = a(i-1,j-1) / 2.0D+00 end if end do end do return end subroutine cheby_u ( n, a ) c*********************************************************************72 c cc CHEBY_U returns the CHEBY_U matrix. c c Discussion c c CHEBY_T is the Chebyshev T matrix, associated with the Chebyshev c "T" polynomials, or Chebyshev polynomials of the first kind. c c Example: c c N = 11 c c 1 . . . . . . . . . . c . 2 . . . . . . . . . c -1 . 4 . . . . . . . . c . -4 . 8 . . . . . . . c 1 . -12 . 16 . . . . . . c . 6 . -32 . 32 . . . . . c -1 . 24 . -80 . 64 . . . . c . -8 . 80 . -192 . 128 . . . c 1 . -40 . 240 . -448 . 256 . . c . 10 . -160 . 672 . -1024 . 512 . c -1 . 60 . -560 . 1792 . -2304 . 1024 c c Properties: c c A is generally not symmetric: A' /= A. c c A is integral, therefore det ( A ) is integral, and c det ( A ) * inverse ( A ) is integral. c c A is generally not normal: A' * A /= A * A'. c c A is lower triangular. c c A is reducible. c c The entries of row N sum to N. c c det ( A ) = 2^((N*(N-1))/2). c c LAMBDA(I) = 2^(I-1) c c The family of matrices is nested as a function of N. c c Licensing: c c This code is distributed under the GNU LGPL license. c c Modified: c c 20 August 2008 c c Author: c c John Burkardt c c Parameters: c c Input, integer N, the order of the matrix. c c Output, double precision A(N,N), the matrix. c implicit none integer n double precision a(n,n) integer i integer j if ( n .le. 0 ) then return end if do j = 1, n do i = 1, n a(i,j) = 0.0D+00 end do end do a(1,1) = 1.0D+00 if ( n .eq. 1 ) then return end if a(2,2) = 2.0D+00 if ( n .eq. 2 ) then return end if do i = 3, n do j = 1, n if ( j .eq. 1 ) then a(i,j) = - a(i-2,j) else a(i,j) = 2.0D+00 * a(i-1,j-1) - a(i-2,j) end if end do end do return end subroutine cheby_u_determinant ( n, determ ) c*********************************************************************72 c cc CHEBY_U_DETERMINANT returns the determinant of the CHEBY_U matrix. c c Licensing: c c This code is distributed under the GNU LGPL license. c c Modified: c c 20 August 2008 c c Author: c c John Burkardt c c Parameters: c c Input, integer N, the order of the matrix. c c Output, double precision DETERM, the determinant. c implicit none double precision determ integer n integer power power = ( n * ( n - 1 ) ) / 2 determ = dble ( 2 ** power ) return end subroutine cheby_u_eigenvalues ( n, lambda ) c*********************************************************************72 c cc CHEBY_U_EIGENVALUES returns the eigenvalues of the CHEBY_U matrix. c c Licensing: c c This code is distributed under the GNU LGPL license. c c Modified: c c 20 August 2008 c c Author: c c John Burkardt c c Parameters: c c Input, integer N, the order of the matrix. c c Output, double precision LAMBDA(N), the eigenvalues. c implicit none integer n integer i double precision lambda(n) do i = 1, n lambda(i) = 2.0D+00* * ( i - 1 ) end do return end subroutine cheby_u_inverse ( n, a ) c*********************************************************************72 c cc CHEBY_U_INVERSE returns the inverse of the CHEBY_U matrix. c c Example: c c N = 11 c c 1 . . . . . . . . . . c . 1 . . . . . . . . . / 2 c 1 . 1 . . . . . . . . / 4 c . 2 . 1 . . . . . . . / 8 c 2 . 3 . 1 . . . . . . / 16 c . 5 . 4 . 1 . . . . . / 32 c 5 . 9 . 5 . 1 . . . . / 64 c . 14 . 14 . 6 . 1 . . . / 128 c 14 . 28 . 20 . 7 . 1 . . / 256 c . 42 . 48 . 27 . 8 . 1 . / 512 c 42 . 90 . 75 . 35 . 9 . 1 / 1024 c c Licensing: c c This code is distributed under the GNU LGPL license. c c Modified: c c 20 August 2008 c c Author: c c John Burkardt c c Parameters: c c Input, integer N, the order of the matrix. c c Output, double precision A(N,N), the matrix. c implicit none integer n double precision a(n,n) integer i integer j if ( n .le. 0 ) then return end if do j = 1, n do i = 1, n a(i,j) = 0.0D+00 end do end do a(1,1) = 1.0D+00 if ( n .eq. 1 ) then return end if a(2,2) = 0.5D+00 if ( n .eq. 2 ) then return end if do i = 3, n do j = 1, n if ( j .eq. 1 ) then a(i,j) = a(i-1,j+1) / 2.0D+00 else if ( j .lt. n ) then a(i,j) = ( a(i-1,j-1) + a(i-1,j+1) ) / 2.0D+00 else a(i,j) = a(i-1,j-1) / 2.0D+00 end if end do end do return end subroutine cheby_u_polynomial ( n, x, cx ) c*********************************************************************72 c cc CHEBY_U_POLYNOMIAL evaluates the Chebyshev polynomials of the second kind. c c Differential equation: c c (1-X*X) Y'' - 3 X Y' + N (N+2) Y = 0 c c Formula: c c If |X| <= 1, then c c U(N)(X) = sin ( (N+1) * arccos(X) ) / sqrt ( 1 - X^2 ) c = sin ( (N+1) * arccos(X) ) / sin ( arccos(X) ) c c else c c U(N)(X) = sinh ( (N+1) * arccosh(X) ) / sinh ( arccosh(X) ) c c First terms: c c U(0)(X) = 1 c U(1)(X) = 2 X c U(2)(X) = 4 X^2 - 1 c U(3)(X) = 8 X^3 - 4 X c U(4)(X) = 16 X^4 - 12 X^2 + 1 c U(5)(X) = 32 X^5 - 32 X^3 + 6 X c U(6)(X) = 64 X^6 - 80 X^4 + 24 X^2 - 1 c U(7)(X) = 128 X^7 - 192 X^5 + 80 X^3 - 8X c c Orthogonality: c c For integration over [-1,1] with weight c c W(X) = sqrt(1-X*X), c c we have c c < U(I)(X), U(J)(X) > = integral ( -1 <= X <= 1 ) W(X) U(I)(X) U(J)(X) dX c c then the result is: c c < U(I)(X), U(J)(X) > = 0 if I /= J c < U(I)(X), U(J)(X) > = PI/2 if I .EQ. J c c Recursion: c c U(0)(X) = 1, c U(1)(X) = 2 * X, c U(N)(X) = 2 * X * U(N-1)(X) - U(N-2)(X) c c Special values: c c U(N)(1) = N + 1 c U(2N)(0) = (-1)^N c U(2N+1)(0) = 0 c U(N)(X) = (-1)^N * U(N)(-X) c c Zeroes: c c M-th zero of U(N)(X) is X = cos( M*PI/(N+1)), M = 1 to N c c Extrema: c c M-th extremum of U(N)(X) is X = cos( M*PI/N), M = 0 to N c c Norm: c c Integral ( -1 <= X <= 1 ) ( 1 - X^2 ) * U(N)(X)^2 dX = PI/2 c c Licensing: c c This code is distributed under the GNU LGPL license. c c Modified: c c 14 August 2008 c c Author: c c John Burkardt c c Reference: c c Milton Abramowitz, Irene Stegun, c Handbook of Mathematical Functions, c National Bureau of Standards, 1964, c ISBN: 0-486-61272-4, c LC: QA47.A34. c c Parameters: c c Input, integer N, the highest polynomial to compute. c c Input, double precision X, the point at which the polynomials c are to be computed. c c Output, double precision CX(0:N), the values of the N+1 Chebyshev c polynomials. c implicit none integer n double precision cx(0:n) integer i double precision x if ( n .lt. 0 ) then return end if cx(0) = 1.0D+00 if ( n .lt. 1 ) then return end if cx(1) = 2.0D+00 * x do i = 2, n cx(i) = 2.0D+00 * x * cx(i-1) - cx(i-2) end do return end subroutine cheby_van1 ( m, a, b, n, x, v ) c*********************************************************************72 c cc CHEBY_VAN1 returns the CHEBY_VAN1 matrix. c c Discussion: c c Normally, the Chebyshev polynomials are defined on -1 <= XI <= +1. c Here, we assume the Chebyshev polynomials have been defined on the c interval A <= X <= B, using the mapping c XI = ( - ( B - X ) + ( X - A ) ) / ( B - A ) c so that c ChebyAB(A,B;X) = Cheby(XI). c c if ( I .eq. 1 ) then c V(1,1:N) = 1; c elseif ( I .eq. 2 ) then c V(2,1:N) = XI(1:N); c else c V(I,1:N) = 2.0 * XI(1:N) * V(I-1,1:N) - V(I-2,1:N); c c Example: c c M = 5, A = -1, B = +1, N = 5, X = ( 1, 2, 3, 4, 5 ) c c 1 1 1 1 1 c 1 2 3 4 5 c 1 7 17 31 49 c 1 26 99 244 485 c 1 97 577 1921 4801 c c Properties: c c V is generally not symmetric: V' /= V. c c V(I,J) = T(I-1) ( X(J) ) where T(I-1) is a Chebyshev polynomial. c c V will be singular if the X values are not distinct. c c Licensing: c c This code is distributed under the GNU LGPL license. c c Modified: c c 10 April 2014 c c Author: c c John Burkardt c c Reference: c c Nicholas Higham, c Stability analysis of algorithms for solving confluent c Vandermonde-like systems, c SIAM Journal on Matrix Analysis and Applications, c Volume 11, 1990, pages 23-41. c c Parameters: c c Input, integer M, the number of rows of the matrix. c c Input, double precision A, B, the interval. c c Input, integer N, the number of columns of the matrix. c c Input, double precision X(N), the vector that defines the matrix. c c Output, double precision V(M,N), the matrix. c implicit none integer m integer n double precision a double precision b integer i integer j double precision v(m,n) double precision x(n) double precision xi do j = 1, n xi = ( - 1.0D+00 * ( b - x(j) ) & + 1.0D+00 * ( x(j) - a ) ) & / ( b - a ) do i = 1, m if ( i .eq. 1 ) then v(i,j) = 1.0D+00 else if ( i .eq. 2 ) then v(i,j) = xi else v(i,j) = 2.0D+00 * xi * v(i-1,j) - v(i-2,j) end if end do end do return end subroutine cheby_van2 ( n, a ) c*********************************************************************72 c cc CHEBY_VAN2 returns the CHEBY_VAN2 matrix. c c Discussion: c c The formula for this matrix has been slightly modified, by a scaling c factor, in order to make it closer to its inverse. c c A(I,J) = ( 1 / sqrt ( N - 1 ) ) * cos ( (I-1) * (J-1) * PI / (N-1) ) c c Example: c c N = 4 c c 1 1 1 1 c 1/sqrt(3) * 1 COS(PI/3) COS(2*PI/3) COS(3*PI/3) c 1 COS(2*PI/3) COS(4*PI/3) COS(6*PI/3) c 1 COS(3*PI/3) COS(6*PI/3) COS(9*PI/3) c c or, in decimal, c c 0.5774 0.5774 0.5774 0.5774 c 0.5774 0.2887 -0.2887 -0.5774 c 0.5774 -0.2887 -0.2887 0.5774 c 0.5774 -0.5774 0.5774 -0.5774 c c Properties: c c A is symmetric: A' = A. c c Because A is symmetric, it is normal. c c Because A is normal, it is diagonalizable. c c The entries of A are based on the extrema of the Chebyshev c polynomial T(n-1). c c Licensing: c c This code is distributed under the GNU LGPL license. c c Modified: c c 21 August 2008 c c Author: c c John Burkardt c c Parameters: c c Input, integer N, the order of the matrix. c c Output, double precision A(N,N), the matrix. c implicit none integer n double precision a(n,n) double precision angle integer i integer j double precision r8_pi parameter ( r8_pi = 3.141592653589793D+00 ) if ( n .eq. 1 ) then a(1,1) = 1.0D+00 return end if do j = 1, n do i = 1, n angle = dble ( ( i - 1 ) * ( j - 1 ) ) * r8_pi & / dble ( n - 1 ) a(i,j) = cos ( angle ) end do end do do j = 1, n do i = 1, n a(i,j) = a(i,j) / sqrt ( dble ( n - 1 ) ) end do end do return end subroutine cheby_van2_determinant ( n, determ ) c*********************************************************************72 c cc CHEBY_VAN2_DETERMINANT returns the determinant of the CHEBY_VAN2 matrix. c c Licensing: c c This code is distributed under the GNU LGPL license. c c Modified: c c 21 August 2008 c c Author: c c John Burkardt c c Parameters: c c Input, integer N, the order of the matrix. c c Output, double precision DETERM, the determinant. c implicit none double precision determ integer n double precision r8_mop if ( n .le. 0 ) then determ = 0.0D+00 else if ( n .eq. 1 ) then determ = 1.0D+00 else determ = r8_mop ( n / 2 ) * sqrt ( 2.0D+00 ) ** ( 4 - n ) end if return end subroutine cheby_van2_inverse ( n, a ) c*********************************************************************72 c cc CHEBY_VAN2_INVERSE returns the inverse of the CHEBY_VAN2 matrix. c c Discussion: c c if ( I .eq. 1 or N ) .and. ( J .eq. 1 or N ) then c A(I,J) = ( 1 / (2*sqrt(N-1)) ) * cos ( (I-1) * (J-1) * PI / (N-1) ) c else if ( I .eq. 1 or N ) .or. ( J .eq. 1 or N ) then c A(I,J) = ( 1 / ( sqrt(N-1)) ) * cos ( (I-1) * (J-1) * PI / (N-1) ) c else c A(I,J) = ( 2 / sqrt(N-1) ) * cos ( (I-1) * (J-1) * PI / (N-1) ) c c c Example: c c N = 4 c c 1/2 1 1 1/2 c 1/sqrt(3) * 1 2*COS(PI/3) 2*COS(2*PI/3) COS(3*PI/3) c 1 2*COS(2*PI/3) 2*COS(4*PI/3) COS(6*PI/3) c 1/2 COS(3*PI/3) COS(6*PI/3) 1/2 * COS(9*PI/3) c c Properties: c c A is symmetric: A' = A. c c Because A is symmetric, it is normal. c c Because A is normal, it is diagonalizable. c c The entries of A are based on the extrema of the Chebyshev c polynomial T(n-1). c c Licensing: c c This code is distributed under the GNU LGPL license. c c Modified: c c 21 August 2008 c c Author: c c John Burkardt c c Parameters: c c Input, integer N, the order of the matrix. c c Output, double precision A(N,N), the matrix. c implicit none integer n double precision a(n,n) double precision angle integer i integer j double precision r8_pi parameter ( r8_pi = 3.141592653589793D+00 ) if ( n .eq. 1 ) then a(1,1) = 1.0 return end if do j = 1, n do i = 1, n angle = dble ( ( i - 1 ) * ( j - 1 ) ) * r8_pi & / dble ( n - 1 ) a(i,j) = cos ( angle ) end do end do do j = 1, n do i = 1, n a(i,j) = 2.0D+00 * a(i,j) / sqrt ( dble ( n - 1 ) ) end do end do do j = 1, n a(1,j) = 0.5D+00 * a(1,j) a(n,j) = 0.5D+00 * a(n,j) end do do i = 1, n a(i,1) = 0.5D+00 * a(i,1) a(i,n) = 0.5D+00 * a(i,n) end do return end subroutine cheby_van3 ( n, a ) c*********************************************************************72 c cc CHEBY_VAN3 returns the CHEBY_VAN3 matrix. c c Discussion: c c A(I,J) = cos ( (I-1) * (J-1/2) * PI / N ) c c Example: c c N = 4 c c 1 1 1 1 c COS( PI/8) COS(3*PI/8) COS( 5*PI/8) COS( 7*PI/8) c COS(2*PI/8) COS(6*PI/8) COS(10*PI/8) COS(14*PI/8) c COS(3*PI/8) COS(9*PI/8) COS(15*PI/8) COS(21*PI/8) c c Properties: c c A is generally not symmetric: A' /= A. c c A is "almost" orthogonal. A * A' = a diagonal matrix. c c The entries of A are based on the zeros of the Chebyshev polynomial T(n). c c Licensing: c c This code is distributed under the GNU LGPL license. c c Modified: c c 21 August 2008 c c Author: c c John Burkardt c c Parameters: c c Input, integer N, the order of the matrix. c c Output, double precision A(N,N), the matrix. c implicit none integer n double precision a(n,n) double precision angle integer i integer j double precision r8_pi parameter ( r8_pi = 3.141592653589793D+00 ) do j = 1, n do i = 1, n angle = dble ( ( i - 1 ) * ( 2 * j - 1 ) ) * r8_pi & / dble ( 2 * n ) a(i,j) = cos ( angle ) end do end do return end subroutine cheby_van3_determinant ( n, determ ) c*********************************************************************72 c cc CHEBY_VAN3_DETERMINANT returns the determinant of the CHEBY_VAN3 matrix. c c Licensing: c c This code is distributed under the GNU LGPL license. c c Modified: c c 21 August 2008 c c Author: c c John Burkardt c c Parameters: c c Input, integer N, the order of the matrix. c c Output, double precision DETERM, the determinant. c implicit none integer n double precision determ double precision r8_mop determ = r8_mop ( n + 1 ) * sqrt ( dble ( n ** n ) ) & / sqrt ( 2.0D+00 ** ( n - 1 ) ) return end subroutine cheby_van3_inverse ( n, a ) c*********************************************************************72 c cc CHEBY_VAN3_INVERSE returns the inverse of the CHEBY_VAN3 matrix. c c Discussion: c c if J .eq. 1 then c A(I,J) = (1/N) * cos ( (I-1/2) * (J-1) * PI / N ) c else if 1 < J then c A(I,J) = (2/N) * cos ( (I-1/2) * (J-1) * PI / N ) c c Example: c c N = 4 c c 1/4 1/2 cos( PI/8) 1/2 cos( 2*PI/8) 1/2 cos( 3*PI/8) c 1/4 1/2 cos(3*PI/8) 1/2 cos( 6*PI/8) 1/2 cos( 9*PI/8) c 1/4 1/2 cos(5*PI/8) 1/2 cos(10*PI/8) 1/2 cos(15*PI/8) c 1/4 1/2 cos(7*PI/8) 1/2 cos(14*PI/8) 1/2 cos(21*PI/8) c c Licensing: c c This code is distributed under the GNU LGPL license. c c Modified: c c 21 August 2008 c c Author: c c John Burkardt c c Parameters: c c Input, integer N, the order of the matrix. c c Output, double precision A(N,N), the matrix. c implicit none integer n double precision a(n,n) double precision angle integer i integer j double precision r8_pi parameter ( r8_pi = 3.141592653589793D+00 ) do j = 1, n do i = 1, n angle = dble ( ( 2 * i - 1 ) * ( j - 1 ) ) * r8_pi & / dble ( 2 * n ) a(i,j) = cos ( angle ) / dble ( n ) end do end do do j = 2, n do i = 1, n a(i,j) = 2.0D+00 * a(i,j) end do end do return end subroutine chow ( alpha, beta, m, n, a ) c*********************************************************************72 c cc CHOW returns the CHOW matrix. c c Discussion: c c By making ALPHA small compared with BETA, the eigenvalues can c all be made very close to BETA, and this is useful as a test c of eigenvalue computing routines. c c Formula: c c if ( I = J ) c A(I,J) = ALPHA + BETA c else if ( J <= I + 1 ) then c A(I,J) = ALPHA^(I+1-J) c else c A(I,J) = 0 c c Example: c c ALPHA = 2, BETA = 3, M = 5, N = 5 c c 5 1 0 0 0 c 4 5 1 0 0 c 8 4 5 1 0 c 16 8 4 5 1 c 32 16 8 4 5 c c ALPHA = ALPHA, BETA = BETA, M = 5, N = 5 c c ALPHA+BETA 1 0 0 0 c ALPHA^2 ALPHA+BETA 1 0 0 c ALPHA^3 ALPHA^2 ALPHA+BETA 1 0 c ALPHA^4 ALPHA^3 ALPHA^2 ALPHA+BETA 1 c ALPHA^5 ALPHA^4 ALPHA^3 ALPHA^2 ALPHA+BETA c c Properties: c c A is Toeplitz: constant along diagonals. c c A is lower Hessenberg. c c A is generally not symmetric: A' /= A. c c If ALPHA is 0.0, then A is singular if and only if BETA is 0.0. c c If BETA is 0.0, then A will be singular if 1 < N. c c If BETA is 0.0 and N = 1, then A will be singular if ALPHA is 0.0. c c A is persymmetric: A(I,J) = A(N+1-J,N+1-I). c c For 1 <= I < N-(N+1)/2, c c LAMBDA(I) = BETA + 4 * ALPHA * cos ( i * pi / ( N+2 ) )^2, c c For N-(N+1)/2+1 <= I <= N c c LAMBDA(I) = BETA c c The family of matrices is nested as a function of N. c c Licensing: c c This code is distributed under the GNU LGPL license. c c Modified: c c 23 August 2008 c c Author: c c John Burkardt c c Reference: c c TS Chow, c A class of Hessenberg matrices with known eigenvalues and inverses, c SIAM Review, c Volume 11, Number 3, 1969, pages 391-395. c c Graeme Fairweather, c On the eigenvalues and eigenvectors of a class of Hessenberg matrices, c SIAM Review, c Volume 13, Number 2, 1971, pages 220-221. c c Parameters: c c Input, double precision ALPHA, the ALPHA value. A typical value is 1.0. c c Input, double precision BETA, the BETA value. A typical value is 0.0. c c Input, integer M, N, the order of the matrix. c c Output, double precision A(M,N), the matrix. c implicit none integer m integer n double precision a(m,n) double precision alpha double precision beta integer i integer j do j = 1, n do i = 1, m if ( i .eq. j - 1 ) then a(i,j) = 1.0D+00 else if ( i .eq. j ) then a(i,j) = alpha + beta else if ( j + 1 .le. i ) then a(i,j) = alpha ** ( i + 1 - j ) else a(i,j) = 0.0D+00 end if end do end do return end subroutine chow_determinant ( alpha, beta, n, determ ) c*********************************************************************72 c cc CHOW_DETERMINANT returns the determinant of the CHOW matrix. c c Licensing: c c This code is distributed under the GNU LGPL license. c c Modified: c c 23 August 2008 c c Author: c c John Burkardt c c Parameters: c c Input, double precision ALPHA, the ALPHA value. A typical value is 1.0. c c Input, double precision BETA, the BETA value. A typical value is 0.0. c c Input, integer N, the order of the matrix. c c Output, double precision DETERM, the determinant. c implicit none integer n double precision alpha double precision angle double precision beta double precision determ integer i integer k double precision r8_pi parameter ( r8_pi = 3.141592653589793D+00 ) determ = 1.0D+00 k = n - ( n / 2 ) do i = 1, k angle = dble ( i ) * r8_pi / dble ( n + 2 ) determ = determ & * ( beta + 4.0D+00 * alpha * ( cos ( angle ) ) ** 2 ) end do determ = determ * beta ** ( n - k ) return end subroutine chow_eigenvalues ( alpha, beta, n, lambda ) c*********************************************************************72 c cc CHOW_EIGENVALUES returns the eigenvalues of the CHOW matrix. c c Example: c c ALPHA = 2, BETA = 3, N = 5 c c 9.49395943 c 6.10991621 c 3.0 c 3.0 c 3.0 c c Licensing: c c This code is distributed under the GNU LGPL license. c c Modified: c c 24 August 2008 c c Author: c c John Burkardt c c Parameters: c c Input, double precision ALPHA, the ALPHA value. A typical value is 1.0. c c Input, double precision BETA, the BETA value. A typical value is 0.0. c c Input, integer N, the order of the matrix. c c Output, double precision LAMBDA(N), the eigenvalues of A. c implicit none integer n double precision alpha double precision angle double precision beta integer i integer k double precision lambda(n) double precision r8_pi parameter ( r8_pi = 3.141592653589793D+00 ) k = n - ( n + 1 ) / 2 do i = 1, k angle = dble ( i ) * r8_pi / dble ( n + 2 ) lambda(i) = beta + 4.0D+00 * alpha * ( cos ( angle ) ) ** 2 end do do i = k + 1, n lambda(i) = beta end do return end subroutine chow_inverse ( alpha, beta, n, a ) c*********************************************************************72 c cc CHOW_INVERSE returns the inverse of the CHOW matrix. c c Licensing: c c This code is distributed under the GNU LGPL license. c c Modified: c c 24 August 2008 c c Author: c c John Burkardt c c Parameters: c c Input, double precision ALPHA, the ALPHA value. A typical value is 1.0. c c Input, double precision BETA, the BETA value. A typical value is 0.0. c c Input, integer N, the order of the matrix. c c Output, double precision A(N,N), the matrix. c implicit none integer n double precision a(n,n) double precision alpha double precision beta double precision d(0:n) double precision dp(-1:n) integer i integer j double precision r8_mop do j = 1, n do i = 1, n a(i,j) = 0.0D+00 end do end do if ( 0.0D+00 .eq. alpha .and. beta .eq. 0.0D+00 ) then write ( *, '(a)' ) ' ' write ( *, '(a)' ) 'CHOW_INVERSE - Fatal error!' write ( *, '(a)' ) ' The Chow matrix is not invertible,' write ( *, '(a)' ) ' because ALPHA = 0 and BETA = 0.' stop 1 else if ( 0.0D+00 .eq. alpha .and. beta .ne. 0.0D+00 ) then do j = 1, n do i = 1, n if ( i .le. j ) then a(i,j) = r8_mop ( j - i ) / beta ** ( j + 1 - i ) else a(i,j) = 0.0D+00 end if end do end do return else if ( 0.0D+00 .ne. alpha .and. beta .eq. 0.0D+00 ) then if ( 1 .lt. n ) then write ( *, '(a)' ) ' ' write ( *, '(a)' ) 'CHOW_INVERSE - Fatal error!' write ( *, '(a)' ) ' The Chow matrix is not invertible,' write ( *, '(a)' ) ' because BETA = 0 and 1 .lt. N.' stop 1 end if a(1,1) = 1.0D+00 / alpha return end if d(0) = 1.0D+00 d(1) = beta do i = 2, n d(i) = beta * d(i-1) + alpha * beta * d(i-2) end do dp(-1) = 1.0D+00 / beta dp(0) = 1.0D+00 dp(1) = alpha + beta do i = 2, n dp(i) = d(i) + alpha * d(i-1) end do do i = 1, n do j = 1, i - 1 a(i,j) = - alpha * ( alpha * beta ) ** ( i - j ) & * dp(j-2) * d(n-i) / dp(n) end do do j = i, n a(i,j) = r8_mop ( i + j ) * dp(i-1) * d(n+1-j) & / ( beta * dp(n) ) end do end do return end subroutine chow_eigen_left ( alpha, beta, n, v ) c*********************************************************************72 c cc CHOW_EIGEN_LEFT returns the left eigenvectors for the CHOW matrix. c c Licensing: c c This code is distributed under the GNU LGPL license. c c Modified: c c 24 August 2008 c c Author: c c John Burkardt c c Parameters: c c Input, double precision ALPHA, the ALPHA value. A typical value is 1.0. c c Input, double precision BETA, the BETA value. A typical value is 0.0. c c Input, integer N, the order of the matrix. c c Output, double precision V(N,N), the left eigenvector matrix. c implicit none integer n double precision alpha double precision angle double precision beta integer i integer j integer k double precision r8_pi parameter ( r8_pi = 3.141592653589793D+00 ) double precision v(n,n) k = n - ( n + 1 ) / 2 do i = 1, k angle = dble ( i ) * r8_pi / dble ( n + 2 ) do j = 1, n v(i,j) = alpha ** ( n - j ) * 2.0D+00 ** ( n - j - 1 ) & * ( cos ( angle ) ) ** ( n - j + 1 ) & * sin ( dble ( n - j + 2 ) * angle ) / sin ( angle ) end do end do do i = k+1, n do j = 1, n - 2 v(i,j) = 0.0D+00 end do v(i,n-1) = -alpha v(i,n) = 1.0D+00 end do return end subroutine chow_eigen_right ( alpha, beta, n, u ) c*********************************************************************72 c cc CHOW_EIGEN_RIGHT returns right eigenvectors for the CHOW matrix. c c Licensing: c c This code is distributed under the GNU LGPL license. c c Modified: c c 24 August 2008 c c Author: c c John Burkardt c c Parameters: c c Input, double precision ALPHA, the ALPHA value. A typical value is 1.0. c c Input, double precision BETA, the BETA value. A typical value is 0.0. c c Input, integer N, the order of the matrix. c c Output, double precision U(N,N), the right eigenvector matrix. c implicit none integer n double precision alpha double precision angle double precision beta integer i integer j integer k double precision r8_pi parameter ( r8_pi = 3.141592653589793D+00 ) double precision u(n,n) k = n - ( n + 1 ) / 2 do j = 1, k angle = dble ( j ) * r8_pi / dble ( n + 2 ) do i = 1, n u(i,j) = alpha ** ( i - 1 ) * 2.0D+00 ** ( i - 2 ) & * ( cos ( angle ) ) ** ( i - 2 ) & * sin ( dble ( i + 1 ) * angle ) / sin ( angle ) end do end do do j = k+1, n u(1,j) = 1.0D+00 u(2,j) = -alpha do i = 3, n u(i,j) = 0.0D+00 end do end do return end subroutine circulant ( m, n, x, a ) c*********************************************************************72 c cc CIRCULANT returns the CIRCULANT matrix. c c Formula: c c K = 1 + mod ( J-I, N ) c A(I,J) = X(K) c c Example: c c M = 4, N = 4, X = ( 1, 2, 3, 4 ) c c 1 2 3 4 c 4 1 2 3 c 3 4 1 2 c 2 3 4 1 c c M = 4, N = 5, X = ( 1, 2, 3, 4, 5 ) c c 1 2 3 4 5 c 5 1 2 3 4 c 4 5 1 2 3 c 3 4 5 1 2 c c M = 5, N = 4, X = ( 1, 2, 3, 4 ) c c 1 2 3 4 c 5 1 2 3 c 4 5 1 2 c 3 4 5 1 c 1 2 3 4 c c Discussion: c c Westlake lists the following "special" circulants: c c B2, X = ( T^2, 1, 2, ..., T, T+1, T, T-1, ..., 1 ), c with T = ( N - 2 ) / 2; c c B3, X = ( N+1, 1, 1, ..., 1 ); c c B5, X = ( 1, 2, 3, ..., N ). c c Properties: c c The product of two circulant matrices is a circulant matrix. c c The transpose of a circulant matrix is a circulant matrix. c c A circulant matrix C, whose first row is (c1, c2, ..., cn), can be c written as a polynomial in the upshift matrix U: c c C = c1 * I + c2 * U + c3 * U^2 + ... + cn * U^n-1. c c A is a circulant: each row is shifted once to get the next row. c c A is generally not symmetric: A' /= A. c c A is Toeplitz: constant along diagonals. c c A is persymmetric: A(I,J) = A(N+1-J,N+1-I). c c A commutes with any other circulant matrix. c c A is normal. c c The transpose of A is also a circulant matrix. c c A has constant row sums. c c Because A has constant row sums, c it has an eigenvalue with this value, c and a right eigenvector of ( 1, 1, 1, ..., 1 ). c c A has constant column sums. c c Because A has constant column sums, c it has an eigenvalue with this value, c and a left eigenvector of ( 1, 1, 1, ..., 1 ). c c The inverse of A is also a circulant matrix. c c The Fourier matrix is the eigenvector matrix for every circulant matrix. c c Because the Fourier matrix F diagonalizes A, the inverse (or c pseudoinverse, if any LAMBDA is zero) can be written c c inverse ( A ) = (F*) * 1/LAMBDA * F c c A is symmetric if, for all I, X(I+1) = X(N-I+1). c c If R is an N-th root of unity, that is, R is a complex number such c that R^N = 1, then c c Y = X(1) + X(2)*R + X(3)*R^2 + ... + X(N)*R^(N-1) c c is an eigenvalue of A, with eigenvector c c ( 1, R, R^2, ..., R^(N-1) ) c c and left eigenvector c c ( R^(N-1), R^(N-2), ..., R^2, R, 1 ). c c Although there are exactly N distinct roots of unity, the circulant c may have repeated eigenvalues, because of the behavior of the polynomial. c However, the matrix is guaranteed to have N linearly independent c eigenvectors. c c Licensing: c c This code is distributed under the GNU LGPL license. c c Modified: c c 30 August 2008 c c Author: c c John Burkardt c c Reference: c c Philip Davis, c Circulant Matrices, c Second Edition, c Chelsea, 1994, c ISBN13: 978-0828403384, c LC: QA188.D37. c c Robert Gregory, David Karney, c A Collection of Matrices for Testing Computational Algorithms, c Wiley, 1969, c ISBN: 0882756494, c LC: QA263.G68. c c Joan Westlake, c A Handbook of Numerical Matrix Inversion and Solution of c Linear Equations, c John Wiley, 1968, c ISBN13: 978-0471936756, c LC: QA263.W47. c c Parameters: c c Input, integer M, N, the order of the matrix. c c Input, double precision X(N), the values in the first row of A. c c Output, double precision A(M,N), the matrix. c implicit none integer m integer n double precision a(m,n) integer i integer i4_modp integer j integer k double precision x(n) do j = 1, n do i = 1, m k = 1 + i4_modp ( j - i, n ) a(i,j) = x(k) end do end do return end subroutine circulant_determinant ( n, x, determ ) c*********************************************************************72 c cc CIRCULANT_DETERMINANT returns the determinant of the CIRCULANT matrix. c c Discussion: c c If the FORTRAN77 compiler won't let us create automatic arrays for c LAMBDA and W, we have to define an N_MAX and allocate them c explicitly. Maybe GFORTRAN will let us do this, at least. c c Licensing: c c This code is distributed under the GNU LGPL license. c c Modified: c c 31 August 2008 c c Author: c c John Burkardt c c Parameters: c c Input, integer N, the order of the matrix. c c Input, double precision X(N), the values in the first row of A. c c Output, double precision DETERM, the determinant. c implicit none integer n double precision determ integer i integer j double complex lambda(n) double complex w(n) double precision x(n) call c8vec_unity ( n, w ) do i = 1, n lambda(i) = dcmplx ( x(n), 0.0D+00 ) end do do i = n-1, 1, -1 do j = 1, n lambda(j) = lambda(j) * w(j) + dcmplx ( x(i), 0.0D+00 ) end do end do c c First eigenvalue is "special". c determ = dreal ( lambda(1) ) c c Eigenvalues 2, 3, through ( N + 1 ) / 2 are paired with complex conjugates. c do i = 2, ( n + 1 ) / 2 determ = determ * ( abs ( lambda(i) ) ) ** 2 end do c c If N is even, there is another unpaired eigenvalue. c if ( mod ( n, 2 ) .eq. 0 ) then determ = determ * dreal ( lambda((n/2)+1) ) end if return end subroutine circulant_eigenvalues ( n, x, lambda ) c*********************************************************************72 c cc CIRCULANT_EIGENVALUES returns the eigenvalues of the CIRCULANT matrix. c c Licensing: c c This code is distributed under the GNU LGPL license. c c Modified: c c 12 March 2001 c c Author: c c John Burkardt c c Parameters: c c Input, integer N, the order of the matrix. c c Input, double precision X(N), the values in the first row of A. c c Output, double complex LAMBDA(N), the eigenvalues. c implicit none integer n integer i integer j double complex lambda(n) double complex w(n) double precision x(n) call c8vec_unity ( n, w ) do j = 1, n lambda(j) = dcmplx ( x(n), 0.0D+00 ) end do do i = n-1, 1, -1 do j = 1, n lambda(j) = lambda(j) * w(j) + dcmplx ( x(i), 0.0 ) end do end do return end subroutine circulant2 ( n, a ) c*********************************************************************72 c cc CIRCULANT2 returns the CIRCULANT2 matrix. c c Formula: c c K = 1 + mod ( J-I, N ) c A(I,J) = K c c Example: c c N = 5 c c 1 2 3 4 5 c 5 1 2 3 4 c 4 5 1 2 3 c 3 4 5 1 2 c 2 3 4 5 1 c c Properties: c c A is generally not symmetric: A' /= A. c c A is a circulant: each row is shifted once to get the next row. c c A is Toeplitz: constant along diagonals. c c A is persymmetric: A(I,J) = A(N+1-J,N+1-I). c c A commutes with any other circulant. c c A is normal. c c The inverse of A is a circulant matrix. c c The eigenvector matrix is the Fourier matrix. c c A has constant row sums. c c Because A has constant row sums, c it has an eigenvalue with this value, c and a right eigenvector of ( 1, 1, 1, ..., 1 ). c c A has constant column sums. c c Because A has constant column sums, c it has an eigenvalue with this value, c and a left eigenvector of ( 1, 1, 1, ..., 1 ). c c If R is an N-th root of unity, that is, R is a complex number such c that R^N = 1, then c c Y = 1 + 2*R + 3*R^2 + ... + N*R^(N-1) c c is an eigenvalue of A, with eigenvector c c ( 1, R, R^2, ..., R^(N-1) ) c c and left eigenvector c c ( R^(N-1), R^(N-2), ..., R^2, R, 1 ). c c Although there are exactly N distinct roots of unity, the circulant c may have repeated eigenvalues, because of the behavior of the polynomial. c However, the matrix is guaranteed to have N linearly independent c eigenvectors. c c Licensing: c c This code is distributed under the GNU LGPL license. c c Modified: c c 09 June 2011 c c Author: c c John Burkardt c c Reference: c c Philip Davis, c Circulant Matrices, c Second Edition, c Chelsea, 1994, c ISBN13: 978-0828403384, c LC: QA188.D37. c c Robert Gregory, David Karney, c A Collection of Matrices for Testing Computational Algorithms, c Wiley, 1969, c ISBN: 0882756494, c LC: QA263.68 c c Morris Newman, John Todd, c The evaluation of matrix inversion programs, c Journal of the Society for Industrial and Applied Mathematics, c Volume 6, Number 4, pages 466-476, 1958. c c Joan Westlake, c A Handbook of Numerical Matrix Inversion and Solution of c Linear Equations, c John Wiley, 1968, c ISBN13: 978-0471936756, c LC: QA263.W47. c c Parameters: c c Input, integer N, the order of the matrix. c c Output, double precision A(N,N), the matrix. c implicit none integer n double precision a(n,n) integer i integer i4_modp integer j integer k do j = 1, n do i = 1, n k = 1 + i4_modp ( j - i, n ) a(i,j) = dble ( k ) end do end do return end subroutine circulant2_determinant ( n, determ ) c*********************************************************************72 c cc CIRCULANT2_DETERMINANT returns the determinant of the CIRCULANT2 matrix. c c Licensing: c c This code is distributed under the GNU LGPL license. c c Modified: c c 11 June 2011 c c Author: c c John Burkardt c c Parameters: c c Input, integer N, the order of the matrix. c c Output, double precision DETERM, the determinant. c implicit none integer n double precision determ integer i integer j double complex lambda(n) double complex w(n) call c8vec_unity ( n, w ) lambda(1:n) = dcmplx ( n ) do i = n - 1, 1, -1 do j = 1, n lambda(j) = lambda(j) * w(j) + dcmplx ( i ) end do end do c c First eigenvalue is "special". c determ = dreal ( lambda(1) ) c c Eigenvalues 2, 3 through ( N + 1 ) / 2 are paired with complex conjugates. c do i = 2, ( n + 1 ) / 2 determ = determ * ( abs ( lambda(i) ) ) ** 2 end do c c If N is even, there is another unpaired eigenvalue. c if ( mod ( n, 2 ) .eq. 0 ) then determ = determ * dreal ( lambda((n/2)+1) ) end if return end subroutine circulant2_eigenvalues ( n, lambda ) c*********************************************************************72 c cc CIRCULANT2_EIGENVALUES returns the eigenvalues of the CIRCULANT2 matrix. c c Licensing: c c This code is distributed under the GNU LGPL license. c c Modified: c c 11 June 2011 c c Author: c c John Burkardt c c Parameters: c c Input, integer N, the order of the matrix. c c Output, double complex LAMBDA(N), the eigenvalues. c implicit none integer n integer i integer j double complex lambda(n) double complex w(n) call c8vec_unity ( n, w ) do i = 1, n lambda(i) = dcmplx ( n ) end do do i = n - 1, 1, -1 do j = 1, n lambda(j) = lambda(j) * w(j) + dcmplx ( i ) end do end do return end subroutine circulant2_inverse ( n, a ) c*********************************************************************72 c cc CIRCULANT2_INVERSE returns the inverse of the CIRCULANT2 matrix. c c Discussion: c c The Moore Penrose generalized inverse is computed, so even if c the circulant is singular, this routine returns a usable result. c c Licensing: c c This code is distributed under the GNU LGPL license. c c Modified: c c 11 June 2011 c c Author: c c John Burkardt c c Parameters: c c Input, integer N, the order of the matrix. c c Output, double precision A(N,N), the matrix. c implicit none integer n double precision a(n,n) double complex b(n,n) double complex c8_zero double complex f(n,n) integer i integer i1 integer j integer j1 double complex lambda(n) call circulant2_eigenvalues ( n, lambda ) do j = 1, n do i = 1, n b(i,j) = 0.0D+00 end do end do do i = 1, n if ( lambda(i) .ne. 0.0D+00 ) then b(i,i) = 1.0D+00 / dconjg ( lambda(i) ) end if end do call fourier ( n, f ) do j = 1, n do i = 1, n a(i,j) = 0.0D+00 do i1 = 1, n do j1 = 1, n a(i,j) = a(i,j) & + dreal ( dconjg ( f(i1,i) ) * b(i1,j1) * f(j1,j) ) end do end do end do end do return end subroutine clement1 ( n, a ) c**********************************************************************72 c cc CLEMENT1 returns the CLEMENT1 matrix. c c Formula: c c if ( J = I + 1 ) c A(I,J) = sqrt(I*(N-I)) c else if ( I = J + 1 ) c A(I,J) = sqrt(J*(N-J)) c else c A(I,J) = 0 c c Example: c c N = 5 c c . sqrt(4) . . . c sqrt(4) . sqrt(6) . . c . sqrt(6) . sqrt(6) . c . . sqrt(6) . sqrt(4) c . . . sqrt(4) . c c Properties: c c A is tridiagonal. c c A is banded, with bandwidth 3. c c Because A is tridiagonal, it has property A (bipartite). c c A is symmetric: A' = A. c c Because A is symmetric, it is normal. c c Because A is normal, it is diagonalizable. c c A is persymmetric: A(I,J) = A(N+1-J,N+1-I). c c The diagonal of A is zero. c c A is singular if N is odd. c c About 64 percent of the entries of the inverse of A are zero. c c The eigenvalues are plus and minus the numbers c c N-1, N-3, N-5, ..., (1 or 0). c c If N is even, c c det ( A ) = (-1)^(N/2) * (N-1) * (N+1)^(N/2) c c and if N is odd, c c det ( A ) = 0 c c Licensing: c c This code is distributed under the GNU LGPL license. c c Modified: c c 13 June 2011 c c Author: c c John Burkardt c c Reference: c c Paul Clement, c A class of triple-diagonal matrices for test purposes, c SIAM Review, c Volume 1, 1959, pages 50-52. c c Parameters: c c Input, integer N, the order of the matrix. c c Output, double precision A(N,N), the matrix. c implicit none integer n double precision a(n,n) integer i integer j do j = 1, n do i = 1, n if ( j .eq. i + 1 ) then a(i,j) = sqrt ( dble ( i * ( n - i ) ) ) else if ( i .eq. j + 1 ) then a(i,j) = sqrt ( dble ( j * ( n - j ) ) ) else a(i,j) = 0.0D+00 end if end do end do return end subroutine clement1_determinant ( n, determ ) c**********************************************************************72 c cc CLEMENT1_DETERMINANT returns the determinant of the CLEMENT1 matrix. c c Licensing: c c This code is distributed under the GNU LGPL license. c c Modified: c c 13 June 2011 c c Author: c c John Burkardt c c Parameters: c c Input, integer N, the order of the matrix. c c Output, double precision DETERM, the determinant. c implicit none double precision determ integer i integer n if ( mod ( n, 2 ) .eq. 1 ) then determ = 0.0D+00 else determ = 1.0D+00 do i = 1, n - 1, 2 determ = determ * dble ( i * ( n - i ) ) end do if ( mod ( n / 2, 2 ) .eq. 1 ) then determ = - determ end if end if return end subroutine clement1_eigenvalues ( n, lambda ) c**********************************************************************72 c cc CLEMENT1_EIGENVALUES returns the eigenvalues of the CLEMENT1 matrix. c c Licensing: c c This code is distributed under the GNU LGPL license. c c Modified: c c 13 June 2011 c c Author: c c John Burkardt c c Parameters: c c Input, integer N, the order of the matrix. c c Output, double precision LAMBDA(N), the eigenvalues. c implicit none integer n integer i double precision lambda(n) do i = 1, n lambda(i) = dble ( - n - 1 + 2 * i ) end do return end subroutine clement1_inverse ( n, a ) c**********************************************************************72 c cc CLEMENT1_INVERSE returns the inverse of the CLEMENT1 matrix. c c Licensing: c c This code is distributed under the GNU LGPL license. c c Modified: c c 22 May 2002 c c Author: c c John Burkardt c c Parameters: c c Input, integer N, the order of the matrix. N must not be oddc c c Output, double precision A(N,N), the matrix. c implicit none integer n double precision a(n,n) integer i integer j double precision prod if ( mod ( n, 2 ) .eq. 1 ) then write ( *, '(a)' ) ' ' write ( *, '(a)' ) 'CLEMENT1_INVERSE - Fatal error!' write ( *, '(a)' ) ' The Clement matrix is singular for odd N.' stop 1 end if do j = 1, n do i = 1, n a(i,j) = 0.0D+00 end do end do do i = 1, n if ( mod ( i, 2 ) .eq. 1 ) then do j = i, n - 1, 2 if ( j .eq. i ) then prod = 1.0D+00 / sqrt ( dble ( j * ( n - j ) ) ) else prod = - prod & * sqrt ( dble ( ( j - 1 ) * ( n + 1 - j ) ) ) & / sqrt ( dble ( j * ( n - j ) ) ) end if a(i,j+1) = prod a(j+1,i) = prod end do end if end do return end subroutine clement2 ( n, x, y, a ) c**********************************************************************72 c cc CLEMENT2 returns the CLEMENT2 matrix. c c Formula: c c if ( J = I + 1 ) then c A(I,J) = X(I) c else if ( I = J + 1 ) then c A(I,J) = Y(J) c else c A(I,J) = 0 c c Example: c c N = 5, X and Y arbitrary: c c . X(1) . . . c Y(1) . X(2) . . c . Y(2) . X(3) . c . . Y(3) . X(4) c . . . Y(4) . c c N = 5, X=(1,2,3,4), Y=(5,6,7,8): c c . 1 . . . c 5 . 2 . . c . 6 . 3 . c . . 7 . 4 c . . . 8 . c c Properties: c c A is generally not symmetric: A' /= A. c c A is tridiagonal. c c Because A is tridiagonal, it has property A (bipartite). c c A is banded, with bandwidth 3. c c The diagonal of A is zero. c c A is singular if N is odd. c c About 64 percent of the entries of the inverse of A are zero. c c If N is even, c c det ( A ) = (-1)^(N/2) * product ( 1 <= I <= N/2 ) c ( X(2*I-1) * Y(2*I-1) ) c c and if N is odd, c c det ( A ) = 0. c c The family of matrices is nested as a function of N. c c Licensing: c c This code is distributed under the GNU LGPL license. c c Modified: c c 13 June 2011 c c Author: c c John Burkardt c c Reference: c c Paul Clement, c A class of triple-diagonal matrices for test purposes, c SIAM Review, c Volume 1, 1959, pages 50-52. c c Alan Edelman, Eric Kostlan, c The road from Kac's matrix to Kac's random polynomials. c In Proceedings of the Fifth SIAM Conference on Applied Linear Algebra, c edited by John Lewis, c SIAM, 1994, pages 503-507. c c Robert Gregory, David Karney, c A Collection of Matrices for Testing Computational Algorithms, c Wiley, 1969, c ISBN: 0882756494, c LC: QA263.68 c c Olga Taussky, John Todd, c Another look at a matrix of Mark Kac, c Linear Algebra and Applications, c Volume 150, 1991, pages 341-360. c c Parameters: c c Input, integer N, the order of the matrix. c c Input, double precision X(N-1), Y(N-1), the first super and c subdiagonals of the matrix A. c c Output, double precision A(N,N), the matrix. c implicit none integer n double precision a(n,n) integer i integer j double precision x(n-1) double precision y(n-1) do j = 1, n do i = 1, n if ( j .eq. i + 1 ) then a(i,j) = x(i) else if ( i .eq. j + 1 ) then a(i,j) = y(j) else a(i,j) = 0.0D+00 end if end do end do return end subroutine clement2_determinant ( n, x, y, determ ) c**********************************************************************72 c cc CLEMENT2_DETERMINANT returns the determinant of the CLEMENT2 matrix. c c Licensing: c c This code is distributed under the GNU LGPL license. c c Modified: c c 21 May 2002 c c Author: c c John Burkardt c c Parameters: c c Input, integer N, the order of the matrix. c c Input, double precision X(N-1), Y(N-1), the first super and c subdiagonals of the matrix A. c c Output, double precision DETERM, the determinant of A. c implicit none integer n double precision determ integer i double precision x(n-1) double precision y(n-1) if ( mod ( n, 2 ) .eq. 1 ) then determ = 0.0D+00 else determ = 1.0D+00 do i = 1, n - 1, 2 determ = determ * x(i) * y(i) end do if ( mod ( n / 2, 2 ) .eq. 1 ) then determ = -determ end if end if return end subroutine clement2_inverse ( n, x, y, a ) c**********************************************************************72 c cc CLEMENT2_INVERSE returns the inverse of the CLEMENT2 matrix. c c Example: c c N = 6, X and Y arbitrary: c c 0 1/Y1 0 -X2/(Y1*Y3) 0 X2*X4/(Y1*Y3*Y5) c 1/X1 0 0 0 0 0 c 0 0 0 1/Y3 0 -X4/(Y3*Y5) c -Y2/(X1*X3) 0 1/X3 0 0 0 c 0 0 0 0 0 1/Y5 c Y2*Y4/(X1*X3*X5) 0 -Y4/(X3*X5) 0 1/X5 0 c c Licensing: c c This code is distributed under the GNU LGPL license. c c Modified: c c 13 June 2011 c c Author: c c John Burkardt c c Reference: c c Paul Clement, c A class of triple-diagonal matrices for test purposes, c SIAM Review, c Volume 1, 1959, pages 50-52. c c Parameters: c c Input, integer N, the order of the matrix. N must not be oddc c c Input, double precision X(N-1), Y(N-1), the first super and c subdiagonals of the matrix A. None of the entries c of X or Y may be zero. c c Output, double precision A(N,N), the matrix. c implicit none integer n double precision a(n,n) integer i integer j double precision prod1 double precision prod2 double precision x(n-1) double precision y(n-1) if ( mod ( n, 2 ) .eq. 1 ) then write ( *, '(a)' ) ' ' write ( *, '(a)' ) 'CLEMENT2_INVERSE - Fatal error!' write ( *, '(a)' ) ' The Clement matrix is singular for odd N.' stop 1 end if do i = 1, n - 1 if ( x(i) .eq. 0.0D+00 ) then write ( *, '(a)' ) ' ' write ( *, '(a)' ) 'CLEMENT2_INVERSE - Fatal error!' write ( *, '(a)' ) ' The matrix is singular' write ( *, '(a,i8)' ) ' X(I) = 0 for I = ', i stop 1 else if ( y(i) .eq. 0.0D+00 ) then write ( *, '(a)' ) ' ' write ( *, '(a)' ) 'CLEMENT2_INVERSE - Fatal error!' write ( *, '(a)' ) ' The matrix is singular' write ( *, '(a,i8)' ) ' Y(I) = 0 for I = ', i stop 1 end if end do do j = 1, n do i = 1, n a(i,j) = 0.0D+00 end do end do do i = 1, n if ( mod ( i, 2 ) .eq. 1 ) then do j = i, n - 1, 2 if ( j .eq. i ) then prod1 = 1.0D+00 / y(j) prod2 = 1.0D+00 / x(j) else prod1 = - prod1 * x(j-1) / y(j) prod2 = - prod2 * y(j-1) / x(j) end if a(i,j+1) = prod1 a(j+1,i) = prod2 end do end if end do return end subroutine colleague ( n, c, a ) c*********************************************************************72 c cc COLLEAGUE returns the COLLEAGUE matrix. c c Discussion: c c The colleague matrix is an analog of the companion matrix, adapted c for use with polynomials represented by a sum of Chebyshev polynomials. c c Let the N-th degree polynomial be defined by c c P(X) = C(N)*T_N(X) + C(N-1)*T_(N-1)(X) + ... + C(1)*T1(X) + C(0)*T0(X) c c where T_I(X) is the I-th Chebyshev polynomial. c c Then the roots of P(X) are the eigenvalues of the colleague matrix A(C): c c 0 1 0 ... 0 0 0 0 ... 0 c 1/2 0 1/2 ... 0 0 0 0 ... 0 c 0 1/2 0 ... 0 - 1/(2*C(N)) * 0 0 0 ... 0 c ... ... ... ... ... ... ... ... ... ... c ... ... ... 0 1/2 ... ... ... ... 0 c ... ... ... 1/2 0 C(0) C(1) C(2) ... C(N-1) c c Licensing: c c This code is distributed under the GNU LGPL license. c c Modified: c c 09 March 2015 c c Author: c c John Burkardt c c Reference: c c I J Good, c The Colleague Matrix: A Chebyshev Analogue of the Companion Matrix, c The Quarterly Journal of Mathematics, c Volume 12, Number 1, 1961, pages 61-68. c c Parameters: c c Input, integer N, the order of the matrix. c c Input, double precision C(0:N), the coefficients of the polynomial. c C(N) should not be zero! c c Output, double precision A(N,N), the matrix. c implicit none integer n double precision a(n,n) double precision c(0:n) integer i integer j do j = 1, n do i = 1, n a(i,j) = 0.0D+00 end do end do if ( n .eq. 1 ) then a(1,1) = - c(0) / c(1) else do i = 1, n do j = 1, n if ( i .eq. 1 ) then if ( j .eq. 2 ) then a(i,j) = 1.0D+00 end if else if ( j .eq. i - 1 .or. j .eq. i + 1 ) then a(i,j) = 0.5D+00 end if end if end do end do do j = 1, n a(n,j) = a(n,j) - 0.5D+00 * c(j-1) / c(n) end do end if return end subroutine combin ( alpha, beta, n, a ) c*********************************************************************72 c cc COMBIN returns the COMBIN matrix. c c Discussion: c c This matrix is known as the combinatorial matrix. c c Formula: c c If ( I = J ) then c A(I,J) = ALPHA + BETA c else c A(I,J) = BETA c c Example: c c N = 5, ALPHA = 2, BETA = 3 c c 5 3 3 3 3 c 3 5 3 3 3 c 3 3 5 3 3 c 3 3 3 5 3 c 3 3 3 3 5 c c Properties: c c A is symmetric: A' = A. c c Because A is symmetric, it is normal. c c Because A is normal, it is diagonalizable. c c A is persymmetric: A(I,J) = A(N+1-J,N+1-I). c c A is a circulant matrix: each row is shifted once to get the next row. c c det ( A ) = ALPHA^(N-1) * ( ALPHA + N * BETA ). c c A has constant row sums. c c Because A has constant row sums, c it has an eigenvalue with this value, c and a right eigenvector of ( 1, 1, 1, ..., 1 ). c c A has constant column sums. c c Because A has constant column sums, c it has an eigenvalue with this value, c and a left eigenvector of ( 1, 1, 1, ..., 1 ). c c LAMBDA(1:N-1) = ALPHA, c LAMBDA(N) = ALPHA + N * BETA. c c The eigenvector associated with LAMBDA(N) is (1,1,1,...,1)/sqrt(N). c c The other N-1 eigenvectors are simply any (orthonormal) basis c for the space perpendicular to (1,1,1,...,1). c c A is nonsingular if ALPHA /= 0 and ALPHA + N * BETA /= 0. c c The family of matrices is nested as a function of N. c c Licensing: c c This code is distributed under the GNU LGPL license. c c Modified: c c 14 June 2011 c c Author: c c John Burkardt c c Reference: c c Robert Gregory, David Karney, c A Collection of Matrices for Testing Computational Algorithms, c Wiley, 1969, c ISBN: 0882756494, c LC: QA263.68 c c Donald Knuth, c The Art of Computer Programming, c Volume 1, Fundamental Algorithms, Second Edition, c Addison-Wesley, Reading, Massachusetts, 1973, page 36. c c Parameters: c c Input, double precision ALPHA, BETA, scalars that define A. c c Input, integer N, the order of the matrix. c c Output, double precision A(N,N), the matrix. c implicit none integer n double precision a(n,n) double precision alpha double precision beta integer i integer j do j = 1, n do i = 1, n a(i,j) = beta end do end do do i = 1, n a(i,i) = a(i,i) + alpha end do return end subroutine combin_condition ( alpha, beta, n, cond ) c*********************************************************************72 c cc COMBIN_CONDITION returns the L1 condition of the COMBIN matrix. c c Licensing: c c This code is distributed under the GNU LGPL license. c c Modified: c c 10 April 2012 c c Author: c c John Burkardt c c Parameters: c c Input, double precision ALPHA, BETA, scalars that define A. c c Input, integer N, the order of the matrix. c c Output, double precision COND, the L1 condition. c implicit none double precision alpha double precision beta double precision cond integer n cond = ( alpha + dble ( 2 * ( n - 1 ) ) * beta ) / alpha return end subroutine combin_determinant ( alpha, beta, n, determ ) c*********************************************************************72 c cc COMBIN_DETERMINANT returns the determinant of the COMBIN matrix. c c Licensing: c c This code is distributed under the GNU LGPL license. c c Modified: c c 14 June 2011 c c Author: c c John Burkardt c c Parameters: c c Input, double precision ALPHA, BETA, scalars that define A. c c Input, integer N, the order of the matrix. c c Output, double precision DETERM, the determinant. c implicit none double precision alpha double precision beta double precision determ integer n determ = alpha ** ( n - 1 ) * ( alpha + dble ( n ) * beta ) return end subroutine combin_eigenvalues ( alpha, beta, n, lambda ) c*********************************************************************72 c cc COMBIN_EIGENVALUES returns the eigenvalues of the COMBIN matrix. c c Licensing: c c This code is distributed under the GNU LGPL license. c c Modified: c c 14 June 2011 c c Author: c c John Burkardt c c Parameters: c c Input, double precision ALPHA, BETA, scalars that define A. c c Input, integer N, the order of the matrix. c c Output, double precision LAMBDA(N), the eigenvalues. c implicit none integer n double precision alpha double precision beta integer i double precision lambda(n) do i = 1, n - 1 lambda(i) = alpha end do lambda(n) = alpha + dble ( n ) * beta return end subroutine combin_inverse ( alpha, beta, n, a ) c*********************************************************************72 c cc COMBIN_INVERSE returns the inverse of the COMBIN matrix. c c Formula: c c if ( I = J ) c A(I,J) = (ALPHA+(N-1)*BETA) / (ALPHA*(ALPHA+N*BETA)) c else c A(I,J) = - BETA / (ALPHA*(ALPHA+N*BETA)) c c Example: c c N = 5, ALPHA = 2, BETA = 3 c c 14 -3 -3 -3 -3 c -3 14 -3 -3 -3 c 1/34 * -3 -3 14 -3 -3 c -3 -3 -3 14 -3 c -3 -3 -3 -3 14 c c Properties: c c A is symmetric: A' = A. c c Because A is symmetric, it is normal. c c Because A is normal, it is diagonalizable. c c A is persymmetric: A(I,J) = A(N+1-J,N+1-I). c c A is a circulant matrix: each row is shifted once to get the next row. c c A is Toeplitz: constant along diagonals. c c det ( A ) = 1 / (ALPHA^(N-1) * (ALPHA+N*BETA)). c c A is well defined if ALPHA /= 0D+00 and ALPHA+N*BETA /= 0. c c Licensing: c c This code is distributed under the GNU LGPL license. c c Modified: c c 14 June 2011 c c Author: c c John Burkardt c c Reference: c c Donald Knuth, c The Art of Computer Programming, c Volume 1, Fundamental Algorithms, Second Edition, c Addison-Wesley, Reading, Massachusetts, 1973, page 36. c c Parameters: c c Input, double precision ALPHA, BETA, scalars that define the matrix. c c Input, integer N, the order of the matrix. c c Output, double precision A(N,N), the matrix. c implicit none integer n double precision a(n,n) double precision alpha double precision beta double precision bot integer i integer j if ( alpha .eq. 0.0D+00 ) then write ( *, '(a)' ) ' ' write ( *, '(a)' ) 'COMBIN_INVERSE - Fatal error!' write ( *, '(a)' ) ' The entries of the matrix are undefined' write ( *, '(a)' ) ' because ALPHA = 0.' stop 1 else if ( alpha + n * beta .eq. 0.0D+00 ) then write ( *, '(a)' ) ' ' write ( *, '(a)' ) 'COMBIN_INVERSE - Fatal error!' write ( *, '(a)' ) ' The entries of the matrix are undefined' write ( *, '(a)' ) ' because ALPHA+N*BETA is zero.' stop 1 end if bot = alpha * ( alpha + dble ( n ) * beta ) do j = 1, n do i = 1, n if ( i .eq. j ) then a(i,j) = ( alpha + dble ( n - 1 ) * beta ) / bot else a(i,j) = - beta / bot end if end do end do return end subroutine combin_eigen_right ( alpha, beta, n, x ) c*********************************************************************72 c cc COMBIN_EIGEN_RIGHT returns right eigenvectors of the COMBIN matrix. c c Licensing: c c This code is distributed under the GNU LGPL license. c c Modified: c c 14 June 2011 c c Author: c c John Burkardt c c Parameters: c c Input, double precision ALPHA, BETA, scalars that define A. c c Input, integer N, the order of the matrix. c c Output, double precision X(N,N), the right eigenvectors. c implicit none integer n double precision alpha double precision beta integer i integer j double precision x(n,n) do j = 1, n do i = 1, n x(i,j) = 0.0D+00 end do end do do j = 1, n - 1 x( 1,j) = +1.0D+00 x(j+1,j) = -1.0D+00 end do j = n do i = 1, n x(i,j) = 1.0D+00 end do return end subroutine companion ( n, x, a ) c*********************************************************************72 c cc COMPANION returns the COMPANION matrix. c c Discussion: c c Let the monic N-th degree polynomial be defined by c c P(t) = t^N + X(N)*t^N-1 + X(N-1)*t^N-1 + ... + X(2)*t + X(1) c c Then c c A(1,J) = X(N+1-J) for J=1 to N c A(I,I-1) = 1 for I=2 to N c A(I,J) = 0 otherwise c c A is called the companion matrix of the polynomial P(t), and the c characteristic equation of A is P(t) = 0. c c Matrices of this form are also called Frobenius matrices. c c The determinant of a matrix is unaffected by being transposed, c and only possibly changes sign if the rows are "reflected", so c there are actually many possible ways to write a companion matrix: c c A B C D A 1 0 0 0 1 0 0 0 0 1 0 0 0 1 A c 1 0 0 0 B 0 1 0 0 0 1 0 0 1 0 0 0 1 0 B c 0 1 0 0 C 0 0 1 0 0 0 1 1 0 0 0 1 0 0 C c 0 0 1 0 D 0 0 0 D C B A A B C D 0 0 0 D c c Example: c c N = 5, X = ( 1, 2, 3, 4, 5 ) c c 5 4 3 2 1 c 1 0 0 0 0 c 0 1 0 0 0 c 0 0 1 0 0 c 0 0 0 1 0 c c Properties: c c A is generally not symmetric: A' /= A. c c A is nonsingular if and only if X(1) is nonzero. c c The eigenvalues of A are the roots of P(t) = 0. c c If LAMBDA is an eigenvalue of A, then a corresponding eigenvector is c ( 1, LAMBDA, LAMBDA^2, ..., LAMBDA^(N-1) ). c c If LAMBDA is an eigenvalue of multiplicity 2, then a second c corresponding generalized eigenvector is c c ( 0, 1, 2 * LAMBDA, ..., (N-1)*LAMBDA^(N-2) ). c c For higher multiplicities, repeatedly differentiate with respect to LAMBDA. c c Any matrix with characteristic polynomial P(t) is similar to A. c c det ( A ) = +/- X(1). c c Licensing: c c This code is distributed under the GNU LGPL license. c c Modified: c c 14 June 2011 c c Author: c c John Burkardt c c Reference: c c Gene Golub, Charles Van Loan, c Matrix Computations, second edition, c Johns Hopkins University Press, Baltimore, Maryland, 1989, c section 7.4.6. c c Charles Kenney, Alan Laub, c Controllability and stability radii for companion form systems, c Math. Control Signals Systems, c Volume 1, 1988, pages 239-256. c c James Wilkinson, c The Algebraic Eigenvalue Problem, c Oxford University Press, c 1965, page 12. c c Parameters: c c Input, integer N, the order of the matrix. c c Input, double precision X(N), the coefficients of the polynomial c which define A. c c Output, double precision A(N,N), the matrix. c implicit none integer n double precision a(n,n) integer i integer j double precision x(n) do j = 1, n do i = 1, n if ( i .eq. 1 ) then a(i,j) = x(n+1-j) else if ( i .eq. j + 1 ) then a(i,j) = 1.0D+00 else a(i,j) = 0.0D+00 end if end do end do return end subroutine companion_condition ( n, x, cond ) c*********************************************************************72 c cc COMPANION_CONDITION returns the L1 condition of the COMPANION matrix. c c Licensing: c c This code is distributed under the GNU LGPL license. c c Modified: c c 22 January 2015 c c Author: c c John Burkardt c c Parameters: c c Input, integer N, the order of the matrix. c c Input, double precision X(N), the coefficients of the polynomial c which define A. c c Output, double precision COND, the L1 condition. c implicit none integer n double precision a_norm double precision b_norm double precision cond integer i double precision x(n) a_norm = abs ( x(1) ) do i = 2, n a_norm = max ( a_norm, 1.0D+00 + abs ( x(i) ) ) end do b_norm = 1.0D+00 / abs ( x(1) ) do i = 2, n b_norm = max ( b_norm, 1.0D+00 + abs ( x(i) ) / abs ( x(1) ) ) end do cond = a_norm * b_norm return end subroutine companion_determinant ( n, x, determ ) c*********************************************************************72 c cc COMPANION_DETERMINANT returns the determinant of the COMPANION matrix. c c Licensing: c c This code is distributed under the GNU LGPL license. c c Modified: c c 14 June 2011 c c Author: c c John Burkardt c c Parameters: c c Input, integer N, the order of the matrix. c c Input, double precision X(N), the coefficients of the polynomial c which define A. c c Output, double precision DETERM, the determinant. c implicit none integer n double precision determ double precision x(n) if ( mod ( n, 2 ) .eq. 1 ) then determ = + x(1) else determ = - x(1) end if return end subroutine companion_inverse ( n, x, a ) c*********************************************************************72 c cc COMPANION_INVERSE returns the inverse of the COMPANION matrix. c c Example: c c N = 5, X = ( 1, 2, 3, 4, 5 ) c c 0 1 0 0 0 c 0 0 1 0 0 c 0 0 0 1 0 c 0 0 0 0 1 c 1/1 -5/1 -4/1 -3/1 -2/1 c c Licensing: c c This code is distributed under the GNU LGPL license. c c Modified: c c 14 June 2011 c c Author: c c John Burkardt c c Reference: c c Gene Golub, Charles Van Loan, c Matrix Computations, second edition, c Johns Hopkins University Press, Baltimore, Maryland, 1989, c section 7.4.6. c c Charles Kenney, Alan Laub, c Controllability and stability radii for companion form systems, c Math. Control Signals Systems, c Volume 1, 1988, pages 239-256. c c James Wilkinson, c The Algebraic Eigenvalue Problem, c Oxford University Press, c 1965, page 12. c c Parameters: c c Input, integer N, the order of the matrix. c c Input, double precision X(N), the coefficients of the polynomial c which define the matrix. X(1) must not be zero. c c Output, double precision A(N,N), the matrix. c implicit none integer n double precision a(n,n) integer i integer j double precision x(n) do j = 1, n do i = 1, n if ( i .eq. n ) then if ( j .eq. 1 ) then a(i,j) = 1.0D+00 / x(1) else a(i,j) = - x(n+2-j) / x(1) end if else if ( i .eq. j - 1 ) then a(i,j) = 1.0D+00 else a(i,j) = 0.0D+00 end if end do end do return end subroutine complete_symmetric_poly ( n, r, x, value ) c*********************************************************************72 c cc COMPLETE_SYMMETRIC_POLY evaluates a complete symmetric polynomial. c c Discussion: c c N\R 0 1 2 3 c +-------------------------------------------------------- c 0 | 1 0 0 0 c 1 | 1 X1 X1^2 X1^3 c 2 | 1 X1+X2 X1^2+X1X2+X2^2 X1^3+X1^2X2+X1X2^2+X2^3 c 3 | 1 X1+X2+X3 ... c c If X = ( 1, 2, 3, 4, 5, ... ) then c c N\R 0 1 2 3 4 ... c +-------------------------------------------------------- c 0 | 1 0 0 0 0 c 1 | 1 1 1 1 1 c 2 | 1 3 7 15 31 c 3 | 1 6 25 90 301 c 4 | 1 10 65 350 1701 c 5 | 1 15 140 1050 6951 c c Licensing: c c This code is distributed under the GNU LGPL license. c c Modified: c c 04 November 2013 c c Author: c c John Burkardt c c Parameters: c c Input, integer N, the number of variables. c 0 <= N. c c Input, integer R, the degree of the polynomial. c 0 <= R. c c Input, double precision X(N), the value of the variables. c c Output, double precision VALUE, the value of TAU(N,R)(X). c implicit none integer n integer r integer i integer nn integer rr double precision tau(0:max(n,r)) double precision value double precision x(n) if ( n .lt. 0 ) then write ( *, '(a)' ) '' write ( *, '(a)' ) 'COMPLETE_SYMMETRIC_POLY - Fatal error!' write ( *, '(a)' ) ' N < 0.' stop 1 end if if ( r .lt. 0 ) then write ( *, '(a)' ) '' write ( *, '(a)' ) 'COMPLETE_SYMMETRIC_POLY - Fatal error!' write ( *, '(a)' ) ' R < 0.' stop 1 end if do i = 0, max ( n, r ) tau(i) = 0.0D+00 end do tau(0) = 1.0D+00 do nn = 1, n do rr = 1, r tau(rr) = tau(rr) + x(nn) * tau(rr-1) end do end do value = tau(r) return end subroutine complex3 ( a ) c*********************************************************************72 c cc COMPLEX3 returns the COMPLEX3 matrix. c c Formula: c c 1 1 + 2i 2 + 10i c 1 + i 3i -5 + 14i c 1 + i 5i -8 + 20i c c Properties: c c A is complex. c c A is complex integral. c c Licensing: c c This code is distributed under the GNU LGPL license. c c Modified: c c 14 June 2011 c c Author: c c John Burkardt c c Reference: c c Joan Westlake, c A Handbook of Numerical Matrix Inversion and Solution of c Linear Equations, c John Wiley, 1968, c ISBN13: 978-0471936756, c LC: QA263.W47. c c Parameters: c c Output, double complex A(3,3), the matrix. c implicit none double complex a(3,3) a(1,1) = dcmplx ( 1.0D+00, 0.0D+00 ) a(2,1) = dcmplx ( 1.0D+00, 1.0D+00 ) a(3,1) = dcmplx ( 1.0D+00, 1.0D+00 ) a(1,2) = dcmplx ( 1.0D+00, 2.0D+00 ) a(2,2) = dcmplx ( 0.0D+00, 3.0D+00 ) a(3,2) = dcmplx ( 0.0D+00, 5.0D+00 ) a(1,3) = dcmplx ( 2.0D+00, 10.0D+00 ) a(2,3) = dcmplx ( -5.0D+00, 14.0D+00 ) a(3,3) = dcmplx ( -8.0D+00, 20.0D+00 ) return end subroutine complex3_inverse ( a ) c*********************************************************************72 c cc COMPLEX3_INVERSE returns the inverse of the COMPLEX3 matrix. c c Formula: c c 10 + i -2 + 6i -3 - 2i c 9 - 3i 8i -3 - 2i c -2 + 2i -1 - 2i 1 c c Licensing: c c This code is distributed under the GNU LGPL license. c c Modified: c c 14 June 2011 c c Author: c c John Burkardt c c Reference: c c Joan Westlake, c A Handbook of Numerical Matrix Inversion and Solution of c Linear Equations, c John Wiley, 1968, c ISBN13: 978-0471936756, c LC: QA263.W47. c c Parameters: c c Output, double complex A(3,3), the matrix. c implicit none double complex a(3,3) a(1,1) = dcmplx ( 10.0D+00, 1.0D+00 ) a(2,1) = dcmplx ( 9.0D+00, -3.0D+00 ) a(3,1) = dcmplx ( -2.0D+00, 2.0D+00 ) a(1,2) = dcmplx ( -2.0D+00, 6.0D+00 ) a(2,2) = dcmplx ( 0.0D+00, 8.0D+00 ) a(3,2) = dcmplx ( -1.0D+00, -2.0D+00 ) a(1,3) = dcmplx ( -3.0D+00, -2.0D+00 ) a(2,3) = dcmplx ( -3.0D+00, -2.0D+00 ) a(3,3) = dcmplx ( 1.0D+00, 0.0D+00 ) return end subroutine complex_i ( a ) c*********************************************************************72 c cc COMPLEX_I returns the COMPLEX_I matrix. c c Discussion: c c This is a real matrix, that has some properties similar to the c imaginary unit. c c Formula: c c 0 1 c -1 0 c c Properties: c c A is integral, therefore det ( A ) is integral, and c det ( A ) * inverse ( A ) is integral. c c A is anti-involutional: A * A = - I c c A * A * A * A = I c c Licensing: c c This code is distributed under the GNU LGPL license. c c Modified: c c 14 June 2011 c c Author: c c John Burkardt c c Parameters: c c Output, double precision A(2,2), the matrix. c implicit none double precision a(2,2) a(1,1) = 0.0D+00 a(1,2) = 1.0D+00 a(2,1) = -1.0D+00 a(2,2) = 0.0D+00 return end subroutine complex_i_determinant ( determ ) c*********************************************************************72 c cc COMPLEX_I_DETERMINANT returns the determinant of the COMPLEX_I matrix. c c Licensing: c c This code is distributed under the GNU LGPL license. c c Modified: c c 14 June 2011 c c Author: c c John Burkardt c c Parameters: c c Output, double precision DETERM, the determinant. c implicit none double precision determ determ = + 1.0D+00 return end subroutine complex_i_inverse ( a ) c*********************************************************************72 c cc COMPLEX_I_INVERSE returns the inverse of the COMPLEX_I matrix. c c Licensing: c c This code is distributed under the GNU LGPL license. c c Modified: c c 14 June 2011 c c Author: c c John Burkardt c c Parameters: c c Output, double precision A(2,2), the matrix. c implicit none double precision a(2,2) a(1,1) = 0.0D+00 a(1,2) = -1.0D+00 a(2,1) = 1.0D+00 a(2,2) = 0.0D+00 return end subroutine conex1 ( alpha, a ) c*********************************************************************72 c cc CONEX1 returns the CONEX1 matrix. c c Discussion: c c The CONEX1 matrix is a counterexample to the LINPACK condition c number estimator RCOND available in the LINPACK routine DGECO. c c Formula: c c 1 -1 -2*ALPHA 0 c 0 1 ALPHA -ALPHA c 0 1 1+ALPHA -1-ALPHA c 0 0 0 ALPHA c c Example: c c ALPHA = 100 c c 1 -1 -200 0 c 0 1 100 -100 c 0 1 101 -101 c 0 0 0 100 c c Properties: c c A is generally not symmetric: A' /= A. c c Licensing: c c This code is distributed under the GNU LGPL license. c c Modified: c c 19 June 2011 c c Author: c c John Burkardt c c Reference: c c Alan Cline, RK Rew, c A set of counterexamples to three condition number estimators, c SIAM Journal on Scientific and Statistical Computing, c Volume 4, 1983, pages 602-611. c c Parameters: c c Input, double precision ALPHA, the scalar defining A. c A common value is 100.0. c c Output, double precision A(4,4), the matrix. c implicit none double precision a(4,4) double precision alpha a(1,1) = 1.0D+00 a(2,1) = 0.0D+00 a(3,1) = 0.0D+00 a(4,1) = 0.0D+00 a(1,2) = -1.0D+00 a(2,2) = 1.0D+00 a(3,2) = 1.0D+00 a(4,2) = 0.0D+00 a(1,3) = -2.0D+00 * alpha a(2,3) = alpha a(3,3) = 1.0D+00 + alpha a(4,3) = 0.0D+00 a(1,4) = 0.0D+00 a(2,4) = -alpha a(3,4) = -1.0D+00 - alpha a(4,4) = alpha return end subroutine conex1_condition ( alpha, cond ) c*********************************************************************72 c cc CONEX1_CONDITION returns the L1 condition of the CONEX1 matrix. c c Licensing: c c This code is distributed under the GNU LGPL license. c c Modified: c c 05 February 2015 c c Author: c c John Burkardt c c Parameters: c c Input, double precision ALPHA, the scalar defining A. c c Output, double precision COND, the L1 condition. c implicit none double precision a_norm double precision alpha double precision b_norm double precision cond double precision v1 double precision v2 double precision v3 a_norm = max ( 3.0D+00, & 3.0D+00 * abs ( alpha ) + abs ( 1.0D+00 + alpha ) ) v1 = abs ( 1.0D+00 - alpha ) + abs ( 1.0D+00 + alpha ) + 1.0D+00 v2 = 2.0D+00 * abs ( alpha ) + 1.0D+00 v3 = 2.0D+00 + 2.0D+00 / abs ( alpha ) b_norm = max ( v1, max ( v2, v3 ) ) cond = a_norm * b_norm; return end subroutine conex1_determinant ( alpha, determ ) c*********************************************************************72 c cc CONEX1_DETERMINANT returns the determinant of the CONEX1 matrix. c c Licensing: c c This code is distributed under the GNU LGPL license. c c Modified: c c 19 June 2011 c c Author: c c John Burkardt c c Parameters: c c Input, double precision ALPHA, the scalar defining A. c c Output, double precision DETERM, the determinant. c implicit none double precision alpha double precision determ determ = alpha return end subroutine conex1_inverse ( alpha, a ) c*********************************************************************72 c cc CONEX1_INVERSE returns the inverse of the CONEX1 matrix. c c Licensing: c c This code is distributed under the GNU LGPL license. c c Modified: c c 19 June 2011 c c Author: c c John Burkardt c c Parameters: c c Input, double precision ALPHA, the scalar defining A. c c Output, double precision A(4,4), the matrix. c implicit none double precision a(4,4) double precision alpha a(1,1) = 1.0D+00 a(1,2) = 1.0D+00 - alpha a(1,3) = alpha a(1,4) = 2.0D+00 a(2,1) = 0.0D+00 a(2,2) = 1.0D+00 + alpha a(2,3) = - alpha a(2,4) = 0.0D+00 a(3,1) = 0.0D+00 a(3,2) = -1.0D+00 a(3,3) = 1.0D+00 a(3,4) = 1.0D+00 / alpha a(4,1) = 0.0D+00 a(4,2) = 0.0D+00 a(4,3) = 0.0D+00 a(4,4) = 1.0D+00 / alpha return end subroutine conex2 ( alpha, a ) c*********************************************************************72 c cc CONEX2 returns the CONEX2 matrix. c c Formula: c c 1 1-1/ALPHA^2 -2 c 0 1/ALPHA -1/ALPHA c 0 0 1 c c Example: c c ALPHA = 100 c c 1 0.9999 -2 c 0 0.01 -0.01 c 0 0 1 c c Properties: c c A is generally not symmetric: A' /= A. c c A is upper triangular. c c det ( A ) = 1 / ALPHA. c c LAMBDA = ( 1, 1/ALPHA, 1 ) c c Licensing: c c This code is distributed under the GNU LGPL license. c c Modified: c c 19 June 2011 c c Author: c c John Burkardt c c Reference: c c Alan Cline, RK Rew, c A set of counterexamples to three condition number estimators, c SIAM Journal on Scientific and Statistical Computing, c Volume 4, 1983, pages 602-611. c c Parameters: c c Input, double precision ALPHA, the scalar defining A. c A common value is 100.0. ALPHA must not be zero. c c Output, double precision A(3,3), the matrix. c implicit none double precision a(3,3) double precision alpha if ( alpha .eq. 0.0D+00 ) then write ( *, '(a)' ) ' ' write ( *, '(a)' ) 'CONEX2 - Fatal error!' write ( *, '(a)' ) ' The input value of ALPHA was zero.' stop 1 end if a(1,1) = 1.0D+00 a(1,2) = ( alpha ** 2 - 1.0D+00 ) / alpha ** 2 a(1,3) = -2.0D+00 a(2,1) = 0.0D+00 a(2,2) = 1.0D+00 / alpha a(2,3) = -1.0D+00 / alpha a(3,1) = 0.0D+00 a(3,2) = 0.0D+00 a(3,3) = 1.0D+00 return end subroutine conex2_condition ( alpha, cond ) c*********************************************************************72 c cc CONEX2_CONDITION returns the L1 condition of the CONEX2 matrix. c c Licensing: c c This code is distributed under the GNU LGPL license. c c Modified: c c 05 February 2015 c c Author: c c John Burkardt c c Parameters: c c Input, double precision ALPHA, the scalar defining A. c c Output, double precision COND, the L1 condition. c implicit none double precision alpha double precision a_norm double precision b_norm double precision c1 double precision c2 double precision c3 double precision cond c1 = 1.0D+00 c2 = abs ( 1.0D+00 - 1.0D+00 / alpha ** 2 ) & + 1.0D+00 / abs ( alpha ) c3 = 3.0D+00 + 1.0D+00 / abs ( alpha ) a_norm = max ( c1, max ( c2, c3 ) ) c1 = 1.0D+00 c2 = abs ( ( 1.0D+00 - alpha * alpha ) / alpha ) + abs ( alpha ) c3 = abs ( ( 1.0D+00 + alpha * alpha ) / alpha ** 2 ) + 2.0D+00 b_norm = max ( c1, max ( c2, c3 ) ) cond = a_norm * b_norm return end subroutine conex2_determinant ( alpha, determ ) c*********************************************************************72 c cc CONEX2_DETERMINANT returns the determinant of the CONEX2 matrix. c c Licensing: c c This code is distributed under the GNU LGPL license. c c Modified: c c 19 June 2011 c c Author: c c John Burkardt c c Parameters: c c Input, double precision ALPHA, the scalar defining A. c c Output, double precision DETERM, the determinant. c implicit none double precision alpha double precision determ determ = 1.0D+00 / alpha return end subroutine conex2_inverse ( alpha, a ) c*********************************************************************72 c cc CONEX2_INVERSE returns the inverse of the CONEX2 matrix. c c Licensing: c c This code is distributed under the GNU LGPL license. c c Modified: c c 19 June 2011 c c Author: c c John Burkardt c c Parameters: c c Input, double precision ALPHA, the scalar defining A. c A common value is 100.0. ALPHA must not be zero. c c Output, double precision A(3,3), the matrix. c implicit none double precision a(3,3) double precision alpha if ( alpha .eq. 0.0D+00 ) then write ( *, '(a)' ) ' ' write ( *, '(a)' ) 'CONEX2_INVERSE - Fatal error!' write ( *, '(a)' ) ' The input value of ALPHA was zero.' stop 1 end if a(1,1) = 1.0D+00 a(1,2) = ( 1.0D+00 - alpha ** 2 ) / alpha a(1,3) = ( 1.0D+00 + alpha ** 2 ) / alpha ** 2 a(2,1) = 0.0D+00 a(2,2) = alpha a(2,3) = 1.0D+00 a(3,1) = 0.0D+00 a(3,2) = 0.0D+00 a(3,3) = 1.0D+00 return end subroutine conex3 ( n, a ) c*********************************************************************72 c cc CONEX3 returns the CONEX3 matrix. c c Formula: c c if ( I = J and I < N ) c A(I,J) = 1.0D+00 for 1<=I A * Q. c do k = 1, n t1 = b(i,k) t2 = b(j,k) b(i,k) = t1 * c - t2 * s b(j,k) = t1 * s + t2 * c end do c c A -> Q' * A c do k = 1, n t1 = b(k,i) t2 = b(k,j) b(k,i) = c * t1 - s * t2 b(k,j) = s * t1 + c * t2 end do c c X -> Q' * X c do k = 1, n t1 = x(k,i) t2 = x(k,j) x(k,i) = c * t1 - s * t2 x(k,j) = s * t1 + c * t2 end do end if end do end do c c Test the size of the off-diagonal elements. c sum2 = 0.0D+00 do i = 1, n do j = 1, i - 1 sum2 = sum2 + abs ( b(i,j) ) end do end do if ( sum2 .le. eps * ( norm_fro + 1.0D+00 ) ) then exit end if end do call r8mat_diag_get_vector ( n, b, lambda ) return end subroutine jacobi_symbol ( q, p, j ) c*********************************************************************72 c cc JACOBI_SYMBOL evaluates the Jacobi symbol (Q/P). c c Discussion: c c If P is prime, then c c Jacobi Symbol (Q/P) = Legendre Symbol (Q/P) c c Else c c let P have the prime factorization c c P = Product ( 1 <= I <= N ) P(I)^E(I) c c Jacobi Symbol (Q/P) = c c Product ( 1 <= I <= N ) Legendre Symbol (Q/P(I))^E(I) c c Licensing: c c This code is distributed under the GNU LGPL license. c c Modified: c c 11 July 2008 c c Author: c c John Burkardt c c Reference: c c Daniel Zwillinger, c CRC Standard Mathematical Tables and Formulae, c 30th Edition, c CRC Press, 1996, pages 86-87. c c Parameters: c c Input, integer Q, an integer whose Jacobi symbol with c respect to P is desired. c c Input, integer P, the number with respect to which the Jacobi c symbol of Q is desired. P should be 2 or greater. c c Output, integer J, the Jacobi symbol (Q/P). c Ordinarily, J will be -1, 0 or 1. c -2, not enough factorization space. c -3, an error during Legendre symbol calculation. c implicit none integer maxfactor parameter ( maxfactor = 20 ) integer factor(maxfactor) integer i integer j integer l integer nfactor integer nleft integer p integer power(maxfactor) integer pp integer q integer qq c c P must be greater than 1. c if ( p .le. 1 ) then write ( *, '(a)' ) ' ' write ( *, '(a)' ) 'JACOBI_SYMBOL - Fatal error!' write ( *, '(a)' ) ' P must be greater than 1.' l = -2 return end if c c Decompose P into factors of prime powers. c call i4_factor ( p, maxfactor, nfactor, factor, power, nleft ) if ( nleft .ne. 1 ) then write ( *, '(a)' ) ' ' write ( *, '(a)' ) 'JACOBI_SYMBOL - Fatal error!' write ( *, '(a)' ) ' Not enough factorization space.' j = -2 return end if c c Force Q to be nonnegative. c qq = q 10 continue if ( qq .lt. 0 ) then qq = qq + p go to 10 end if c c For each prime factor, compute the Legendre symbol, and c multiply the Jacobi symbol by the appropriate factor. c j = 1 do i = 1, nfactor pp = factor(i) call legendre_symbol ( qq, pp, l ) if ( l .lt. -1 ) then write ( *, '(a)' ) ' ' write ( *, '(a)' ) 'JACOBI_SYMBOL - Fatal error!' write ( *, '(a)' ) & ' Error during Legendre symbol calculation.' j = -3 return end if j = j * l**power(i) end do return end subroutine jordan ( m, n, alpha, a ) c*********************************************************************72 c cc JORDAN returns the JORDAN matrix. c c Formula: c c if ( I = J ) c A(I,J) = ALPHA c else if ( I = J-1 ) c A(I,J) = 1 c else c A(I,J) = 0 c c Example: c c ALPHA = 2, M = 5, N = 5 c c 2 1 0 0 0 c 0 2 1 0 0 c 0 0 2 1 0 c 0 0 0 2 1 c 0 0 0 0 2 c c Properties: c c A is upper triangular. c c A is lower Hessenberg. c c A is bidiagonal. c c Because A is bidiagonal, it has property A (bipartite). c c A is banded, with bandwidth 2. c c A is generally not symmetric: A' /= A. c c A is persymmetric: A(I,J) = A(N+1-J,N+1-I). c c A is nonsingular if and only if ALPHA is nonzero. c c det ( A ) = ALPHA^N. c c LAMBDA(I) = ALPHA. c c A is defective, having only one eigenvector, namely (1,0,0,...,0). c c The JORDAN matrix is a special case of the BIS matrix. c c The family of matrices is nested as a function of N. c c Licensing: c c This code is distributed under the GNU LGPL license. c c Modified: c c 16 June 2011 c c Author: c c John Burkardt c c Parameters: c c Input, integer M, N, the order of the matrix. c c Input, double precision ALPHA, the eigenvalue of the Jordan matrix. c c Output, double precision A(M,N), the matrix. c implicit none integer m integer n double precision a(m,n) double precision alpha integer i integer j do j = 1, n do i = 1, m if ( i .eq. j ) then a(i,j) = alpha else if ( j .eq. i + 1 ) then a(i,j) = 1.0D+00 else a(i,j) = 0.0D+00 end if end do end do return end subroutine jordan_condition ( n, alpha, cond ) c*********************************************************************72 c cc JORDAN_CONDITION returns the L1 condition of the JORDAN matrix. c c Licensing: c c This code is distributed under the GNU LGPL license. c c Modified: c c 17 February 2015 c c Author: c c John Burkardt c c Parameters: c c Input, integer N, the order of the matrix. c c Input, double precision ALPHA, the eigenvalue of the Jordan matrix. c c Output, double precision COND, the L1 condition of the matrix. c implicit none double precision a_norm double precision a2 double precision alpha double precision b_norm double precision cond integer n a2 = abs ( alpha ) if ( n .eq. 1 ) then a_norm = a2 else a_norm = a2 + 1.0D+00 end if if ( a2 .eq. 1 ) then b_norm = dble ( n ) * a2 else b_norm = ( a2 ** n - 1.0D+00 ) / ( a2 - 1.0D+00 ) / a2 ** n end if cond = a_norm * b_norm return end subroutine jordan_determinant ( n, alpha, determ ) c*********************************************************************72 c cc JORDAN_DETERMINANT returns the determinant of the JORDAN matrix. c c Licensing: c c This code is distributed under the GNU LGPL license. c c Modified: c c 16 June 2011 c c Author: c c John Burkardt c c Parameters: c c Input, integer N, the order of the matrix. c c Input, double precision ALPHA, the eigenvalue of the Jordan matrix. c c Output, double precision DETERM, the determinant. c implicit none double precision alpha double precision determ integer n determ = alpha ** n return end subroutine jordan_eigenvalues ( n, alpha, lambda ) c*********************************************************************72 c cc JORDAN_EIGENVALUES returns the eigenvalues of the JORDAN matrix. c c Licensing: c c This code is distributed under the GNU LGPL license. c c Modified: c c 16 June 2011 c c Author: c c John Burkardt c c Parameters: c c Input, integer N, the order of the matrix. c c Input, double precision ALPHA, the eigenvalue of the Jordan matrix. c c Output, double precision LAMBDA(N), the eigenvalues of the matrix. c implicit none integer n double precision alpha integer i double precision lambda(n) do i = 1, n lambda(i) = alpha end do return end subroutine jordan_inverse ( n, alpha, a ) c*********************************************************************72 c cc JORDAN_INVERSE returns the inverse of the JORDAN matrix. c c Formula: c c if ( I <= J ) c A(I,J) = -1 * (-1/ALPHA)^(J+1-I) c else c A(I,J) = 0 c c Example: c c ALPHA = 2, N = 4 c c 1/2 -1/4 1/8 -1/16 c 0 1/2 -1/4 1/8 c 0 0 1/2 -1/4 c 0 0 0 1/2 c c Properties: c c A is upper triangular. c c A is Toeplitz: constant along diagonals. c c A is generally not symmetric: A' /= A. c c A is persymmetric: A(I,J) = A(N+1-J,N+1-I). c c The inverse of A is the Jordan block matrix, whose diagonal c entries are ALPHA, whose first superdiagonal entries are 1, c with all other entries zero. c c det ( A ) = (1/ALPHA)^N. c c LAMBDA(1:N) = 1 / ALPHA. c c Licensing: c c This code is distributed under the GNU LGPL license. c c Modified: c c 16 June 2011 c c Author: c c John Burkardt c c Parameters: c c Input, integer N, the order of the matrix. c c Input, double precision ALPHA, the eigenvalue of the Jordan matrix. c c Output, double precision A(N,N), the matrix. c implicit none integer n double precision a(n,n) double precision alpha integer i integer j if ( alpha .eq. 0.0D+00 ) then write ( *, '(a)' ) ' ' write ( *, '(a)' ) 'JORDAN_INVERSE - Fatal error!' write ( *, '(a)' ) ' The input parameter ALPHA was 0.' stop 1 end if do i = 1, n do j = 1, n if ( i .le. j ) then a(i,j) = - ( - 1.0D+00 / alpha ) ** ( j + 1 - i ) else a(i,j) = 0.0D+00 end if end do end do return end subroutine kahan ( alpha, m, n, a ) c*********************************************************************72 c cc KAHAN returns the KAHAN matrix. c c Formula: c c if ( I = J ) c A(I,I) = sin(ALPHA)^I c else if ( I < J ) c A(I,J) = - sin(ALPHA)^I * cos(ALPHA) c else c A(I,J) = 0 c c Example: c c ALPHA = 0.25, N = 4 c c S -C*S -C*S -C*S c 0 S^2 -C*S^2 -C*S^2 c 0 0 S^3 -C*S^3 c 0 0 0 S^4 c c where c c S = sin(ALPHA), C=COS(ALPHA) c c Properties: c c A is upper triangular. c c A = B * C, where B is a diagonal matrix and C is unit upper triangular. c For instance, for the case M = 3, N = 4: c c A = | S 0 0 | * | 1 -C -C -C | c | 0 S^2 0 | | 0 1 -C -C | c | 0 0 S^3 | | 0 0 1 -C | c c A is generally not symmetric: A' /= A. c c A has some interesting properties regarding estimation of c condition and rank. c c det ( A ) = sin(ALPHA)^(N*(N+1)/2). c c LAMBDA(I) = sin ( ALPHA )^I c c A is nonsingular if and only if sin ( ALPHA ) =/= 0. c c The family of matrices is nested as a function of N. c c Licensing: c c This code is distributed under the GNU LGPL license. c c Modified: c c 16 June 2011 c c Author: c c John Burkardt c c Reference: c c Nicholas Higham, c A survey of condition number estimation for triangular matrices, c SIAM Review, c Volume 9, 1987, pages 575-596. c c W Kahan, c Numerical Linear Algebra, c Canadian Mathematical Bulletin, c Volume 9, 1966, pages 757-801. c c Parameters: c c Input, double precision ALPHA, the scalar that defines A. A typical c value is 1.2. The "interesting" range of ALPHA is 0 < ALPHA < PI. c c Input, integer M, N, the order of the matrix. c c Output, double precision A(M,N), the matrix. c implicit none integer m integer n double precision a(m,n) double precision alpha double precision csi integer i integer j double precision si do i = 1, m si = sin ( alpha ) ** i csi = - cos ( alpha ) * si do j = 1, n if ( j .lt. i ) then a(i,j) = 0.0D+00 else if ( j .eq. i ) then a(i,j) = si else a(i,j) = csi end if end do end do return end subroutine kahan_determinant ( alpha, n, determ ) c*********************************************************************72 c cc KAHAN_DETERMINANT returns the determinant of the KAHAN matrix. c c Licensing: c c This code is distributed under the GNU LGPL license. c c Modified: c c 16 June 2011 c c Author: c c John Burkardt c c Parameters: c c Input, double precision ALPHA, the scalar that defines A. A typical c value is 1.2. The "interesting" range of ALPHA is 0 < ALPHA < PI. c c Input, integer N, the order of the matrix. c c Output, double precision DETERM, the determinant. c implicit none double precision alpha double precision determ integer n integer power power = ( n * ( n + 1 ) ) / 2 determ = ( sin ( alpha ) ) ** power return end subroutine kahan_inverse ( alpha, n, a ) c*********************************************************************72 c cc KAHAN_INVERSE returns the inverse of the KAHAN matrix. c c Licensing: c c This code is distributed under the GNU LGPL license. c c Modified: c c 16 June 2011 c c Author: c c John Burkardt c c Parameters: c c Input, double precision ALPHA, the scalar that defines A. A typical c value is 1.2. The "interesting" range of ALPHA is 0 < ALPHA < PI. c c Input, integer N, the order of the matrix. c c Output, double precision A(N,N), the matrix. c implicit none integer n double precision a(n,n) double precision alpha double precision ci integer i integer j double precision si ci = cos ( alpha ) do i = 1, n do j = 1, n if ( i .eq. j ) then a(i,j) = 1.0D+00 else if ( i .eq. j - 1 ) then a(i,j) = ci else if ( i .lt. j ) then a(i,j) = ci * ( 1.0D+00 + ci ) ** ( j - i - 1 ) else a(i,j) = 0.0D+00 end if end do end do c c Scale the columns. c do j = 1, n si = sin ( alpha ) ** j do i = 1, n a(i,j) = a(i,j) / si end do end do return end subroutine kershaw ( a ) c*********************************************************************72 c cc KERSHAW returns the KERSHAW matrix. c c Discussion: c c The Kershaw matrix is a simple example of a symmetric c positive definite matrix for which the incomplete Cholesky c factorization fails, because of a negative pivot. c c Example: c c 3 -2 0 2 c -2 3 -2 0 c 0 -2 3 -2 c 2 0 -2 3 c c Properties: c c A is symmetric. c c A is positive definite. c c det ( A ) = 1. c c LAMBDA(A) = [ c 5.828427124746192 c 5.828427124746188 c 0.171572875253810 c 0.171572875253810 ]. c c A does not have an incompete Cholesky factorization. c c Licensing: c c This code is distributed under the GNU LGPL license. c c Modified: c c 13 October 2007 c c Author: c c John Burkardt c c Reference: c c David Kershaw, c The Incomplete Cholesky-Conjugate Gradient Method for the Iterative c Solution of Systems of Linear Equations, c Journal of Computational Physics, c Volume 26, Number 1, January 1978, pages 43-65. c c Parameters: c c Output, double precision A(4,4), the matrix. c implicit none double precision a(4,4) double precision a_save(4,4) save a_save c c Note that the matrix entries are listed by column. c data a_save / & 3.0D+00, -2.0D+00, 0.0D+00, 2.0D+00, & -2.0D+00, 3.0D+00, -2.0D+00, 0.0D+00, & 0.0D+00, -2.0D+00, 3.0D+00, -2.0D+00, & 2.0D+00, 0.0D+00, -2.0D+00, 3.0D+00 / call r8mat_copy ( 4, 4, a_save, a ) return end subroutine kershaw_condition ( cond ) c*********************************************************************72 c cc KERSHAW_CONDITION returns the L1 condition of the KERSHAW matrix. c c Licensing: c c This code is distributed under the GNU LGPL license. c c Modified: c c 17 February 2015 c c Author: c c John Burkardt c c Parameters: c c Output, double precision COND, the L1 condition of the matrix. c implicit none double precision a_norm double precision b_norm double precision cond a_norm = 7.0D+00 b_norm = 7.0D+00 cond = a_norm * b_norm return end subroutine kershaw_determinant ( determ ) c*********************************************************************72 c cc KERSHAW_DETERMINANT returns the determinant of the KERSHAW matrix. c c Licensing: c c This code is distributed under the GNU LGPL license. c c Modified: c c 16 June 2011 c c Author: c c John Burkardt c c Parameters: c c Output, double precision DETERM, the determinant of the matrix. c implicit none double precision determ determ = 1.0D+00 return end subroutine kershaw_eigen_right ( x ) c*********************************************************************72 c cc KERSHAW_EIGEN_RIGHT returns the right eigenvectors of the KERSHAW matrix. c c Licensing: c c This code is distributed under the GNU LGPL license. c c Modified: c c 13 March 2015 c c Author: c c John Burkardt c c Parameters: c c Output, double precision X(4,4), the eigenvectors. c implicit none double precision x(4,4) double precision x_save(4,4) save x_save data x_save / & 0.500000000000000D+00, -0.707106781186548D+00, & 0.500000000000000D+00, -0.000000000000000D+00, & 0.500000000000000D+00, -0.000000000000000D+00, & -0.500000000000000D+00, 0.707106781186548D+00, & -0.548490135760211D+00, -0.703402951241362D+00, & -0.446271857698584D+00, 0.072279237578588D+00, & 0.446271857698584D+00, -0.072279237578588D+00, & -0.548490135760211D+00, -0.703402951241362D+00 / call r8mat_copy ( 4, 4, x_save, x ) return end subroutine kershaw_eigenvalues ( lambda ) c*********************************************************************72 c cc KERSHAW_EIGENVALUES returns the eigenvalues of the KERSHAW matrix. c c Licensing: c c This code is distributed under the GNU LGPL license. c c Modified: c c 16 June 2011 c c Author: c c John Burkardt c c Reference: c c David Kershaw, c The Incomplete Cholesky-Conjugate Gradient Method for the Iterative c Solution of Systems of Linear Equations, c Journal of Computational Physics, c Volume 26, Number 1, January 1978, pages 43-65. c c Parameters: c c Output, double precision LAMBDA(4), the eigenvalues of the matrix. c implicit none double precision lambda(4) double precision lambda_save(4) save lambda_save data lambda_save / & 5.828427124746192D+00, & 5.828427124746188D+00, & 0.171572875253810D+00, & 0.171572875253810D+00 / call r8vec_copy ( 4, lambda_save, lambda ) return end subroutine kershaw_inverse ( a ) c*********************************************************************72 c cc KERSHAW_INVERSE returns the inverse of the KERSHAW matrix. c c Licensing: c c This code is distributed under the GNU LGPL license. c c Modified: c c 16 June 2011 c c Author: c c John Burkardt c c Parameters: c c Output, double precision A(4,4), the matrix. c implicit none double precision a(4,4) double precision a_save(4,4) save a_save c c Note that the matrix entries are listed by column. c data a_save / & 3.0D+00, 2.0D+00, 0.0D+00, -2.0D+00, & 2.0D+00, 3.0D+00, 2.0D+00, 0.0D+00, & 0.0D+00, 2.0D+00, 3.0D+00, 2.0D+00, & -2.0D+00, 0.0D+00, 2.0D+00, 3.0D+00 / call r8mat_copy ( 4, 4, a_save, a ) return end subroutine kershaw_llt ( a ) c*********************************************************************72 c cc KERSHAW_LLT returns the Cholesky factor of the KERSHAW matrix. c c Licensing: c c This code is distributed under the GNU LGPL license. c c Modified: c c 15 March 2015 c c Author: c c John Burkardt c c Parameters: c c Output, double precision A(4,4), the matrix. c implicit none double precision a(4,4) c c Note that the matrix entries are listed by column. c double precision a_save(4,4) save a_save data a_save / & 1.732050807568877D+00, -1.154700538379252D+00, & 0.0D+00, 1.154700538379252D+00, & 0.0D+00, 1.290994448735805D+00, & -1.549193338482967D+00, 1.032795558988645D+00, & 0.0D+00, 0.0D+00, & 0.774596669241483D+00, -0.516397779494321D+00, & 0.0D+00, 0.0D+00, & 0.0D+00, 0.577350269189626D+00 / call r8mat_copy ( 4, 4, a_save, a ) return end subroutine kershawtri ( n, x, a ) c*********************************************************************72 c cc KERSHAWTRI returns the KERSHAWTRI matrix. c c Discussion: c c A(I,I) = X(I) for I <= (N+1)/2 c A(I,I) = X(N+1-I) for (N+1)/2 < I c A(I,J) = 1 for I = J + 1 or I = J - 1. c A(I,J) = 0 otherwise. c c Example: c c N = 5, c X = ( 10, 20, 30 ) c A = c 10 1 0 0 0 c 1 20 1 0 0 c 0 1 30 1 0 c 0 0 1 20 1 c 0 0 0 1 10 c c Properties: c c A is tridiagonal. c c A is symmetric. c c If the entries in X are integers, then det(A) is an integer. c c If det(A) is an integer, then det(A) * inv(A) is an integer matrix. c c A is persymmetric: A(I,J) = A(N+1-J,N+1-I). c c A is centrosymmetric: A(I,J) = A(N+1-I,N+1-J). c c Licensing: c c This code is distributed under the GNU LGPL license. c c Modified: c c 16 June 2011 c c Author: c c John Burkardt c c Reference: c c P Schlegel, c The Explicit Inverse of a Tridiagonal Matrix, c Mathematics of Computation, c Volume 24, Number 111, July 1970, page 665. c c Parameters: c c Input, integer N, the order of the matrix. c c Input, double precision X((N+1)/2), defines the diagonal of the matrix. c c Output, double precision A(N,N), the matrix. c implicit none integer n double precision a(n,n) integer i integer j integer nh double precision x((n+1)/2) double precision xim1 do j = 1, n do i = 1, n a(i,j) = 0.0D+00 end do end do nh = ( n / 2 ) do i = 1, nh a(i,i) = x(i) a(n+1-i,n+1-i) = x(i) end do if ( mod ( n, 2 ) .eq. 1 ) then a(nh+1,nh+1) = x(nh+1) end if do i = 1, n - 1 a(i,i+1) = 1.0D+00 a(i+1,i) = 1.0D+00 end do return end subroutine kershawtri_determinant ( n, x ) c*********************************************************************72 c cc KERSHAWTRI_DETERMINANT returns the determinant of the KERSHAWTRI matrix. c c Licensing: c c This code is distributed under the GNU LGPL license. c c Modified: c c 16 June 2011 c c Author: c c John Burkardt c c Parameters: c c Input, integer N, the order of the matrix. c c Input, double precision X((N+1)/2), defines the diagonal of the matrix. c c Output, double precision DETERM, the determinant. c implicit none integer n double precision determ integer i integer nh double precision r(n+1) double precision x((n+1)/2) double precision xim1 nh = ( n / 2 ) do i = 1, n + 1 r(i) = 0.0D+00 end do r(1) = 1.0D+00 r(2) = - x(1) do i = 3, n if ( i - 1 .le. nh ) then xim1 = x(i-1) else xim1 = x(n+1-i+1) end if r(i) = - ( xim1 * r(i-1) + r(i-2) ) end do determ = x(1) * r(n) + r(n-1) return end subroutine kershawtri_inverse ( n, x, a ) c*********************************************************************72 c cc KERSHAWTRI_INVERSE returns the inverse of the KERSHAWTRI matrix. c c Licensing: c c This code is distributed under the GNU LGPL license. c c Modified: c c 16 June 2011 c c Author: c c John Burkardt c c Parameters: c c Input, integer N, the order of the matrix. c c Input, double precision X((N+1)/2), defines the diagonal of the matrix. c c Output, double precision A(N,N), the matrix. c implicit none integer n double precision a(n,n) integer i integer j integer nh double precision r(n+1) double precision x((n+1)/2) double precision xim1 nh = ( n / 2 ) do i = 1, n + 1 r(i) = 0.0D+00 end do r(1) = 1.0D+00 r(2) = - x(1) do i = 3, n if ( i - 1 .le. nh ) then xim1 = x(i-1) else xim1 = x(n+1-i+1) end if r(i) = - ( xim1 * r(i-1) + r(i-2) ) end do r(n+1) = x(1) * r(n) + r(n-1) do j = 1, n do i = 1, n a(i,j) = 0.0D+00 end do end do do i = 1, n do j = 1, i - 1 a(i,j) = r(j) * r(n+1-i) / r(n+1) end do a(i,i) = r(i) * r(n+1-i) / r(n+1) do j = i + 1, n a(i,j) = r(i) * r(n+1-j) / r(n+1) end do end do return end subroutine kms ( alpha, m, n, a ) c*********************************************************************72 c cc KMS returns the KMS matrix. c c Discussion: c c The KMS matrix is also called the Kac-Murdock-Szego matrix. c c Formula: c c A(I,J) = ALPHA^abs ( I - J ) c c Example: c c ALPHA = 2, N = 5 c c 1 2 4 8 16 c 2 1 2 4 8 c 4 2 1 2 4 c 8 4 2 1 2 c 16 8 4 2 1 c c ALPHA = 1/2, N = 5 c c 1 1/2 1/4 1/8 1/16 c 1/2 1 1/2 1/4 1/8 c 1/4 1/2 1 1/2 1/4 c 1/8 1/4 1/2 1 1/2 c 1/16 1/8 1/4 1/2 1 c c Properties: c c A is Toeplitz: constant along diagonals. c c A is symmetric: A' = A. c c Because A is symmetric, it is normal. c c Because A is normal, it is diagonalizable. c c A is persymmetric: A(I,J) = A(N+1-J,N+1-I). c c A is centrosymmetric: A(I,J) = A(N+1-I,N+1-J). c c A has an L*D*L' factorization, with L being the inverse c of the transpose of the matrix with 1's on the diagonal and c -ALPHA on the superdiagonal and zero elsewhere, and c D(I,I) = (1-ALPHA^2) except that D(1,1)=1. c c det ( A ) = ( 1 - ALPHA * ALPHA )^(N-1). c c The inverse of A is tridiagonal. c c A is positive definite if and only if 0 < abs ( ALPHA ) < 1. c c The family of matrices is nested as a function of N. c c Licensing: c c This code is distributed under the GNU LGPL license. c c Modified: c c 08 June 2011 c c Author: c c John Burkardt c c Reference: c c William Trench, c Numerical solution of the eigenvalue problem for Hermitian c Toeplitz matrices, c SIAM Journal on Matrix Analysis and Applications, c Volume 10, Number 2, April 1989, pages 135-146. c c Parameters: c c Input, double precision ALPHA, the scalar that defines A. c A typical value is 0.5. c c Input, integer M, N, the order of the matrix. c c Output, double precision A(M,N), the matrix. c implicit none integer m integer n double precision a(m,n) double precision alpha integer i integer j do i = 1, m do j = 1, n if ( alpha .eq. 0.0D+00 .and. i .eq. j ) then a(i,j) = 1.0D+00 else a(i,j) = alpha**abs ( i - j ) end if end do end do return end subroutine kms_determinant ( alpha, n, determ ) c*********************************************************************72 c cc KMS_DETERMINANT returns the determinant of the KMS matrix. c c Licensing: c c This code is distributed under the GNU LGPL license. c c Modified: c c 08 June 2011 c c Author: c c John Burkardt c c Parameters: c c Input, double precision ALPHA, the scalar that defines A. c c Input, integer N, the order of the matrix. c c Output, double precision DETERM, the determinant. c implicit none double precision alpha double precision determ integer n if ( n .eq. 1 ) then determ = 1.0D+00 else determ = ( 1.0D+00 - alpha ) * ( 1.0D+00 + alpha ) determ = determ ** ( n - 1 ) end if return end subroutine kms_eigenvalues ( alpha, n, lambda ) c*********************************************************************72 c cc KMS_EIGENVALUES returns the eigenvalues of the KMS matrix. c c Licensing: c c This code is distributed under the GNU LGPL license. c c Modified: c c 08 June 2011 c c Author: c c John Burkardt c c Reference: c c William Trench, c Spectral decomposition of Kac-Murdock-Szego matrices, c Unpublished technical document. c c Parameters: c c Input, double precision ALPHA, the scalar that defines A. c Eigenvalue computations require 0 <= ALPHA <= 1. c c Input, integer N, the order of the matrix. c c Output, double precision LAMBDA(N), the eigenvalues. c implicit none integer n double precision alpha integer i double precision lambda(n) double precision theta(n) call kms_eigenvalues_theta ( alpha, n, theta ) do i = 1, n lambda(i) = ( 1.0D+00 + alpha ) * ( 1.0D+00 - alpha ) & / ( 1.0D+00 - 2.0D+00 * alpha * cos ( theta(i) ) & + alpha * alpha ) end do return end subroutine kms_eigenvalues_theta ( alpha, n, t ) c*********************************************************************72 c cc KMS_EIGENVALUES_THETA returns data needed to compute KMS eigenvalues. c c Licensing: c c This code is distributed under the GNU LGPL license. c c Modified: c c 08 June 2011 c c Author: c c John Burkardt c c Reference: c c William Trench, c Spectral decomposition of Kac-Murdock-Szego matrices, c Unpublished technical document. c c Parameters: c c Input, double precision ALPHA, the scalar that defines A. c Eigenvalue computations require 0 <= ALPHA <= 1. c c Input, integer N, the order of the matrix. c c Output, double precision T(N), the angles associated with c the eigenvalues. c implicit none integer n double precision alpha double precision fxa double precision fxb double precision fxc integer i double precision kms_eigenvalues_theta_f double precision r8_pi parameter ( r8_pi = 3.141592653589793D+00 ) integer step integer step_max parameter ( step_max = 100 ) double precision t(n) double precision temp double precision xa double precision xb double precision xc do i = 1, n c c Avoid confusion in first subinterval, where f(0) = 0. c if ( i .eq. 1 ) then xa = 0.0001D+00 else xa = dble ( i - 1 ) * r8_pi / dble ( n + 1 ) end if fxa = kms_eigenvalues_theta_f ( alpha, n, xa ) xb = dble ( i ) * r8_pi / dble ( n + 1 ) fxb = kms_eigenvalues_theta_f ( alpha, n, xb ) if ( 0.0D+00 .lt. fxa ) then temp = xa xa = xb xb = temp temp = fxa fxa = fxb fxb = temp end if do step = 1, step_max xc = 0.5D+00 * ( xa + xb ) fxc = kms_eigenvalues_theta_f ( alpha, n, xc ) c c Return if residual is small. c if ( abs ( fxc ) .le. 0.0000001D+00 ) then go to 10 end if c c Return if interval is small. c if ( abs ( xb - xa ) .le. 0.0000001D+00 ) then go to 10 end if if ( fxc .lt. 0.0D+00 ) then xa = xc fxa = fxc else xb = xc fxb = fxc end if end do 10 continue t(i) = xc end do return end function kms_eigenvalues_theta_f ( alpha, n, t ) c*********************************************************************72 c cc KMS_EIGENVALUES_THETA_F evaluates a function for KMS eigenvalues. c c Licensing: c c This code is distributed under the GNU LGPL license. c c Modified: c c 08 June 2011 c c Author: c c John Burkardt c c Reference: c c William Trench, c Spectral decomposition of Kac-Murdock-Szego matrices, c Unpublished technical document. c c Parameters: c c Input, double precision ALPHA, the scalar that defines A. c Eigenvalue computations require 0 <= ALPHA <= 1. c c Input, integer N, the order of the matrix. c c Input, double precision T, an angle associated with the eigenvalue. c c Output, double precision KMS_EIGENVALUES_THETA_F, the function value. c implicit none double precision alpha double precision kms_eigenvalues_theta_f integer n double precision n_r8 double precision t double precision value n_r8 = dble ( n ) value = sin ( ( n_r8 + 1.0D+00 ) * t ) & - 2.0D+00 * alpha * sin ( n_r8 * t ) & + alpha * alpha * sin ( ( n_r8 - 1.0D+00 ) * t ) kms_eigenvalues_theta_f = value return end subroutine kms_inverse ( alpha, n, a ) c*********************************************************************72 c cc KMS_INVERSE returns the inverse of the KMS matrix. c c Formula: c c if ( I = J ) c if ( I = 1 ) c A(I,J) = -1/(ALPHA^2-1) c else if ( I < N ) c A(I,J) = -(ALPHA^2+1)/(ALPHA^2-1) c else if ( I = N ) c A(I,J) = -1/(ALPHA^2-1) c else if ( J = I + 1 or I = J + 1 ) c A(I,J) = ALPHA/(ALPHA^2-1) c else c A(I,J) = 0 otherwise c c Example: c c ALPHA = 2, N = 5 c c -1 2 0 0 0 c 2 -5 2 0 0 c 1/3 * 0 2 -5 2 0 c 0 0 2 -5 2 c 0 0 0 2 -1 c c Properties: c c A is symmetric: A' = A. c c Because A is symmetric, it is normal. c c Because A is normal, it is diagonalizable. c c A is persymmetric: A(I,J) = A(N+1-J,N+1-I). c c Licensing: c c This code is distributed under the GNU LGPL license. c c Modified: c c 08 June 2011 c c Author: c c John Burkardt c c Reference: c c William Trench, c Numerical solution of the eigenvalue problem for Hermitian c Toeplitz matrices, c SIAM Journal on Matrix Analysis and Applications, c Volume 10, Number 2, April 1989, pages 135-146. c c Parameters: c c Input, double precision ALPHA, the scalar that defines A. c c Input, integer N, the order of the matrix. c c Output, double precision A(N,N), the matrix. c implicit none integer n double precision a(n,n) double precision alpha double precision bot integer i integer j bot = alpha * alpha - 1.0D+00 do i = 1, n do j = 1, n if ( i .eq. j ) then if ( j .eq. 1 ) then a(i,j) = - 1.0D+00 / bot else if ( j .lt. n ) then a(i,j) = - ( alpha * alpha + 1.0D+00 ) / bot else if ( j .eq. n ) then a(i,j) = -1.0D+00 / bot end if else if ( i .eq. j + 1 .or. j .eq. i + 1 ) then a(i,j) = alpha / bot else a(i,j) = 0.0D+00 end if end do end do return end subroutine kms_ldl ( alpha, n, l, d ) c*********************************************************************72 c cc KMS_LDL returns the LDL factorization of the KMS matrix. c c Discussion: c c A = L * D * L' c c Example: c c ALPHA = 0.5, N = 5 c c D = c c 1 0 0 0 0 c 0 3/4 0 0 0 c 0 0 3/4 0 0 c 0 0 0 3/4 0 c 0 0 0 0 3/4 c c L = c c 1 0 0 0 0 c 1/2 1 0 0 0 c 1/4 1/2 1 0 0 c 1/8 1/4 1/2 1 0 c 1/16 1/8 1/4 1/2 1 c c Licensing: c c This code is distributed under the GNU LGPL license. c c Modified: c c 08 June 2011 c c Author: c c John Burkardt c c Reference: c c William Trench, c Numerical solution of the eigenvalue problem for Hermitian c Toeplitz matrices, c SIAM Journal on Matrix Analysis and Applications, c Volume 10, Number 2, April 1989, pages 135-146. c c Parameters: c c Input, double precision ALPHA, the scalar that defines A. c A typical value is 0.5. c c Input, integer N, the order of the matrix. c c Output, double precision L(N,N), the lower triangular factor. c c Output, double precision D(N,N), the diagonal factor. c implicit none integer n double precision alpha double precision d(n,n) integer i integer j double precision l(n,n) l(1,1) = 1.0D+00 do i = 2, n l(i,1) = alpha * l(i-1,1) end do do j = 2, n do i = 1, j - 1 l(i,j) = 0.0D+00 end do do i = j, n l(i,j) = l(1+i-j,1) end do end do do j = 1, n do i = 1, n d(i,j) = 0.0D+00 end do end do d(1,1) = 1.0D+00 do i = 2, n d(i,i) = 1.0D+00 - alpha * alpha end do return end subroutine kms_plu ( alpha, n, p, l, u ) c*********************************************************************72 c cc KMS_PLU returns the PLU factors of the KMS matrix. c c Example: c c ALPHA = 0.5, N = 5 c c P = Identity matrix c c L = c c 1 0 0 0 0 c 1/2 1 0 0 0 c 1/4 1/2 1 0 0 c 1/8 1/4 1/2 1 0 c 1/16 1/8 1/4 1/2 1 c c U = c c 1 1/2 1/4 1/8 1/16 c 0 3/4 3/8 3/16 3/32 c 0 0 3/4 3/8 3/16 c 0 0 0 3/4 3/8 c 0 0 0 0 3/4 c c Licensing: c c This code is distributed under the GNU LGPL license. c c Modified: c c 08 June 2011 c c Author: c c John Burkardt c c Reference: c c William Trench, c Numerical solution of the eigenvalue problem for Hermitian c Toeplitz matrices, c SIAM Journal on Matrix Analysis and Applications, c Volume 10, Number 2, April 1989, pages 135-146. c c Parameters: c c Input, double precision ALPHA, the scalar that defines A. c A typical value is 0.5. c c Input, integer N, the order of the matrix. c c Output, double precision P(N,N), L(N,N), U(N,N), the PLU factors. c implicit none integer n double precision alpha integer i integer j double precision l(n,n) double precision p(n,n) double precision u(n,n) do j = 1, n do i = 1, n if ( i .eq. j ) then p(i,j) = 1.0D+00 else p(i,j) = 0.0D+00 end if end do end do l(1,1) = 1.0D+00 do i = 2, n l(i,1) = alpha * l(i-1,1) end do do j = 2, n do i = 1, j - 1 l(i,j) = 0.0D+00 end do do i = j, n l(i,j) = l(1+i-j,1) end do end do do j = 1, n do i = 1, n u(i,j) = l(j,i) end do end do do j = 1, n do i = 2, n u(i,j) = u(i,j) * ( 1.0D+00 - alpha * alpha ) end do end do return end subroutine kms_eigen_right ( alpha, n, a ) c*********************************************************************72 c cc KMS_EIGEN_RIGHT returns right eigenvectors of the KMS matrix. c c Licensing: c c This code is distributed under the GNU LGPL license. c c Modified: c c 08 June 2011 c c Author: c c John Burkardt c c Reference: c c William Trench, c Spectral decomposition of Kac-Murdock-Szego matrices, c Unpublished technical report. c c Parameters: c c Input, double precision ALPHA, the parameter. c Eigenvalue computations require 0 <= ALPHA <= 1. c c Input, integer N, the order of A. c c Output, double precision A(N,N), the right eigenvector matrix. c implicit none integer n double precision a(n,n) double precision alpha integer i integer j double precision t(n) call kms_eigenvalues_theta ( alpha, n, t ) do i = 1, n do j = 1, n a(i,j) = sin ( dble ( i ) * t(j) ) & - alpha * sin ( dble ( i - 1 ) * t(j) ) end do end do return end subroutine krylov ( n, b, x, a ) c*********************************************************************72 c cc KRYLOV returns the KRYLOV matrix. c c Formula: c c Column 1 of A is X. c Column 2 of A is B*X. c Column 3 of A is B*B*X. c .. c Column N of A is B^(N-1)*X. c c Example: c c N = 5, X = ( 1, -2, 3, -4, 5 ) c c Matrix B: c c 1 2 1 0 1 c 1 0 3 1 4 c 2 1 3 2 1 c 1 1 2 1 0 c 1 -4 3 5 0 c c Matrix A: c c 6 61 71 688 c 26 16 -37 2752 c 6 54 312 1878 c 1 44 229 887 c -2 -76 379 2300 c c Properties: c c A is generally not symmetric: A' /= A. c c The family of matrices is nested as a function of N. c c Licensing: c c This code is distributed under the GNU LGPL license. c c Modified: c c 20 June 2011 c c Author: c c John Burkardt c c Reference: c c Gene Golub, Charles Van Loan, c Matrix Computations, c Johns Hopkins University Press, 1983, page 224. c c Parameters: c c Input, integer N, the order of the matrices. c c Input, double precision B(N,N), the multiplying matrix. c c Input, double precision X(N), the vector defining A. c c Output, double precision A(N,N), the matrix. c implicit none integer n double precision a(n,n) double precision b(n,n) integer i integer j double precision x(n) do i = 1, n a(i,1) = x(i) end do do j = 2, n call r8mat_mv ( n, n, b, a(1,j-1), a(1,j) ) end do return end subroutine laguerre ( n, a ) c*********************************************************************72 c cc LAGUERRE returns the LAGUERRE matrix. c c Example: c c N = 8 c c 1 . . . . . . . c 1 -1 . . . . . . c 2 -4 1 . . . . . / 2 c 6 -18 9 -1 . . . . / 6 c 24 -96 72 -16 1 . . . / 24 c 120 -600 600 -200 25 -1 . . / 120 c 720 -4320 5400 -2400 450 -36 1 . / 720 c 5040 -35280 52920 -29400 7350 -882 49 -1 / 5040 c c Properties: c c A is generally not symmetric: A' /= A. c c A is lower triangular. c c The columns of A alternate in sign. c c A(I,1) = 1 c A(I,I) = (-1)^(I-1) / (I-1)!. c c LAMBDA(I) = (-1)^(I-1) / (I-1)!. c c det ( A ) = product ( 1 <= I <= N ) (-1)^(I-1) / (I-1)! c c The I-th row contains the coefficients of the Laguerre c polynomial of degree I-1. c c The family of matrices is nested as a function of N. c c Licensing: c c This code is distributed under the GNU LGPL license. c c Modified: c c 20 June 2011 c c Author: c c John Burkardt c c Reference: c c Milton Abramowitz, Irene Stegun, c Handbook of Mathematical Functions, c US Department of Commerce, 1964. c c Parameters: c c Input, integer N, the order of the matrix. c c Output, double precision A(N,N), the matrix. c implicit none integer n double precision a(n,n) integer i integer j if ( n <= 0 ) then return end if do j = 1, n do i = 1, n a(i,j) = 0.0D+00 end do end do a(1,1) = 1.0D+00 if ( n .eq. 1 ) then return end if a(2,1) = 1.0D+00 a(2,2) = -1.0D+00 if ( n .eq. 2 ) then return end if do i = 3, n do j = 1, n if ( j .eq. 1 ) then a(i,j) = ( dble ( 2 * i - 3 ) * a(i-1,j) & + dble ( - i + 2 ) * a(i-2,j) ) & / dble ( i - 1 ) else a(i,j) = ( dble ( 2 * i - 3 ) * a(i-1,j) & - dble ( 1 ) * a(i-1,j-1) & + dble ( - i + 2 ) * a(i-2,j) ) & / dble ( i - 1 ) end if end do end do return end subroutine laguerre_determinant ( n, determ ) c*********************************************************************72 c cc LAGUERRE_DETERMINANT returns the determinant of the LAGUERRE matrix. c c Licensing: c c This code is distributed under the GNU LGPL license. c c Modified: c c 03 November 2007 c c Author: c c John Burkardt c c Parameters: c c Input, integer N, the order of the matrix. c c Output, double precision DETERM, the determinant. c implicit none double precision determ integer i integer im1 integer n double precision p double precision r8_factorial determ = 1.0D+00 p = + 1.0D+00 do i = 1, n im1 = i - 1 determ = determ * p / r8_factorial ( im1 ) p = - p end do return end subroutine laguerre_inverse ( n, a ) c*********************************************************************72 c cc LAGUERRE_INVERSE returns the inverse of the LAGUERRE matrix. c c Example: c c N = 9 c c 1 . . . . . . . . c 1 -1 . . . . . . . c 2 -4 2 . . . . . . c 6 -18 18 -6 . . . . . c 24 -96 144 -96 24 . . . . c 120 -600 1200 -1200 600 -120 . . . c 720 -4320 10800 -14400 10800 -4320 720 . . c 5040 -35280 105840 -176400 176400 -105840 35280 -5040 . c 40320 -322560 1128960 -2257920 2822400 -2257920 1128960 -322560 40320 c c Properties: c c A is generally not symmetric: A' /= A. c c A is lower triangular. c c The columns of A alternate in sign. c c A(I,1) = (I-1)! c A(I,I) = (I-1)! * ( -1 )^(N+1) c c Licensing: c c This code is distributed under the GNU LGPL license. c c Modified: c c 13 July 2000 c c Author: c c John Burkardt c c Parameters: c c Input, integer N, the order of the matrix. c c Output, double precision A(N,N), the matrix. c implicit none integer n double precision a(n,n) integer i integer j if ( n .le. 0 ) then return end if do j = 1, n do i = 1, n a(i,j) = 0.0D+00 end do end do a(1,1) = 1.0D+00 if ( n .eq. 1 ) then return end if a(2,1) = 1.0D+00 a(2,2) = -1.0D+00 if ( n .eq. 2 ) then return end if do i = 3, n do j = 1, n if ( j .eq. 1 ) then a(i,j) = dble ( i - 1 ) * ( a(i-1,j) ) else a(i,j) = dble ( i - 1 ) * ( a(i-1,j) - a(i-1,j-1) ) end if end do end do return end subroutine lauchli ( alpha, m, n, a ) c*********************************************************************72 c cc LAUCHLI returns the LAUCHLI matrix. c c Discussion: c c The Lauchli matrix is of order M by N, with M = N + 1. c c This matrix is a well-known example in least squares that indicates c the danger of forming the matrix of the normal equations, A' * A. c c A common value for ALPHA is sqrt(EPS) where EPS is the machine epsilon. c c Formula: c c if ( I = 1 ) c A(I,J) = 1 c else if ( I-1 = J ) c A(I,J) = ALPHA c else c A(I,J) = 0 c c Example: c c M = 5, N = 4 c ALPHA = 2 c c 1 1 1 1 c 2 0 0 0 c 0 2 0 0 c 0 0 2 0 c 0 0 0 2 c c Properties: c c The matrix is singular in a simple way. The first row is c equal to the sum of the other rows, divided by ALPHA. c c if ( ALPHA /= 0 ) then c rank ( A ) = N - 1 c else if ( ALPHA .eq. 0 ) then c rank ( A ) = 1 c c The family of matrices is nested as a function of N. c c Licensing: c c This code is distributed under the GNU LGPL license. c c Modified: c c 15 April 1999 c c Author: c c John Burkardt c c Reference: c c Peter Lauchli, c Jordan-Elimination und Ausgleichung nach kleinsten Quadraten, c (Jordan elimination and smoothing by least squares), c Numerische Mathematik, c Volume 3, Number 1, December 1961, pages 226-240. c c Parameters: c c Input, double precision ALPHA, the scalar defining the matrix. c c Input, integer M, N, the order of the matrix. c It should be the case that M = N + 1. c c Output, double precision A(M,N), the matrix. c implicit none integer m integer n double precision a(m,n) double precision alpha integer i integer j do j = 1, n do i = 1, m if ( i .eq. 1 ) then a(i,j) = 1.0D+00 else if ( i .eq. j + 1 ) then a(i,j) = alpha else a(i,j) = 0.0D+00 end if end do end do return end subroutine lauchli_null_left ( alpha, m, n, x ) c*********************************************************************72 c cc LAUCHLI_NULL_LEFT returns a left null vector of the LAUCHLI matrix. c c Licensing: c c This code is distributed under the GNU LGPL license. c c Modified: c c 03 November 2007 c c Author: c c John Burkardt c c Parameters: c c Input, double precision ALPHA, the scalar defining the matrix. c c Input, integer M, N, the order of the matrix. c It should be the case that M = N + 1. c c Output, double precision X(M), the vector. c implicit none integer m integer n double precision alpha integer i double precision x(m) x(1) = - alpha do i = 2, m x(i) = 1.0D+00 end do return end subroutine legendre ( n, a ) c*********************************************************************72 c cc LEGENDRE returns the LEGENDRE matrix. c c Example: c c N = 11 c c 1 . . . . . . . . . . / 1 c . 1 . . . . . . . . . / 1 c -1 . 3 . . . . . . . . / 2 c . -3 . 5 . . . . . . . / 2 c 3 . -30 . 35 . . . . . . / 8 c . 15 . -70 . 63 . . . . . / 8 c -5 . 105 . -315 . 231 . . . . / 16 c . -35 . 315 . -693 . 429 . . . / 16 c 35 . -1260 . 6930 . -12012 . 6435 . . / 128 c . 315 . -4620 . 18018 . -25740 . 12155 . / 128 c -63 . 3465 . -30030 . 90090 . -109395 . 46189 / 256 c c Properties: c c A is generally not symmetric: A' /= A. c c A is lower triangular. c c The elements of each row sum to 1. c c Because it has a constant row sum of 1, c A has an eigenvalue of 1, and c a right eigenvector of ( 1, 1, 1, ..., 1 ). c c A is reducible. c c The diagonals form a pattern of zero, positive, zero, negative. c c The family of matrices is nested as a function of N. c c Licensing: c c This code is distributed under the GNU LGPL license. c c Modified: c c 20 June 2011 c c Author: c c John Burkardt c c Parameters: c c Input, integer N, the order of the matrix. c c Output, double precision A(N,N), the matrix. c implicit none integer n double precision a(n,n) integer i integer j if ( n .le. 0 ) then return end if do j = 1, n do i = 1, n a(i,j) = 0.0D+00 end do end do a(1,1) = 1.0D+00 if ( n .eq. 1 ) then return end if a(2,2) = 1.0D+00 if ( n .eq. 2 ) then return end if do i = 3, n do j = 1, n if ( j .eq. 1 ) then a(i,j) = - dble ( i - 2 ) * a(i-2,j) & / dble ( i - 1 ) else a(i,j) = ( dble ( 2 * i - 3 ) * a(i-1,j-1) & + dble ( - i + 2 ) * a(i-2,j) ) & / dble ( i - 1 ) end if end do end do return end subroutine legendre_determinant ( n, determ ) c*********************************************************************72 c cc LEGENDRE_DETERMINANT returns the determinant of the LEGENDRE matrix. c c Licensing: c c This code is distributed under the GNU LGPL license. c c Modified: c c 07 February 2015 c c Author: c c John Burkardt c c Parameters: c c Input, integer N, the order of the matrix. c c Output, double precision DETERM, the determinant. c implicit none double precision determ integer i integer n double precision t double precision value value = 1.0D+00 t = 1.0D+00 do i = 3, n t = t * dble ( 2 * i - 3 ) / dble ( i - 1 ) value = value * t; end do determ = value return end subroutine legendre_inverse ( n, a ) c*********************************************************************72 c cc LEGENDRE_INVERSE returns the inverse of the LEGENDRE matrix. c c Example: c c N = 11 c c 1 . . . . . . . . . . c . 1 . . . . . . . . . c 1 . 2 . . . . . . . . / 3 c . 3 . 2 . . . . . . . / 5 c 7 . 20 . 8 . . . . . . / 35 c . 27 . 28 . 8 . . . . . / 63 c 33 . 110 . 72 . 16 . . . . / 231 c . 143 . 182 . 88 . 16 . . . / 429 c 715 . 2600 . 2160 . 832 . 128 . . / 6435 c . 3315 . 4760 . 2992 . 960 . 128 . / 12155 c 4199 . 16150 . 15504 . 7904 . 2176 . 256 / 46189 c c Properties: c c A is nonnegative. c c The elements of each row sum to 1. c c Because it has a constant row sum of 1, c A has an eigenvalue of 1, and c a right eigenvector of ( 1, 1, 1, ..., 1 ). c c A is lower triangular. c c A is reducible. c c Licensing: c c This code is distributed under the GNU LGPL license. c c Modified: c c 20 June 2011 c c Author: c c John Burkardt c c Parameters: c c Input, integer N, the order of the matrix. c c Output, double precision A(N,N), the matrix. c implicit none integer n double precision a(n,n) integer i integer j if ( n .le. 0 ) then return end if do j = 1, n do i = 1, n a(i,j) = 0.0D+00 end do end do a(1,1) = 1.0D+00 if ( n .eq. 1 ) then return end if a(2,2) = 1.0D+00 if ( n .eq. 2 ) then return end if do i = 3, n do j = 1, n if ( j .eq. 1 ) then a(i,j) = dble ( j ) * a(i-1,j+1) & / dble ( 2 * j + 1 ) else if ( j .lt. n ) then a(i,j) = dble ( j - 1 ) * a(i-1,j-1) & / dble ( 2 * j - 3 ) & + dble ( j ) * a(i-1,j+1) & / dble ( 2 * j + 1 ) else a(i,j) = dble ( j - 1 ) * a(i-1,j-1) & / dble ( 2 * j - 3 ) end if end do end do return end subroutine legendre_symbol ( q, p, l ) c*********************************************************************72 c cc LEGENDRE_SYMBOL evaluates the Legendre symbol (Q/P). c c Discussion: c c Let P be an odd prime. Q is a QUADRATIC RESIDUE modulo P c if there is an integer R such that R^2 = Q ( mod P ). c The Legendre symbol ( Q / P ) is defined to be: c c + 1 if Q ( mod P ) /= 0 and Q is a quadratic residue modulo P, c - 1 if Q ( mod P ) /= 0 and Q is not a quadratic residue modulo P, c 0 if Q ( mod P ) .eq. 0. c c We can also define ( Q / P ) for P = 2 by: c c + 1 if Q ( mod P ) /= 0 c 0 if Q ( mod P ) .eq. 0 c c Example: c c (0/7) = 0 c (1/7) = + 1 ( 1^2 = 1 mod 7 ) c (2/7) = + 1 ( 3^2 = 2 mod 7 ) c (3/7) = - 1 c (4/7) = + 1 ( 2^2 = 4 mod 7 ) c (5/7) = - 1 c (6/7) = - 1 c c Note: c c For any prime P, exactly half of the integers from 1 to P-1 c are quadratic residues. c c ( 0 / P ) = 0. c c ( Q / P ) = ( mod ( Q, P ) / P ). c c ( Q / P ) = ( Q1 / P ) * ( Q2 / P ) if Q = Q1 * Q2. c c If Q is prime, and P is prime and greater than 2, then: c c if ( Q .eq. 1 ) then c c ( Q / P ) = 1 c c else if ( Q .eq. 2 ) then c c ( Q / P ) = + 1 if mod ( P, 8 ) = 1 or mod ( P, 8 ) = 7, c ( Q / P ) = - 1 if mod ( P, 8 ) = 3 or mod ( P, 8 ) = 5. c c else c c ( Q / P ) = - ( P / Q ) if Q = 3 ( mod 4 ) and P = 3 ( mod 4 ), c = ( P / Q ) otherwise. c c Licensing: c c This code is distributed under the GNU LGPL license. c c Modified: c c 18 July 2008 c c Author: c c John Burkardt c c Reference: c c Charles Pinter, c A Book of Abstract Algebra, c McGraw Hill, 1982, pages 236-237. c c Daniel Zwillinger, c CRC Standard Mathematical Tables and Formulae, c 30th Edition, c CRC Press, 1996, pages 86-87. c c Parameters: c c Input, integer Q, an integer whose Legendre symbol with c respect to P is desired. c c Input, integer P, a prime number, greater than 1, with respect c to which the Legendre symbol of Q is desired. c c Output, integer L, the Legendre symbol (Q/P). c Ordinarily, L will be -1, 0 or 1. c L = -2, P is less than or equal to 1. c L = -3, P is not prime. c L = -4, the internal stack of factors overflowed. c L = -5, not enough factorization space. c implicit none integer maxfactor parameter ( maxfactor = 20 ) integer maxstack parameter ( maxstack = 50 ) integer factor(maxfactor) integer i logical i4_is_prime integer l integer nfactor integer nleft integer nmore integer nstack integer p integer power(maxfactor) integer pp integer pstack(maxstack) integer q integer qq integer qstack(maxstack) integer t c c P must be greater than 1. c if ( p .le. 1 ) then write ( *, '(a)' ) ' ' write ( *, '(a)' ) 'LEGENDRE_SYMBOL - Fatal error!' write ( *, '(a)' ) ' P must be greater than 1.' l = -2 return end if c c P must be prime. c if ( .not. i4_is_prime ( p ) ) then write ( *, '(a)' ) ' ' write ( *, '(a)' ) 'LEGENDRE_SYMBOL - Fatal error!' write ( *, '(a)' ) ' P is not prime.' l = -3 return end if c c ( k*P / P ) = 0. c if ( mod ( q, p ) .eq. 0 ) then l = 0 return end if c c For the special case P = 2, (Q/P) = 1 for all odd numbers. c if ( p .eq. 2 ) then l = 1 return end if c c Make a copy of Q, and force it to be nonnegative. c qq = q 10 continue if ( qq .lt. 0 ) then qq = qq + p go to 10 end if nstack = 0 pp = p l = 1 20 continue qq = mod ( qq, pp ) c c Decompose QQ into factors of prime powers. c call i4_factor ( qq, maxfactor, nfactor, factor, power, nleft ) if ( nleft .ne. 1 ) then write ( *, '(a)' ) ' ' write ( *, '(a)' ) 'LEGENDRE_SYMBOL - Fatal error!' write ( *, '(a)' ) ' Not enough factorization space.' l = - 5 return end if c c Each factor which is an odd power is added to the stack. c nmore = 0 do i = 1, nfactor if ( mod ( power(i), 2 ) .eq. 1 ) then nmore = nmore + 1 nstack = nstack + 1 if ( maxstack .lt. nstack ) then write ( *, '(a)' ) ' ' write ( *, '(a)' ) 'LEGENDRE_SYMBOL - Fatal error!' write ( *, '(a)' ) ' Stack overflowc' l = - 4 return end if pstack(nstack) = pp qstack(nstack) = factor(i) end if end do if ( nmore .ne. 0 ) then qq = qstack(nstack) nstack = nstack - 1 c c Check for a QQ of 1 or 2. c if ( qq .eq. 1 ) then l = + 1 * l else if ( qq .eq. 2 .and. & ( mod ( pp, 8 ) .eq. 1 .or. & mod ( pp, 8 ) .eq. 7 ) ) then l = + 1 * l else if ( qq .eq. 2 .and. & ( mod ( pp, 8 ) .eq. 3 .or. & mod ( pp, 8 ) .eq. 5 ) ) then l = - 1 * l else if ( mod ( pp, 4 ) .eq. 3 .and. & mod ( qq, 4 ) .eq. 3 ) then l = - 1 * l end if t = pp pp = qq qq = t go to 20 end if end if c c If the stack is empty, we're done. c if ( nstack .eq. 0 ) then go to 30 end if c c Otherwise, get the last P and Q from the stack, and process them. c pp = pstack(nstack) qq = qstack(nstack) nstack = nstack - 1 go to 20 30 continue return end subroutine legendre_van ( m, a, b, n, x, v ) c*********************************************************************72 c cc LEGENDRE_VAN returns the LEGENDRE_VAN matrix. c c Discussion: c c The LEGENDRE_VAN matrix is the Legendre Vandermonde-like matrix. c c Normally, the Legendre polynomials are defined on -1 <= XI <= +1. c Here, we assume the Legendre polynomials have been defined on the c interval A <= X <= B, using the mapping c XI = ( - ( B - X ) + ( X - A ) ) / ( B - A ) c so that c Lab(A,B;X) = L(XI). c c if ( I = 1 ) then c V(1,1:N) = 1 c else if ( I = 2 ) then c V(2,1:N) = XI(1:N) c else c V(I,1:N) = ( (2*I-1) * XI(1:N) * V(I-1,1:N) - (I-1)*V(I-2,1:N) ) / I c c Licensing: c c This code is distributed under the GNU LGPL license. c c Modified: c c 10 April 2014 c c Author: c c John Burkardt c c Parameters: c c Input, integer M, the number of rows of the matrix. c c Input, double precision A, B, the interval. c c Input, integer N, the number of columns of the matrix. c c Input, double precision X(N), the vector that defines the matrix. c c Output, double precision V(M,N), the matrix. c implicit none integer m integer n double precision a double precision b integer i integer j double precision v(m,n) double precision x(n) double precision xi do j = 1, n xi = ( - ( b - x(j) ) + ( x(j) - a ) ) / ( b - a ) do i = 1, m if ( i .eq. 1 ) then v(i,j) = 1.0D+00 else if ( i .eq. 2 ) then v(i,j) = xi else v(i,j) = ( dble ( 2 * i - 1 ) * xi * v(i-1,j) + & dble ( - i + 1 ) * v(i-2,j) ) & / dble ( i ) end if end do end do return end subroutine legendre_zeros ( n, x ) c*********************************************************************72 c cc LEGENDRE_ZEROS computes the zeros of the Legendre polynomial. c c Licensing: c c This code is distributed under the GNU LGPL license. c c Modified: c c 16 June 2011 c c Parameters: c c Input, integer N, the degree of the polynomial. c c Output, double precision X(N), the zeros of the polynomial. c implicit none integer n double precision d1 double precision d2pn double precision d3pn double precision d4pn double precision dp double precision dpn double precision e1 double precision fx double precision h integer i integer iback integer k integer m integer mp1mi integer ncopy integer nmove double precision p double precision r8_pi parameter ( r8_pi = 3.141592653589793D+00 ) double precision pk double precision pkm1 double precision pkp1 double precision t double precision u double precision v double precision x0 double precision x(n) double precision xtemp e1 = dble ( n * ( n + 1 ) ) m = ( n + 1 ) / 2 do i = 1, ( n + 1 ) / 2 mp1mi = m + 1 - i t = dble ( 4 * i - 1 ) * r8_pi / dble ( 4 * n + 2 ) x0 = cos(t) * ( 1.0D+00 - ( 1.0D+00 - 1.0D+00 / dble ( n ) ) & / dble ( 8 * n * n ) ) pkm1 = 1.0D+00 pk = x0 do k = 2, n pkp1 = 2.0D+00 * x0 * pk - pkm1 - ( x0 * pk - pkm1 ) & / dble ( k ) pkm1 = pk pk = pkp1 end do d1 = dble ( n ) * ( pkm1 - x0 * pk ) dpn = d1 / ( 1.0D+00 - x0 * x0 ) d2pn = ( 2.0D+00 * x0 * dpn - e1 * pk ) / ( 1.0D+00 - x0 * x0 ) d3pn = ( 4.0D+00 * x0 * d2pn + ( 2.0D+00 - e1 ) * dpn ) & / ( 1.0D+00 - x0 * x0 ) d4pn = ( 6.0D+00 * x0 * d3pn + ( 6.0D+00 - e1 ) * d2pn ) / & ( 1.0D+00 - x0 * x0 ) u = pk / dpn v = d2pn / dpn c c Initial approximation H: c h = - u * ( 1.0D+00 + 0.5D+00 * u * ( v + u * ( v * v - d3pn / & ( 3.0D+00 * dpn ) ) ) ) c c Refine H using one step of Newton's method: c p = pk + h * ( dpn + 0.5D+00 * h * ( d2pn + h / 3.0D+00 & * ( d3pn + 0.25D+00 * h * d4pn ) ) ) dp = dpn + h * ( d2pn + 0.5D+00 * h & * ( d3pn + h * d4pn / 3.0D+00 ) ) h = h - p / dp xtemp = x0 + h x(mp1mi) = xtemp fx = d1 - h * e1 * ( pk + 0.5D+00 * h * ( dpn + h / 3.0D+00 & * ( d2pn + 0.25D+00 * h * ( d3pn + 0.2D+00 * h * d4pn ) ) ) ) end do if ( mod ( n, 2 ) .eq. 1 ) then x(1) = 0.0D+00 end if c c Shift the data up. c nmove = ( n + 1 ) / 2 ncopy = n - nmove do i = 1, nmove iback = n + 1 - i x(iback) = x(iback-ncopy) end do c c Reflect values for the negative abscissas. c do i = 1, n - nmove x(i) = - x(n+1-i) end do return end subroutine lehmer ( m, n, a ) c*********************************************************************72 c cc LEHMER returns the LEHMER matrix. c c Discussion: c c This matrix is also known as the "Westlake" matrix. c c See page 154 of the Todd reference. c c Formula: c c A(I,J) = min ( I, J ) / max ( I, J ) c c Example: c c N = 5 c c 1/1 1/2 1/3 1/4 1/5 c 1/2 2/2 2/3 2/4 2/5 c 1/3 2/3 3/3 3/4 3/5 c 1/4 2/4 3/4 4/4 4/5 c 1/5 2/5 3/5 4/5 5/5 c c Properties: c c A is symmetric: A' = A. c c Because A is symmetric, it is normal. c c Because A is normal, it is diagonalizable. c c A is positive definite. c c A is totally nonnegative. c c The inverse of A is tridiagonal. c c The condition number of A lies between N and 4*N*N. c c The family of matrices is nested as a function of N. c c Licensing: c c This code is distributed under the GNU LGPL license. c c Modified: c c 20 June 2011 c c Author: c c John Burkardt c c Reference: c c Morris Newman, John Todd, c The evaluation of matrix inversion programs, c Journal of the Society for Industrial and Applied Mathematics, c Volume 6, Number 4, 1958, pages 466-476. c c Solutions to problem E710, proposed by DH Lehmer: The inverse of c a matrix. c American Mathematical Monthly, c Volume 53, Number 9, November 1946, pages 534-535. c c John Todd, c Basic Numerical Mathematics, c Volume 2: Numerical Algebra, c Birkhauser, 1980, c ISBN: 0817608117, c LC: QA297.T58. c c Parameters: c c Input, integer M, N, the order of the matrix. c c Output, double precision A(M,N), the matrix. c implicit none integer m integer n double precision a(m,n) integer i integer j do j = 1, n do i = 1, m a(i,j) = dble ( min ( i, j ) ) / dble ( max ( i, j ) ) end do end do return end subroutine lehmer_determinant ( n, value ) c*********************************************************************72 c cc LEHMER_DETERMINANT returns the determinant of the LEHMER matrix. c c Formula: c c determinant = (2n)! / 2^n / (n!)^3 c c Licensing: c c This code is distributed under the GNU LGPL license. c c Modified: c c 07 April 2015 c c Author: c c John Burkardt c c Reference: c c Emrah Kilic, Pantelimon Stanica, c The Lehmer matrix and its recursive analogue, c Journal of Combinatorial Mathematics and Combinatorial Computing, c Volume 74, August 2010, pages 193-205. c c Parameters: c c Input, integer M, N, the order of the matrix. c c Output, double precision VALUE, the determinant. c implicit none integer i integer n double precision value value = 1.0D+00 do i = 1, n value = value * dble ( n + i ) / dble ( 2 * i ** 2 ) end do return end subroutine lehmer_inverse ( n, a ) c*********************************************************************72 c cc LEHMER_INVERSE returns the inverse of the LEHMER matrix. c c Licensing: c c This code is distributed under the GNU LGPL license. c c Modified: c c 20 June 2011 c c Author: c c John Burkardt c c Parameters: c c Input, integer N, the order of the matrix. c c Output, double precision A(N,N), the matrix. c implicit none integer n double precision a(n,n) integer i integer j do j = 1, n do i = 1, n a(i,j) = 0.0D+00 end do end do do i = 1, n - 1 a(i,i) = dble ( 4 * i * i * i ) / dble ( 4 * i * i - 1 ) end do a(n,n) = dble ( n * n ) / dble ( 2 * n - 1 ) do i = 1, n - 1 a(i,i+1) = - dble ( i * ( i + 1 ) ) / dble ( 2 * i + 1 ) a(i+1,i) = - dble ( i * ( i + 1 ) ) / dble ( 2 * i + 1 ) end do return end subroutine lehmer_llt ( n, a ) c*********************************************************************72 c cc LEHMER_LLT returns the Cholesky factor of the LEHMER matrix. c c Licensing: c c This code is distributed under the GNU LGPL license. c c Modified: c c 07 April 2015 c c Author: c c John Burkardt c c Reference: c c Emrah Kilic, Pantelimon Stanica, c The Lehmer matrix and its recursive analogue, c Journal of Combinatorial Mathematics and Combinatorial Computing, c Volume 74, August 2010, pages 193-205. c c Parameters: c c Input, integer N, the order of the matrix. c c Output, double precision A(N,N), the matrix. c implicit none integer n double precision a(n,n) integer i integer j do j = 1, n do i = 1, j - 1 a(i,j) = 0.0D+00 end do do i = j, n a(i,j) = sqrt ( dble ( 2 * j - 1 ) ) / dble ( i ) end do end do return end subroutine lehmer_plu ( n, p, l, u ) c*********************************************************************72 c cc LEHMER_PLU returns the PLU factors of the LEHMER matrix. c c Licensing: c c This code is distributed under the GNU LGPL license. c c Modified: c c 07 April 2015 c c Author: c c John Burkardt c c Reference: c c Emrah Kilic, Pantelimon Stanica, c The Lehmer matrix and its recursive analogue, c Journal of Combinatorial Mathematics and Combinatorial Computing, c Volume 74, August 2010, pages 193-205. c c Parameters: c c Input, integer N, the order of the matrix. c c Output, double precision P(N,N), L(N,N), U(N,N), the PLU factors. c implicit none integer n integer i integer j double precision l(n,n) double precision p(n,n) double precision u(n,n) do j = 1, n do i = 1, n if ( i .eq. j ) then p(i,j) = 1.0D+00 else p(i,j) = 0.0D+00 end if end do end do do j = 1, n do i = 1, j - 1 l(i,j) = 0.0D+00 end do l(j,j) = 1.0D+00 do i = j + 1, n l(i,j) = dble ( j ) / dble ( i ) end do end do do j = 1, n do i = 1, j u(i,j) = dble ( 2 * i - 1 ) / dble ( i * j ) end do do i = j + 1, n u(i,j) = 0.0D+00 end do end do return end subroutine leslie ( b, di, da, a ) c*********************************************************************72 c cc LESLIE returns the LESLIE matrix. c c Discussion: c c This matrix is used in population dynamics. c c Formula: c c 5/6 * ( 1.0D+00 - DI ) 0 B 0 c 1/6 * ( 1.0D+00 - DI ) 13/14 0 0 c 0 1/14 39/40 0 c 0 0 1/40 9/10 * ( 1 - DA ) c c Discussion: c c A human population is assumed to be grouped into the categories: c c X(1) = between 0 and 5+ c X(2) = between 6 and 19+ c X(3) = between 20 and 59+ c X(4) = between 60 and 69+ c c Humans older than 69 are ignored. Deaths occur in the 60 to 69 c year bracket at a relative rate of DA per year, and in the 0 to 5 c year bracket at a relative rate of DI per year. Deaths do not occurr c in the other two brackets. c c Births occur at a rate of B relative to the population in the c 20 to 59 year bracket. c c Thus, given the population vector X in a given year, the population c in the next year will be A * X. c c Licensing: c c This code is distributed under the GNU LGPL license. c c Modified: c c 21 June 2011 c c Author: c c John Burkardt c c Reference: c c Ke Chen, Peter Giblin, Alan Irving, c Mathematical Explorations with MATLAB, c Cambridge University Press, 1999, c ISBN: 0-521-63920-4. c c Parameters: c c Input, double precision B, DI, DA, the birth rate, infant mortality rate, c and aged mortality rate. These should be positive values. c The mortality rates must be between 0.0D+00 and 1.0. Reasonable c values might be B = 0.025, DI = 0.010, and DA = 0.100 c c Output, double precision A(4,4), the matrix. c implicit none double precision a(4,4) double precision b double precision da double precision di if ( b .lt. 0.0D+00 ) then write ( *, '(a)' ) ' ' write ( *, '(a)' ) 'LESLIE - Fatal error!' write ( *, '(a)' ) ' 0 <= B is required.' stop 1 end if if ( da .lt. 0.0D+00 .or. 1.0D+00 .lt. da ) then write ( *, '(a)' ) ' ' write ( *, '(a)' ) 'LESLIE - Fatal error!' write ( *, '(a)' ) ' 0 <= DA <= 1.0D+00 is required.' stop 1 end if if ( di .lt. 0.0D+00 .or. 1.0D+00 .lt. di ) then write ( *, '(a)' ) ' ' write ( *, '(a)' ) 'LESLIE - Fatal error!' write ( *, '(a)' ) ' 0 <= DI <= 1.0D+00 is required.' stop 1 end if a(1,1) = 5.0D+00 * ( 1.0D+00 - di ) / 6.0D+00 a(1,2) = 0.0D+00 a(1,3) = b a(1,4) = 0.0D+00 a(2,1) = ( 1.0D+00 - di ) / 6.0D+00 a(2,2) = 13.0D+00 / 14.0D+00 a(2,3) = 0.0D+00 a(2,4) = 0.0D+00 a(3,1) = 0.0D+00 a(3,2) = 1.0D+00 / 14.0D+00 a(3,3) = 39.0D+00 / 40.0D+00 a(3,4) = 0.0D+00 a(4,1) = 0.0D+00 a(4,2) = 0.0D+00 a(4,3) = 1.0D+00 / 40.0D+00 a(4,4) = 9.0D+00 * ( 1.0D+00 - da ) / 10.0D+00 return end subroutine leslie_determinant ( b, di, da, determ ) c*********************************************************************72 c cc LESLIE_DETERMINANT returns the determinant of the LESLIE matrix. c c Discussion: c c DETERM = a(4,4) * ( c a(1,1) * a(2,2) * a(3,3) c + a(1,3) * a(2,1) * a(3,2) ) c c Licensing: c c This code is distributed under the GNU LGPL license. c c Modified: c c 21 June 2011 c c Author: c c John Burkardt c c Parameters: c c Input, double precision B, DI, DA, the birth rate, infant mortality rate, c and aged mortality rate. These should be positive values. c The mortality rates must be between 0.0D+00 and 1.0. Reasonable c values might be B = 0.025, DI = 0.010, and DA = 0.100 c c Output, double precision DETERM, the determinant. c implicit none double precision a(4,4) double precision b double precision da double precision determ double precision di determ = 9.0D+00 * ( 1.0D+00 - da ) / 10.0D+00 * & ( & 5.0D+00 * ( 1.0D+00 - di ) / 6.0D+00 & * 13.0D+00 / 14.0D+00 & * 39.0D+00 / 40.0D+00 & + b & * ( 1.0D+00 - di ) / 6.0D+00 & * 1.0D+00 / 14.0D+00 & ) return end subroutine lesp ( m, n, a ) c*********************************************************************72 c cc LESP returns the LESP matrix. c c Formula: c c if ( I - J .eq. 1 ) then c A(I,J) = 1 / I c else if ( I - J .eq. 0 ) then c A(I,J) = - ( 2*I+3 ) c else if ( I - J .eq. 1 ) then c A(I,J) = J c else c A(I,J) = 0.0D+00 c c Example: c c M = 5, N = 5 c c -5 2 . . . c 1/2 -7 3 . . c . 1/3 -9 4 . c . . 1/4 -11 5 c . . . 1/5 -13 c c c Properties: c c The matrix is tridiagonal. c c Because A is tridiagonal, it has property A (bipartite). c c A is generally not symmetric: A' /= A. c c The eigenvalues are real, and smoothly distributed in [-2*N-3.5, -4.5]. c c The eigenvalues are sensitive. c c The matrix is similar to the symmetric tridiagonal matrix with c the same diagonal entries and with off-diagonal entries 1, c via a similarity transformation using the diagonal matrix c D = diagonal ( 1!, 2!, ..., N! ). c c The family of matrices is nested as a function of N. c c Licensing: c c This code is distributed under the GNU LGPL license. c c Modified: c c 21 June 2011 c c Author: c c John Burkardt c c Reference: c c Wim Lenferink, MN Spijker, c On the use of stability regions in the numerical analysis of initial c value problems, c Mathematics of Computation, c Volume 57, 1991, pages 221-237. c c Lloyd Trefethen, c Pseudospectra of matrices, c in Numerical Analysis 1991, c Proceedings of the 14th Dundee Conference, c D F Griffiths and G A Watson, editors, c Pitman Research Notes in Mathematics, volume 260, c Longman Scientific and Technical, Essex, UK, 1992, pages 234-266. c c Parameters: c c Input, integer M, N, the order of the matrix. c c Output, double precision A(M,N), the matrix. c implicit none integer m integer n double precision a(m,n) integer i integer j do j = 1, n do i = 1, m if ( i - j .eq. 1 ) then a(i,j) = 1.0D+00 / dble ( i ) else if ( i - j .eq. 0 ) then a(i,j) = - dble ( 2 * i + 3 ) else if ( i - j .eq. -1 ) then a(i,j) = dble ( j ) else a(i,j) = 0.0D+00 end if end do end do return end subroutine lesp_determinant ( n, determ ) c*********************************************************************72 c cc LESP_DETERMINANT computes the determinant of the LESP matrix. c c Licensing: c c This code is distributed under the GNU LGPL license. c c Modified: c c 21 June 2011 c c Author: c c John Burkardt c c Parameters: c c Input, integer N, the order of the matrix. c c Output, double precision DETERM, the determinant. c implicit none integer n double precision determ double precision determ_nm1 double precision determ_nm2 integer i determ_nm1 = - dble ( 2 * n + 3 ) if ( n .eq. 1 ) then determ = determ_nm1 return end if determ_nm2 = determ_nm1 determ_nm1 = dble ( 2 * n + 1 ) * dble ( 2 * n + 3 ) - 1.0D00 if ( n .eq. 2 ) then determ = determ_nm1 return end if do i = n - 2, 1, -1 determ = - dble ( 2 * i + 3 ) * determ_nm1 - determ_nm2 determ_nm2 = determ_nm1 determ_nm1 = determ end do return end subroutine lesp_inverse ( n, a ) c*********************************************************************72 c cc LESP_INVERSE returns the inverse of the LESP matrix. c c Discussion: c c This computation is an application of the TRIV_INVERSE function. c c Example: c c N = 5 c -0.2060 -0.0598 -0.0201 -0.0074 -0.0028 c -0.0150 -0.1495 -0.0504 -0.0184 -0.0071 c -0.0006 -0.0056 -0.1141 -0.0418 -0.0161 c -0.0000 -0.0001 -0.0026 -0.0925 -0.0356 c -0.0000 -0.0000 -0.0000 -0.0014 -0.0775 c c Licensing: c c This code is distributed under the GNU LGPL license. c c Modified: c c 09 April 2015 c c Author: c c John Burkardt c c Reference: c c CM daFonseca, J Petronilho, c Explicit Inverses of Some Tridiagonal Matrices, c Linear Algebra and Its Applications, c Volume 325, 2001, pages 7-21. c c Parameters: c c Input, integer N, the order of the matrix. c c Output, double precision A(N,N), the inverse of the matrix. c implicit none integer n double precision a(n,n) integer i double precision x(n-1) double precision y(n) double precision z(n-1) do i = 1, n - 1 x(i) = 1.0D+00 / dble ( i + 1 ) end do do i = 1, n y(i) = dble ( - 2 * i - 3 ) end do do i = 1, n - 1 z(i) = dble ( i + 1 ) end do call triv_inverse ( n, x, y, z, a ) return end subroutine lietzke ( n, a ) c*********************************************************************72 c cc LIETZKE returns the LIETZKE matrix. c c Formula: c c A(I,J) = N - abs ( I - J ) c c Example: c c N = 5 c c 5 4 3 2 1 c 4 5 4 3 2 c 3 4 5 4 3 c 2 3 4 5 4 c 1 2 3 4 5 c c Properties: c c A is integral, therefore det ( A ) is integral, and c det ( A ) * inverse ( A ) is integral. c c A is symmetric: A' = A. c c Because A is symmetric, it is normal. c c Because A is normal, it is diagonalizable. c c det ( A ) = ( n + 1 ) * 2^( n - 2 ) c c Licensing: c c This code is distributed under the GNU LGPL license. c c Modified: c c 21 June 2011 c c Author: c c John Burkardt c c Reference: c c M Lietzke, R Stoughton, Marjorie Lietzke, c A Comparison of Seeral Method for Inverting Large Symmetric c Positive Definite Matrics, c Mathematics of Computation, c Volume 18, Number 87, pages 449-456. c c Parameters: c c Input, integer N, the order of the matrix. c c Output, double precision A(N,N), the matrix. c implicit none integer n double precision a(n,n) integer i integer j do j = 1, n do i = 1, n a(i,j) = dble ( n - abs ( i - j ) ) end do end do return end subroutine lietzke_condition ( n, value ) c*********************************************************************72 c cc LIETZKE_CONDITION returns the L1 condition of the LIETZKE matrix. c c Licensing: c c This code is distributed under the GNU LGPL license. c c Modified: c c 08 April 2015 c c Author: c c John Burkardt c c Parameters: c c Input, integer N, the order of the matrix. c c Output, double precision VALUE, the L1 condition. c implicit none double precision a_norm double precision b_norm integer i integer k integer n integer s double precision value s = 0 k = n do i = 1, n s = s + k if ( mod ( i, 2 ) .eq. 1 ) then k = k - 1 end if end do a_norm = dble ( s ) if ( n .eq. 1 ) then b_norm = 0.25D+00 else if ( n .eq. 2 ) then b_norm = 5.0D+00 / 6.0D+00 else b_norm = 2.0D+00 end if value = a_norm * b_norm return end subroutine lietzke_determinant ( n, determ ) c*********************************************************************72 c cc LIETZKE_DETERMINANT returns the determinant of the LIETZKE matrix. c c Licensing: c c This code is distributed under the GNU LGPL license. c c Modified: c c 21 June 2011 c c Author: c c John Burkardt c c Parameters: c c Input, integer N, the order of the matrix. c c Output, double precision DETERM, the determinant. c implicit none double precision determ integer n determ = dble ( n + 1 ) * dble ( 2 ** ( n - 2 ) ) return end subroutine lietzke_inverse ( n, a ) c*********************************************************************72 c cc LIETZKE_INVERSE returns the inverse of the LIETZKE matrix. c c Example: c c N = 5 c c 0.5833 -0.5000 0 0 0.0833 c -0.5000 1.0000 -0.5000 0 0 c 0 -0.5000 1.0000 -0.5000 0 c 0 0 -0.5000 1.0000 -0.5000 c 0.0833 0 0 -0.5000 0.5833 c c Licensing: c c This code is distributed under the GNU LGPL license. c c Modified: c c 21 June 2011 c c Author: c c John Burkardt c c Parameters: c c Input, integer N, the order of the matrix. c c Output, double precision A(N,N), the matrix. c implicit none integer n double precision a(n,n) integer i integer j do j = 1, n do i = 1, n a(i,j) = 0.0D+00 end do end do a(1,1) = dble ( n + 2 ) / dble ( 2 * n + 2 ) do i = 2, n - 1 a(i,i) = 1.0D+00 end do a(n,n) = dble ( n + 2 ) / dble ( 2 * n + 2 ) if ( n .eq. 2 ) then do i = 1, n - 1 a(i,i+1) = - 1.0D+00 / 3.0D+00 end do do i = 2, n a(i,i-1) = - 1.0D+00 / 3.0D+00 end do else do i = 1, n - 1 a(i,i+1) = - 0.5D+00 end do do i = 2, n a(i,i-1) = - 0.5D+00 end do end if a(1,n) = 1.0D+00 / dble ( 2 * n + 2 ) a(n,1) = 1.0D+00 / dble ( 2 * n + 2 ) return end subroutine lights_out ( row_num, col_num, n, a ) c*********************************************************************72 c cc LIGHTS_OUT returns the LIGHTS_OUT matrix. c c Discussion: c c This is the adjacency matrix for a set of points arranged in c an ROW_NUM by COL_NUM grid, with the addition of a self-edge c at each node. c c Diagram: c c ROW_NUM = 4, COL_NUM = 3 c c 1---5---9 c | | | c 2---6--10 c | | | c 3---7--11 c | | | c 4---8--12 c c Example: c c ROW_NUM = 4, COL_NUM = 3 c c 1 1 0 0 1 0 0 0 0 0 0 0 c 1 1 1 0 0 1 0 0 0 0 0 0 c 0 1 1 1 0 0 1 0 0 0 0 0 c 0 0 1 1 1 0 0 1 0 0 0 0 c c 1 0 0 0 1 1 0 0 1 0 0 0 c 0 1 0 0 1 1 1 0 0 1 0 0 c 0 0 1 0 0 1 1 1 0 0 1 0 c 0 0 0 1 0 0 1 1 0 0 0 1 c c 0 0 0 0 1 0 0 0 1 1 0 0 c 0 0 0 0 0 1 0 0 1 1 1 0 c 0 0 0 0 0 0 1 0 0 1 1 1 c 0 0 0 0 0 0 0 1 0 0 1 1 c c Discussion: c c A game called "Lights Out" comprises a 5 by 5 array of lights. c Initially, a random subset of the lights are on, and the player's c task is to turn all the lights off. Pressing any light c reverses the state of that light and its immediate neighbors to c the north, south, east and west. c c The "Lights Out" matrix summarizes the relationships between c the lights. We represent any configuration of lights c by a vector B0 of 1's and 0's. If we want to push light 17, c say, then we make a vector X which is all zero, except for a c 1 in entry 17. We multiply this perturbation matrix by A, c to get the vector, or list, A*X, of all the lights that switch c their state, and we use this to update B. c c In particular, if we agree to do arithmetic modulo 2, then c the new state B1 can be computed by c c B1 = B0 + A*X (mod 2) c c Note that if we plan to push 10 buttons, we can calculate the c final result by computing each change, or we can simply have c the vector X record all the buttons we are going to push, and c do the calculation in a single step. c c Thus, if we start with all the lights on, and we want to end c with all the lights off, we are asking for the solubility c of the system c c 1 + A*X = 0 (mod 2) c c or, equivalently, c c A*X = 1 (mod 2) c c Thus, if A has full rank, we can always solve the system, c but if it has null vectors, there will be some configurations of c lights that we cannot shut down. c c In some versions of the game, "wrap-around" is allowed, so that c lights on the extreme right boundary can affect lights on the c extreme left, and similarly for lights at the top and bottom. c c Properties: c c A is symmetric: A' = A. c c Because A is symmetric, it is normal. c c Because A is normal, it is diagonalizable. c c A is a zero/one matrix. c c A is integral, therefore det ( A ) is integral, and c det ( A ) * inverse ( A ) is integral. c c A is block tridiagonal. c c A is an adjacency matrix. c c For ROW_NUM = COL_NUM, the dimension of the null space of A is: c c ROW_NUM N Null c c 2 4 0 c 3 9 0 c 4 16 4 c 5 25 2 c 6 36 0 c 7 49 0 c 8 64 0 c 9 81 8 c 10 100 0 c 11 121 6 c 12 144 0 c 13 169 0 c 14 196 4 c 15 225 0 c 16 256 8 c 17 289 2 c 18 324 0 c 19 361 16 c 20 400 0 c 21 441 0 c c Licensing: c c This code is distributed under the GNU LGPL license. c c Modified: c c 21 June 2011 c c Author: c c John Burkardt c c Reference: c c Marlow Anderson, Todd Feil, c Turning Lights Out With Linear Algebra, c Mathematics Magazine, c Volume 71, Number 4, October 1998, pages 300-303. c c Parameters: c c Input, integer ROW_NUM, COL_NUM, the number of rows and c columns in the underlying array. c c Input, integer N, the order of the matrix. c N = ROW_NUM * COL_NUM. c c Output, double precision A(N,N), the matrix. c implicit none integer n integer row_num double precision a(n,n) double precision b(row_num,row_num) integer col_num integer i integer i_block integer ilo integer j integer j_block integer jlo do j = 1, n do i = 1, n a(i,j) = 0.0D+00 end do end do do j_block = 1, col_num jlo = ( j_block - 1 ) * row_num do i_block = 1, col_num ilo = ( i_block - 1 ) * row_num if ( j_block .eq. i_block ) then call line_loop_adj ( row_num, b ) else if ( abs ( j_block - i_block ) .eq. 1 ) then call identity ( row_num, row_num, b) else call zero ( row_num, row_num, b ) end if do j = 1, row_num do i = 1, row_num a(ilo+i,jlo+j) = b(i,j) end do end do end do end do return end subroutine line_adj ( n, a ) c*********************************************************************72 c cc LINE_ADJ returns the LINE_ADJ matrix. c c Discussion: c c The matrix describes the adjacency of points on a line. c c Example: c c N = 5 c c 0 1 0 0 0 c 1 0 1 0 0 c 0 1 0 1 0 c 0 0 1 0 1 c 0 0 0 1 0 c c Properties: c c A is symmetric: A' = A. c c Because A is symmetric, it is normal. c c Because A is normal, it is diagonalizable. c c A is tridiagonal. c c A is a special case of the TRIS or tridiagonal scalar matrix. c c Because A is tridiagonal, it has property A (bipartite). c c A is banded, with bandwidth 3. c c A is an adjacency matrix for a set of points arranged in a line. c c A has a zero diagonal. c c A is a zero/one matrix. c c The row and column sums are all 2, except for the first and last c rows and columns which have a sum of 1. c c A is singular if N is odd. c c det ( A ) = 0, -1, 0, +1, as mod ( N, 4 ) = 1, 2, 3 or 0. c c The family of matrices is nested as a function of N. c c Licensing: c c This code is distributed under the GNU LGPL license. c c Modified: c c 13 June 2011 c c Author: c c John Burkardt c c Parameters: c c Input, integer N, the order of the matrix. c c Output, double precision A(N,N), the matrix. c implicit none integer n double precision a(n,n) integer i integer j do j = 1, n do i = 1, n if ( j .eq. i - 1 ) then a(i,j) = 1.0D+00 else if ( j .eq. i + 1 ) then a(i,j) = 1.0D+00 else a(i,j) = 0.0D+00 end if end do end do return end subroutine line_adj_determinant ( n, determ ) c*********************************************************************72 c cc LINE_ADJ_DETERMINANT returns the determinant of the LINE_ADJ matrix. c c Licensing: c c This code is distributed under the GNU LGPL license. c c Modified: c c 13 June 2011 c c Author: c c John Burkardt c c Parameters: c c Input, integer N, the order of the matrix. c c Output, double precision DETERM, the determinant. c implicit none double precision determ integer n if ( mod ( n, 4 ) .eq. 1 ) then determ = 0.0D+00 else if ( mod ( n, 4 ) .eq. 2 ) then determ = - 1.0D+00 else if ( mod ( n, 4 ) .eq. 3 ) then determ = 0.0D+00 else if ( mod ( n, 4 ) .eq. 0 ) then determ = + 1.0D+00 end if return end subroutine line_adj_eigen_right ( n, a ) c*********************************************************************72 c cc LINE_ADJ_EIGEN_RIGHT returns right eigenvectors of the LINE_ADJ matrix. c c Licensing: c c This code is distributed under the GNU LGPL license. c c Modified: c c 06 April 2015 c c Author: c c John Burkardt c c Parameters: c c Input, integer N, the order of the matrix. c c Output, double precision A(N,N), the right eigenvector matrix. c implicit none integer n double precision a(n,n) double precision angle integer i integer j double precision r8_pi parameter ( r8_pi = 3.141592653589793D+00 ) do j = 1, n do i = 1, n angle = dble ( i * j ) * r8_pi / dble ( n + 1 ) a(i,j) = sqrt ( 2.0D+00 / dble ( n + 1 ) ) * sin ( angle ) end do end do return end subroutine line_adj_eigenvalues ( n, lambda ) c*********************************************************************72 c cc LINE_ADJ_EIGENVALUES returns the eigenvalues of the LINE_ADJ matrix. c c Licensing: c c This code is distributed under the GNU LGPL license. c c Modified: c c 13 June 2011 c c Author: c c John Burkardt c c Parameters: c c Input, integer N, the order of the matrix. c c Output, double precision LAMBDA(N), the eigenvalues. c implicit none integer n double precision angle integer i double precision lambda(n) double precision r8_pi parameter ( r8_pi = 3.141592653589793D+00 ) do i = 1, n angle = dble ( i ) * r8_pi / dble ( n + 1 ) lambda(i) = 2.0D+00 * cos ( angle ) end do return end subroutine line_adj_inverse ( n, a ) c*********************************************************************72 c cc LINE_ADJ_INVERSE returns the inverse of the LINE_ADJ matrix. c c Example: c c N = 6: c c 0 1 0 -1 0 1 c 1 0 0 0 0 0 c 0 0 0 1 0 -1 c -1 0 1 0 0 0 c 0 0 0 0 0 1 c 1 0 -1 0 1 0 c c Licensing: c c This code is distributed under the GNU LGPL license. c c Modified: c c 17 April 2015 c c Author: c c John Burkardt c c Parameters: c c Input, integer N, the order of the matrix. c c Output, double precision A(N,N), the matrix. c implicit none integer n double precision a(n,n) integer i integer j double precision p if ( mod ( n, 2 ) .eq. 1 ) then write ( *, '(a)' ) ' ' write ( *, '(a)' ) 'LINE_ADJ_INVERSE - Fatal error!' write ( *, '(a)' ) ' The matrix is singular for odd N.' stop 1 end if do j = 1, n do i = 1, n a(i,j) = 0.0D+00 end do end do do i = 1, n if ( mod ( i, 2 ) .eq. 1 ) then do j = i, n - 1, 2 if ( j .eq. i ) then p = 1.0D+00 else p = - p end if a(i,j+1) = p a(j+1,i) = p end do end if end do return end subroutine line_adj_null_left ( m, n, x ) c*********************************************************************72 c cc LINE_ADJ_NULL_LEFT returns a left null vector of the LINE_ADJ matrix. c c Licensing: c c This code is distributed under the GNU LGPL license. c c Modified: c c 13 March 2015 c c Author: c c John Burkardt c c Parameters: c c Input, integer M, N, the order of the matrix. c c Output, double precision X(M), a null vector c implicit none integer m integer n integer i double precision x(m) if ( mod ( m, 2 ) .eq. 0 ) then write ( *, '(a)' ) ' ' write ( *, '(a)' ) 'LINE_ADJ_NULL_RIGHT - Fatal error!' write ( *, '(a)' ) ' For M even, there is no null vector.' stop 1 end if do i = 1, m, 4 x(i) = 1.0D+00 end do do i = 2, m, 2 x(i) = 0.0D+00 end do do i = 3, m, 4 x(i) = -1.0D+00 end do return end subroutine line_adj_null_right ( m, n, x ) c*********************************************************************72 c cc LINE_ADJ_NULL_RIGHT returns a right null vector of the LINE_ADJ matrix. c c Licensing: c c This code is distributed under the GNU LGPL license. c c Modified: c c 13 June 2011 c c Author: c c John Burkardt c c Parameters: c c Input, integer M, N, the order of the matrix. c c Output, double precision X(N), a null vector c implicit none integer m integer n integer i double precision x(n) if ( mod ( n, 2 ) .eq. 0 ) then write ( *, '(a)' ) ' ' write ( *, '(a)' ) 'LINE_ADJ_NULL_RIGHT - Fatal error!' write ( *, '(a)' ) ' For N even, there is no null vector.' stop 1 end if do i = 1, n, 4 x(i) = 1.0D+00 end do do i = 2, n, 2 x(i) = 0.0D+00 end do do i = 3, n, 4 x(i) = -1.0D+00 end do return end subroutine line_loop_adj ( n, a ) c*********************************************************************72 c cc LINE_LOOP_ADJ returns the LINE_LOOP_ADJ matrix. c c Discussion: c c The matrix describes the adjacency of points on a loop. c c Example: c c N = 5 c c 1 1 0 0 0 c 1 1 1 0 0 c 0 1 1 1 0 c 0 0 1 1 1 c 0 0 0 1 1 c c Properties: c c A is symmetric: A' = A. c c Because A is symmetric, it is normal. c c Because A is normal, it is diagonalizable. c c A is tridiagonal. c c A is a special case of the TRIS or tridiagonal scalar matrix. c c Because A is tridiagonal, it has property A (bipartite). c c A is banded, with bandwidth 3. c c A is an adjacency matrix for a set of points arranged in a line. c c A is a zero/one matrix. c c The row and column sums are all 3, except for the first and last c rows and columns which have a sum of 2. c c The family of matrices is nested as a function of N. c c Licensing: c c This code is distributed under the GNU LGPL license. c c Modified: c c 13 June 2011 c c Author: c c John Burkardt c c Parameters: c c Input, integer N, the order of the matrix. c c Output, double precision A(N,N), the matrix. c implicit none integer n double precision a(n,n) integer i integer j do j = 1, n do i = 1, n if ( j .eq. i - 1 ) then a(i,j) = 1.0D+00 else if ( j .eq. i ) then a(i,j) = 1.0D+00 else if ( j .eq. i + 1 ) then a(i,j) = 1.0D+00 else a(i,j) = 0.0D+00 end if end do end do return end subroutine line_loop_adj_determinant ( n, determ ) c*********************************************************************72 c cc LINE_LOOP_ADJ_DETERMINANT: the determinant of the LINE_LOOP_ADJ matrix. c c Licensing: c c This code is distributed under the GNU LGPL license. c c Modified: c c 25 October 2007 c c Author: c c John Burkardt c c Parameters: c c Input, integer N, the order of the matrix. c c Output, double precision DETERM, the determinant. c implicit none integer n double precision angle double precision determ integer i double precision r8_pi parameter ( r8_pi = 3.141592653589793D+00 ) if ( mod ( n, 2 ) .eq. 1 ) then determ = 0.0D+00 else determ = 1.0D+00 do i = 1, n angle = dble ( i ) * r8_pi / dble ( n + 1 ) determ = determ * ( 1.0D+00 + 2.0D+00 * cos ( angle ) ) end do end if return end subroutine line_loop_adj_eigen_right ( n, a ) c*********************************************************************72 c cc LINE_LOOP_ADJ_EIGEN_RIGHT:right eigenvectors of the LINE_LOOP_ADJ matrix. c c Licensing: c c This code is distributed under the GNU LGPL license. c c Modified: c c 06 April 2015 c c Author: c c John Burkardt c c Parameters: c c Input, integer N, the order of the matrix. c c Output, double precision A(N,N), the right eigenvector matrix. c implicit none integer n double precision a(n,n) double precision angle integer i integer j double precision r8_pi parameter ( r8_pi = 3.141592653589793D+00 ) do j = 1, n do i = 1, n angle = dble ( i * j ) * r8_pi / dble ( n + 1 ) a(i,j) = sqrt ( 2.0D+00 / dble ( n + 1 ) ) * sin ( angle ) end do end do return end subroutine line_loop_adj_eigenvalues ( n, lambda ) c*********************************************************************72 c cc LINE_LOOP_ADJ_EIGENVALUES: the eigenvalues of the LINE_LOOP_ADJ matrix. c c Licensing: c c This code is distributed under the GNU LGPL license. c c Modified: c c 13 June 2011 c c Author: c c John Burkardt c c Parameters: c c Input, integer N, the order of the matrix. c c Output, double precision LAMBDA(N), the eigenvalues. c implicit none integer n double precision angle integer i double precision lambda(n) double precision r8_pi parameter ( r8_pi = 3.141592653589793D+00 ) do i = 1, n angle = dble ( i ) * r8_pi / dble ( n + 1 ) lambda(i) = 1.0D+00 + 2.0D+00 * cos ( angle ) end do return end subroutine loewner ( w, x, y, z, n, a ) c*********************************************************************72 c cc LOEWNER returns the LOEWNER matrix. c c Formula: c c A(I,J) = ( W(I) - X(J) ) / ( Y(I) - Z(J) ) c c Example: c c N = 3 c W = (/ 8, 4, 9 /) c X = (/ 1, 2, 3 /) c Y = (/ 9, 6, 4 /) c Z = (/ 2, 3, 1 /) c c A = c c 8 - 1 8 - 2 8 - 3 c ----- ----- ----- c 9 - 2 9 - 3 9 - 1 c c 4 - 1 4 - 2 4 - 3 c ----- ----- ----- c 6 - 2 6 - 3 6 - 1 c c 9 - 1 9 - 2 9 - 3 c ----- ----- ----- c 4 - 2 4 - 3 4 - 1 c c = c c 7/7 6/6 5/8 c c 3/4 2/3 1/5 c c 8/2 7/1 6/3 c c Properties: c c A is generally not symmetric: A' /= A. c c The family of matrices is nested as a function of N. c c Licensing: c c This code is distributed under the GNU LGPL license. c c Modified: c c 21 June 2011 c c Author: c c John Burkardt c c Parameters: c c Input, double precision W(N), X(N), Y(N), Z(N), vectors defining c the matrix. c c Input, integer N, the order of the matrix. c c Output, double precision A(N,N), the matrix. c implicit none integer n double precision a(n,n) integer i integer j double precision w(n) double precision x(n) double precision y(n) double precision z(n) do j = 1, n do i = 1, n if ( y(i) - z(j) .eq. 0.0D+00 ) then write ( *, '(a)' ) ' ' write ( *, '(a)' ) 'LOEWNER - Fatal error!' write ( *, '(a)' ) ' Y(I) = Z(J).' stop 1 end if a(i,j) = ( w(i) - x(j) ) / ( y(i) - z(j) ) end do end do return end subroutine lotkin ( m, n, a ) c*********************************************************************72 c cc LOTKIN returns the LOTKIN matrix. c c Formula: c c if ( I = 1 ) c A(I,J) = 1 c else c A(I,J) = 1 / ( I + J - 1 ) c c Example: c c N = 5 c c 1 1 1 1 1 c 1/2 1/3 1/4 1/5 1/6 c 1/3 1/4 1/5 1/6 1/7 c 1/4 1/5 1/6 1/7 1/8 c 1/5 1/6 1/7 1/8 1/9 c c Properties: c c A is the Hilbert matrix with the first row set to all 1's. c c A is generally not symmetric: A' /= A. c c A is ill-conditioned. c c A has many negative eigenvalues of small magnitude. c c The inverse of A has all integer elements, and is known explicitly. c c For N = 6, the eigenvalues are: c 2.132376, c -0.2214068, c -0.3184330 D-1, c -0.8983233 D-3, c -0.1706278 D-4, c -0.1394499 D-6. c c det ( A(N) ) = ( -1 )^(N-1) / DELTA(N) c c where c c DELTA(N) = CHOOSE ( 2*N-2, N-2 ) * CHOOSE ( 2*N-2, N-1 ) c * ( 2*N-1) * DELTA(N-1), c DELTA(1) = 1. c c The family of matrices is nested as a function of N. c c Licensing: c c This code is distributed under the GNU LGPL license. c c Modified: c c 21 June 2011 c c Author: c c John Burkardt c c Reference: c c Robert Gregory, David Karney, c A Collection of Matrices for Testing Computational Algorithms, c Wiley, 1969, c ISBN: 0882756494, c LC: QA263.G68. c c Max Lotkin, c A set of test matrices, c Mathematics Tables and Other Aids to Computation, c Volume 9, 1955, pages 153-161. c c Joan Westlake, c A Handbook of Numerical Matrix Inversion and Solution of c Linear Equations, c John Wiley, 1968, c ISBN13: 978-0471936756, c LC: QA263.W47. c c Parameters: c c Input, integer M, N, the order of the matrix. c c Output, double precision A(M,N), the matrix. c implicit none integer m integer n double precision a(m,n) integer i integer j do j = 1, n do i = 1, m if ( i .eq. 1 ) then a(i,j) = 1.0D+00 else a(i,j) = 1.0D+00 / dble ( i + j - 1 ) end if end do end do return end subroutine lotkin_determinant ( n, determ ) c*********************************************************************72 c cc LOTKIN_DETERMINANT returns the determinant of the LOTKIN matrix. c c Licensing: c c This code is distributed under the GNU LGPL license. c c Modified: c c 21 June 2011 c c Author: c c John Burkardt c c Parameters: c c Input, integer N, the order of the matrix. c c Output, double precision DETERM, the determinant. c implicit none integer n double precision delta double precision determ integer i double precision r8_choose delta = 1.0D+00 do i = 2, n delta = - r8_choose ( 2 * i - 2, i - 2 ) & * r8_choose ( 2 * i - 2, i - 1 ) & * ( 2 * i - 1 ) * delta end do determ = 1.0D+00 / delta return end subroutine lotkin_inverse ( n, a ) c*********************************************************************72 c cc LOTKIN_INVERSE returns the inverse of the LOTKIN matrix. c c Licensing: c c This code is distributed under the GNU LGPL license. c c Modified: c c 21 June 2011 c c Author: c c John Burkardt c c Parameters: c c Input, integer N, the order of the matrix. c c Output, double precision A(N,N), the matrix. c implicit none integer n double precision a(n,n) integer i integer j double precision r8_choose double precision r8_mop do j = 1, n do i = 1, n if ( j .eq. 1 ) then a(i,j) = r8_mop ( n - i ) & * r8_choose ( n + i - 1, i - 1 ) & * r8_choose ( n, i ) else a(i,j) = r8_mop ( i - j + 1 ) * dble ( i ) & * r8_choose ( i + j - 1, j - 1 ) & * r8_choose ( i + j - 2, j - 2 ) & * r8_choose ( n + i - 1, i + j - 1 ) & * r8_choose ( n + j - 1, i + j - 1 ) end if end do end do return end subroutine magic ( n, a ) c*********************************************************************72 c cc MAGIC returns a magic matrix. c c Discussion: c c The entries of A are the integers from 1 to N*N, each occurring once. c The row and column sums of A are all equal to N*(N*N+1)/2. c c What about the diagonals? c c The algorithms used are derived from ACM algorithms 117 and 118, c which in turn are derived from Kraitchik. c c There is no 2 by 2 magic square. c c Example: c c N = 3 c c 8 3 4 c 1 5 9 c 6 7 2 c c Properties: c c A is generally not symmetric: A' /= A. c c A is integral, therefore det ( A ) is integral, and c det ( A ) * inverse ( A ) is integral. c c A is a multiple of a doubly stochastic matrix. c c Because it has a constant row sum of N*(N*N+1)/2, c A has an eigenvalue of N*(N*N+1)/2. c and a right eigenvector of ( 1, 1, 1, ..., 1 ). c c Because it has a constant column sum of N*(N*N+1)/2, c A has an eigenvalue of N*(N*N+1)/2. c and a left eigenvector of ( 1, 1, 1, ..., 1 ). c c Licensing: c c This code is distributed under the GNU LGPL license. c c Modified: c c 21 June 2011 c c Author: c c Original FORTRAN77 version by David Collison. c This FORTRAN77 version by John Burkardt c c Reference: c c David Collison, c Algorithms 117 and 118: c Magic square (even order) and Magic square (odd order), c Communications of the ACM, c Volume 5, Number 8, pages 435-436. c c Maurice Kraitchik, c Mathematical Recreations, c Norton, 1942, pages 149-152. c c Parameters: c c Input, integer N, the order of the matrix. N must not be 2. c c Output, double precision A(N,N), the matrix. c implicit none integer n double precision a(n,n) if ( n .le. 0 ) then write ( *, '(a)' ) ' ' write ( *, '(a)' ) 'MAGIC - Fatal error!' write ( *, '(a,i8)' ) ' Nonpositive value of N = ', n stop 1 else if ( n .eq. 1 ) then a(1,1) = 1.0D+00 else if ( n .eq. 2 ) then write ( *, '(a)' ) ' ' write ( *, '(a)' ) 'MAGIC - Fatal error!' write ( *, '(a)' ) ' There is no 2 by 2 magic square.' stop 1 else if ( mod ( n, 2 ) .eq. 0 ) then call magic_even ( n, a ) else call magic_odd ( n, a ) end if return end subroutine magic_a ( n, a, i, j, k, bool ) c*********************************************************************72 c cc MAGIC_A is a utility routine for magic square computations. c c Licensing: c c This code is distributed under the GNU LGPL license. c c Modified: c c 21 June 2011 c c Author: c c Original FORTRAN77 version by David Collison. c This FORTRAN77 version by John Burkardt c c Reference: c c David Collison, c Algorithms 117 and 118: c Magic square (even order) and Magic square (odd order), c Communications of the ACM, c Volume 5, Number 8, pages 435-436. c c Parameters: c c Input, integer N, the order of the matrix. N must not be 2. c c Input/output, double precision A(N,N), ... c c Input, integer I, ? c c Input, integer J, ? c c Input, integer K, ? c c Input, logical BOOL, ? c implicit none integer n double precision a(n,n) logical bcopy logical bool integer i integer j integer k integer l bcopy = bool do l = i, j if ( bcopy ) then a(l,k) = k * n - n + l else a(l,k) = n * n - k * n + 1 + n - l end if bcopy = .not. bcopy end do return end subroutine magic_b ( n, a, i, j, k, bool ) c*********************************************************************72 c cc MAGIC_B is a utility routine for magic square computations. c c Licensing: c c This code is distributed under the GNU LGPL license. c c Modified: c c 21 June 2011 c c Author: c c Original FORTRAN77 version by David Collison. c This FORTRAN77 version by John Burkardt c c Reference: c c David Collison, c Algorithms 117 and 118: c Magic square (even order) and Magic square (odd order), c Communications of the ACM, c Volume 5, Number 8, pages 435-436. c c Parameters: c c Input, integer N, the order of the matrix. N must not be 2. c c Input/output, double precision A(N,N), ... c c Input, integer I, ? c c Input, integer J, ? c c Input, integer K, ? c c Input, logical BOOL, ? c implicit none integer n double precision a(n,n) logical bcopy logical bool integer i integer j integer k integer l bcopy = bool do l = i, j if ( bcopy ) then a(l,k) = n * n - k * n + l else a(l,k) = k * n + 1 - l end if bcopy = .not. bcopy end do return end subroutine magic_bimarkov ( n, a ) c*********************************************************************72 c cc MAGIC_BIMARKOV returns a magic biMarkov matrix. c c Discussion: c c The matrix returned will be magic (row sums = column sums = diagonal c sums) and biMarkov ( row sums = 1, column sums = 1 ). c c There is no 2 by 2 magic square. c c Example: c c N = 3 c c 8/15 3/15 4/15 c 1/15 5/15 9/15 c 6/15 7/15 2/15 c c Properties: c c A is generally not symmetric: A' /= A. c c A is magic. c c A is biMarkov. c c A is positive. c c Licensing: c c This code is distributed under the GNU LGPL license. c c Modified: c c 21 June 2011 c c Author: c c John Burkardt c c Parameters: c c Input, integer N, the order of the matrix. N must not be 2. c c Output, double precision A(N,N), the matrix. c implicit none integer n double precision a(n,n) integer i integer j double precision rsum if ( n .le. 0 ) then write ( *, '(a)' ) ' ' write ( *, '(a)' ) 'MAGIC_BIMARKOV - Fatal error!' write ( *, '(a,i8)' ) ' Nonpositive value of N = ', n stop 1 else if ( n .eq. 1 ) then a(1,1) = 1.0D+00 else if ( n .eq. 2 ) then write ( *, '(a)' ) ' ' write ( *, '(a)' ) 'MAGIC_BIMARKOV - Fatal error!' write ( *, '(a)' ) ' There is no 2 by 2 magic square.' stop 1 else call magic ( n, a ) rsum = 0.0D+00 do i = 1, n rsum = rsum + a(i,1) end do do j = 1, n do i = 1, n a(i,j) = a(i,j) / rsum end do end do end if return end subroutine magic_c ( n, a, i, j, k, bool ) c*********************************************************************72 c cc MAGIC_C is a utility routine for magic square computations. c c Licensing: c c This code is distributed under the GNU LGPL license. c c Modified: c c 21 June 2011 c c Author: c c Original FORTRAN77 version by David Collison. c This FORTRAN77 version by John Burkardt c c Reference: c c David Collison, c Algorithms 117 and 118: c Magic square (even order) and Magic square (odd order), c Communications of the ACM, c Volume 5, Number 8, pages 435-436. c c Parameters: c c Input, integer N, the order of the matrix. N must not be 2. c c Input/output, double precision A(N,N), ... c c Input, integer I, ? c c Input, integer J, ? c c Input, integer K, ? c c Input, logical BOOL, ? c implicit none integer n double precision a(n,n) logical bcopy logical bool integer i integer j integer k integer l bcopy = bool do l = i, j if ( bcopy ) then a(l,k) = n * n - k * n + n - l + 1 else a(l,k) = k * n + 1 - l end if bcopy = .not. bcopy end do return end subroutine magic_even ( n, a ) c*********************************************************************72 c cc MAGIC_EVEN constructs a magic square for the case where N is even. c c Licensing: c c This code is distributed under the GNU LGPL license. c c Modified: c c 21 June 2011 c c Author: c c Original FORTRAN77 version by David Collison. c This FORTRAN77 version by John Burkardt c c Reference: c c David Collison, c Algorithms 117 and 118: c Magic square (even order) and Magic square (odd order), c Communications of the ACM, c Volume 5, Number 8, pages 435-436. c c Parameters: c c Input, integer N, the order of the matrix. N must not be 2. c c Output, double precision A(N,N), the matrix. c implicit none integer n double precision a(n,n) integer i integer j integer n2 integer n_square logical p logical q logical r n2 = n / 2 n_square = n * n p = mod ( n, 4 ) .eq. 0 q = p r = .true. do i = 1, n2 - 1 call magic_b ( n, a, 1, i - 1, i, r ) call magic_a ( n, a, i, n2 - 1, i, .true. ) if ( q ) then a(n2,i) = n_square - i * n + n2 + 1 else a(n2,i) = n_square - i * n + n2 end if call magic_a ( n, a, n2+1, n, i, .not.q ) q = .not. q r = .not. r end do call magic_a ( n, a, 1, n2 - 1, n2, .not.p ) call magic_a ( n, a, n2 + 2, n, n2, .false. ) call magic_c ( n, a, 1, n2 - 1, n2 + 1, p ) call magic_c ( n, a, n2 + 2, n, n2 + 1, .true. ) q = p r = .true. do i = n2 + 2, n call magic_b ( n, a, 1, n - i, i, q ) a(n-i+1,i) = i * n - i + 1 call magic_b ( n, a, n-i+2, n2-1, i, .true. ) if ( r ) then a(n2,i) = n_square - i*n+n-n2+1 a(n2+1,i) = n_square - i*n+n-(n2+1)+1 else a(n2,i) = n_square - i * n + n2 a(n2+1,i) = i * n - n2 + 1 end if call magic_b ( n, a, n2+2, i-1, i, .not.r ) call magic_a ( n, a, i, n, i, .true. ) q = .not. q r = .not. r end do do i = n2, n2+1 do j = n2, n2+1 if ( p ) then a(j,i) = i * n - n + j else a(j,i) = n_square - i * n + n - j + 1 end if end do end do if ( .not. p ) then a(n2-1,n2) = n2 * n - n2 + 2 a(n2-1,n2+1) = ( n2 + 1 ) * n - n2 + 2 a(n2,n2+2) = n * n2 - 2 * n + n2 a(n2+1,n2+2) = n * n2 - 2 * n + n2 + 1 end if return end subroutine magic_odd ( n, a ) c*********************************************************************72 c cc MAGIC_ODD constructs a magic square for the case where N is odd. c c Licensing: c c This code is distributed under the GNU LGPL license. c c Modified: c c 21 June 2011 c c Author: c c Original FORTRAN77 version by David Collison. c This FORTRAN77 version by John Burkardt c c Reference: c c David Collison, c Algorithms 117 and 118: c Magic square (even order) and Magic square (odd order), c Communications of the ACM, c Volume 5, Number 8, pages 435-436. c c Parameters: c c Input, integer N, the order of the matrix. N must not be 2. c c Output, double precision A(N,N), the matrix. c implicit none integer n double precision a(n,n) integer i integer j integer k do j = 1, n do i = 1, n a(i,j) = 0.0D+00 end do end do i = ( n + 1 ) / 2 j = n do k = 1, n * n if ( a(i,j) .ne. 0.0D+00 ) then i = i - 1 if ( i .lt. 1 ) then i = i + n end if j = j - 2 if ( j .lt. 1 ) then j = j + n end if end if a(i,j) = dble ( k ) i = i + 1 if ( n .lt. i ) then i = i - n end if j = j + 1 if ( n .lt. j ) then j = j - n end if end do return end subroutine markov_random ( n, key, a ) c*********************************************************************72 c cc MARKOV_RANDOM returns the MARKOV_RANDOM matrix. c c Discussion: c c A Markov matrix, also called a "stochastic" matrix, is distinguished c by two properties: c c * All matrix entries are nonnegative; c * The sum of the entries in each row is 1. c c A "transition matrix" is the transpose of a Markov matrix, and c has column sums equal to 1. c c Example: c c N = 4 c c 1/10 2/10 3/10 4/10 c 1 0 0 0 c 5/10 2/10 3/10 0 c 2/10 2/10 2/10 4/10 c c Properties: c c A is generally not symmetric: A' /= A. c c 0 <= A(I,J) <= 1.0D+00 for every I and J. c c The sum of the entries in each row of A is 1. c c Because it has a constant row sum of 1, c A has an eigenvalue of 1, and c a right eigenvector of ( 1, 1, 1, ..., 1 ). c c All the eigenvalues of A have modulus no greater than 1. c c The eigenvalue 1 lies on the boundary of all the Gerschgorin rowsum disks. c c Licensing: c c This code is distributed under the GNU LGPL license. c c Modified: c c 21 June 2011 c c Author: c c John Burkardt c c Parameters: c c Input, integer N, the order of the matrix. c c Input, integer KEY, a positive integer that selects the data. c c Output, double precision A(N,N), the matrix. c implicit none integer n double precision a(n,n) integer i integer j integer key double precision row_sum integer seed seed = key call r8mat_uniform_01 ( n, n, seed, a ) do i = 1, n row_sum = 0.0D+00 do j = 1, n row_sum = row_sum + a(i,j) end do do j = 1, n a(i,j) = a(i,j) / row_sum end do end do return end subroutine maxij ( m, n, a ) c*********************************************************************72 c cc MAXIJ returns the MAXIJ matrix. c c Discussion: c c This matrix is occasionally known as the "Boothroyd MAX" matrix. c c Formula: c c A(I,J) = max(I,J) c c Example: c c N = 5 c c 1 2 3 4 5 c 2 2 3 4 5 c 3 3 3 4 5 c 4 4 4 4 5 c 5 5 5 5 5 c c Properties: c c A is integral, therefore det ( A ) is integral, and c det ( A ) * inverse ( A ) is integral. c c A is symmetric: A' = A. c c Because A is symmetric, it is normal. c c Because A is normal, it is diagonalizable. c c The inverse of A is tridiagonal. c c The family of matrices is nested as a function of N. c c Licensing: c c This code is distributed under the GNU LGPL license. c c Modified: c c 21 June 2011 c c Author: c c John Burkardt c c Reference: c c Robert Gregory, David Karney, c A Collection of Matrices for Testing Computational Algorithms, c Wiley, 1969, c ISBN: 0882756494, c LC: QA263.G68. c c Parameters: c c Input, integer M, N, the order of the matrix. c c Output, double precision A(M,N), the matrix. c implicit none integer m integer n double precision a(m,n) integer i integer j do i = 1, m do j = 1, n a(i,j) = dble ( max ( i, j ) ) end do end do return end subroutine maxij_condition ( n, cond ) c*********************************************************************72 c cc MAXIJ_CONDITION returns the L1 condition of the MAXIJ matrix. c c Licensing: c c This code is distributed under the GNU LGPL license. c c Modified: c c 26 January 2015 c c Author: c c John Burkardt c c Parameters: c c Input, integer N, the order of the matrix. c c Output, double precision COND, the L1 condition. c implicit none double precision a_norm double precision b_norm double precision cond integer n a_norm = dble ( n * n ) if ( n .eq. 1 ) then b_norm = 1.0D+00 else if ( n .eq. 2 ) then b_norm = 2.0D+00 else b_norm = 4.0D+00 end if cond = a_norm * b_norm return end subroutine maxij_determinant ( n, determ ) c*********************************************************************72 c cc MAXIJ_DETERMINANT returns the determinant of the MAXIJ matrix. c c Licensing: c c This code is distributed under the GNU LGPL license. c c Modified: c c 21 June 2011 c c Author: c c John Burkardt c c Parameters: c c Input, integer N, the order of the matrix. c c Output, double precision DETERM, the determinant. c implicit none double precision determ integer n determ = dble ( n ) return end subroutine maxij_inverse ( n, a ) c*********************************************************************72 c cc MAXIJ_INVERSE returns the inverse of the MAXIJ matrix. c c Formula: c c if ( I = 1 and J = 1 ) c A(I,J) = -1 c else if ( I = N and J = N ) c A(I,J) = -(N-1)/N c else if ( I = J ) c A(I,J) = -2 c else if ( J = I-1 or J = I + 1 ) c A(I,J) = 1 c else c A(I,J) = 0 c c Example: c c N = 5 c c -1 1 0 0 0 c 1 -2 1 0 0 c 0 1 -2 1 0 c 0 0 1 -2 1 c 0 0 0 1 -4/5 c c Properties: c c A is symmetric: A' = A. c c Because A is symmetric, it is normal. c c Because A is normal, it is diagonalizable. c c A is tridiagonal. c c Because A is tridiagonal, it has property A (bipartite). c c A is "almost" equal to the second difference matrix. c c Licensing: c c This code is distributed under the GNU LGPL license. c c Modified: c c 21 June 2011 c c Author: c c John Burkardt c c Parameters: c c Input, integer N, the order of the matrix. c c Output, double precision A(N,N), the matrix. c implicit none integer n double precision a(n,n) integer i integer j do i = 1, n do j = 1, n if ( j .eq. i ) then if ( i .eq. 1 ) then a(i,j) = - 1.0D+00 else if ( i .lt. n ) then a(i,j) = - 2.0D+00 else a(i,j) = - dble ( n - 1 ) / dble ( n ) end if else if ( j .eq. i - 1 .or. j .eq. i + 1 ) then a(i,j) = 1.0D+00 else a(i,j) = 0.0D+00 end if end do end do return end subroutine maxij_plu ( n, p, l, u ) c*********************************************************************72 c cc MAXIJ_PLU returns the PLU factors of the MAXIJ matrix. c c Licensing: c c This code is distributed under the GNU LGPL license. c c Modified: c c 26 June 2011 c c Author: c c John Burkardt c c Parameters: c c Input, integer N, the order of the matrix. c c Output, double precision P(N,N), L(N,N), U(N,N), the PLU factors. c implicit none integer n integer i integer i4_wrap integer j double precision l(n,n) double precision p(n,n) double precision u(n,n) do j = 1, n do i = 1, n if ( i4_wrap ( j - i, 1, n ) .eq. 1 ) then p(i,j) = 1.0D+00 else p(i,j) = 0.0D+00 end if end do end do i = 1 j = 1 l(i,j) = 1.0D+00 j = 1 do i = 2, n l(i,j) = dble ( i - 1 ) / dble ( n ) end do do j = 2, n do i = 1, j - 1 l(i,j) = 0.0D+00 end do l(j,j) = 1.0D+00 do i = j + 1, n l(i,j) = 0.0D+00 end do end do i = 1 do j = 1, n u(i,j) = dble ( n ) end do do i = 2, n do j = 1, i - 1 u(i,j) = 0.0D+00 end do do j = i, n u(i,j) = dble ( j + 1 - i ) end do end do return end function mertens ( n ) c*********************************************************************72 c cc MERTENS evaluates the Mertens function. c c Discussion: c c The Mertens function M(N) is the sum from 1 to N of the Moebius c function MU. That is, c c M(N) = sum ( 1 <= I <= N ) MU(I) c c N M(N) c -- ---- c 1 1 c 2 0 c 3 -1 c 4 -1 c 5 -2 c 6 -1 c 7 -2 c 8 -2 c 9 -2 c 10 -1 c 11 -2 c 12 -2 c 100 1 c 1000 2 c 10000 -23 c 100000 -48 c c The determinant of the Redheffer matrix of order N is equal c to the Mertens function M(N). c c Licensing: c c This code is distributed under the GNU LGPL license. c c Modified: c c 05 July 2008 c c Author: c c John Burkardt c c Reference: c c M Deleglise, J Rivat, c Computing the Summation of the Moebius Function, c Experimental Mathematics, c Volume 5, 1996, pages 291-295. c c Eric Weisstein, c CRC Concise Encyclopedia of Mathematics, c CRC Press, 2002, c Second edition, c ISBN: 1584883472, c LC: QA5.W45 c c Parameters: c c Input, integer N, the argument. c c Output, integer MERTENS, the value. c implicit none integer i integer mertens integer mu_i integer n integer value value = 0 do i = 1, n call moebius ( i, mu_i ) value = value + mu_i end do mertens = value return end subroutine mertens_values ( n_data, n, c ) c*********************************************************************72 c cc MERTENS_VALUES returns some values of the Mertens function. c c Discussion: c c The Mertens function M(N) is the sum from 1 to N of the Moebius c function MU. c c Licensing: c c This code is distributed under the GNU LGPL license. c c Modified: c c 01 Decemberr 2007 c c Author: c c John Burkardt c c Reference: c c Marc Deleglise, Joel Rivat, c Computing the Summation of the Moebius Function, c Experimental Mathematics, c Volume 5, 1996, pages 291-295. c c Eric Weisstein, c CRC Concise Encyclopedia of Mathematics, c CRC Press, 2002, c Second edition, c ISBN: 1584883472, c LC: QA5.W45. c c Parameters: c c Input/output, integer N_DATA. c On input, if N_DATA is 0, the first test data is returned, and N_DATA c is set to 1. On each subsequent call, the input value of N_DATA is c incremented and that test data item is returned, if available. When c there is no more test data, N_DATA is set to 0. c c Output, integer N, the argument of the Mertens function. c c Output, integer C, the value of the Mertens function. c implicit none integer nmax parameter ( nmax = 15 ) integer c integer c_vec(nmax) integer n integer n_data integer n_vec(nmax) save c_vec save n_vec data c_vec / & 1, 0, -1, -1, -2, -1, -2, -2, -2, -1, & -2, -2, 1, 2, -23 / data n_vec / & 1, 2, 3, 4, 5, 6, 7, 8, 9, 10, & 11, 12, 100, 1000, 10000 / if ( n_data .lt. 0 ) then n_data = 0 end if n_data = n_data + 1 if ( nmax .lt. n_data ) then n_data = 0 n = 0 c = 0 else n = n_vec(n_data) c = c_vec(n_data) end if return end subroutine milnes ( m, n, x, a ) c*********************************************************************72 c cc MILNES returns the MILNES matrix. c c Formula: c c If ( I <= J ) c A(I,J) = 1 c else c A(I,J) = X(J) c c Example: c c M = 5, N = 5, X = ( 4, 7, 3, 8 ) c c 1 1 1 1 1 c 4 1 1 1 1 c 4 7 1 1 1 c 4 7 3 1 1 c 4 7 3 8 1 c c M = 3, N = 6, X = ( 5, 7 ) c c 1 1 1 1 1 c 5 1 1 1 1 c 5 7 1 1 1 c c M = 5, N = 3, X = ( 5, 7, 8 ) c c 1 1 1 c 5 1 1 c 5 7 1 c 5 7 8 c 5 7 8 c c Properties: c c A is generally not symmetric: A' /= A. c c det ( A ) = ( 1 - X(1) ) * ( 1 - X(2) ) * ... * ( 1 - X(N-1) ). c c A is singular if and only if X(I) = 1 for any I. c c The family of matrices is nested as a function of N. c c Licensing: c c This code is distributed under the GNU LGPL license. c c Modified: c c 22 June 2011 c c Author: c c John Burkardt c c Reference: c c Robert Gregory, David Karney, c A Collection of Matrices for Testing Computational Algorithms, c Wiley, 1969, c ISBN: 0882756494, c LC: QA263.G68. c c Parameters: c c Input, integer M, N, the order of the matrix. c c Input, double precision X(*), the lower column values. c If M <= N, then X should be dimensioned M-1. c If N < M, X should be dimensioned N. c c Output, double precision A(M,N), the matrix. c implicit none integer m integer n double precision a(m,n) integer i integer j double precision x(*) do i = 1, m do j = 1, n if ( i .le. j ) then a(i,j) = 1.0D+00 else a(i,j) = x(j) end if end do end do return end subroutine milnes_determinant ( n, x, determ ) c*********************************************************************72 c cc MILNES_DETERMINANT returns the determinant of the MILNES matrix. c c Licensing: c c This code is distributed under the GNU LGPL license. c c Modified: c c 22 June 2011 c c Author: c c John Burkardt c c Parameters: c c Input, integer N, the order of the matrix. c c Input, double precision X(N-1), the lower column values. c c Output, double precision DETERM, the determinant. c implicit none integer n double precision determ integer i double precision x(n-1) if ( n .eq. 1 ) then determ = 1.0D+00 else determ = 1.0D+00 do i = 1, n - 1 determ = determ * ( 1.0D+00 - x(i) ) end do end if return end subroutine milnes_inverse ( n, x, a ) c*********************************************************************72 c cc MILNES_INVERSE returns the inverse of the MILNES matrix. c c Licensing: c c This code is distributed under the GNU LGPL license. c c Modified: c c 22 June 2011 c c Author: c c John Burkardt c c Reference: c c Robert Gregory, David Karney, c A Collection of Matrices for Testing Computational Algorithms, c Wiley, 1969, c ISBN: 0882756494, c LC: QA263.G68. c c Parameters: c c Input, integer N, the order of the matrix. c c Input, double precision X(N-1), the lower column values. c c Output, double precision A(N,N), the matrix. c implicit none integer n double precision a(n,n) integer i integer j double precision x(n-1) do i = 1, n do j = 1, n if ( i .eq. j .and. i .ne. n ) then a(i,j) = 1.0D+00 / ( 1.0D+00 - x(i) ) else if ( j .eq. i + 1 .and. i .ne. n ) then a(i,j) = -1.0D+00 / ( 1.0D+00 - x(i) ) else if ( i .eq. n .and. j .ne. 1 .and. j .ne. n ) then a(i,j) = ( x(j-1) - x(j) ) / & ( ( 1.0D+00 - x(j) ) * (1.0D+00 - x(j-1) ) ) else if ( i .eq. n .and. j .eq. 1 ) then a(i,j) = -x(1) / ( 1.0D+00 - x(1) ) else if ( i .eq. n .and. j .eq. n ) then a(i,j) = 1.0D+00 / ( 1.0D+00 - x(n-1) ) else a(i,j) = 0.0D+00 end if end do end do return end subroutine minij ( m, n, a ) c*********************************************************************72 c cc MINIJ returns the MINIJ matrix. c c Discussion: c c See page 158 of the Todd reference. c c Formula: c c A(I,J) = min ( I, J ) c c Example: c c N = 5 c c 1 1 1 1 1 c 1 2 2 2 2 c 1 2 3 3 3 c 1 2 3 4 4 c 1 2 3 4 5 c c Properties: c c A is integral, therefore det ( A ) is integral, and c det ( A ) * inverse ( A ) is integral. c c A is positive definite. c c A is symmetric: A' = A. c c Because A is symmetric, it is normal. c c Because A is normal, it is diagonalizable. c c The inverse of A is tridiagonal. c c The eigenvalues of A are c c LAMBDA(I) = 0.5 / ( 1 - cos ( ( 2 * I - 1 ) * pi / ( 2 * N + 1 ) ) ), c c For N = 12, the characteristic polynomial is c P(X) = X^12 - 78 X^11 + 1001 X^10 - 5005 X^9 + 12870 X^8 c - 19448 X^7 + 18564 X^6 - 11628 X^5 + 4845 X^4 - 1330 X^3 c + 231 X^2 - 23 X + 1. c c (N+1)*ONES(N) - A also has a tridiagonal inverse. c c Gregory and Karney consider the matrix defined by c c B(I,J) = N + 1 - MAX(I,J) c c which is equal to the MINIJ matrix, but with the rows and c columns reversed. c c The family of matrices is nested as a function of N. c c Licensing: c c This code is distributed under the GNU LGPL license. c c Modified: c c 11 June 2011 c c Author: c c John Burkardt c c Reference: c c Robert Gregory, David Karney, c A Collection of Matrices for Testing Computational Algorithms, c Wiley, 1969, c ISBN: 0882756494, c LC: QA263.G68. c c Daniel Rutherford, c Some continuant determinants arising in physics and chemistry II, c Proceedings of the Royal Society Edinburgh, c Volume 63, A, 1952, pages 232-241. c c John Todd, c Basic Numerical Mathematics, c Volume 2: Numerical Algebra, c Birkhauser, 1980, c ISBN: 0817608117, c LC: QA297.T58. c c Joan Westlake, c A Handbook of Numerical Matrix Inversion and Solution of c Linear Equations, c John Wiley, 1968, c ISBN13: 978-0471936756, c LC: QA263.W47. c c Parameters: c c Input, integer M, N, the order of the matrix. c c Output, double precision A(M,N), the matrix. c implicit none integer m integer n double precision a(m,n) integer i integer j do i = 1, m do j = 1, n a(i,j) = dble ( min ( i, j ) ) end do end do return end subroutine minij_condition ( n, cond ) c*********************************************************************72 c cc MINIJ_CONDITION returns the L1 condition of the MINIJ matrix. c c Licensing: c c This code is distributed under the GNU LGPL license. c c Modified: c c 29 January 2015 c c Author: c c John Burkardt c c Parameters: c c Input, integer N, the order of the matrix. c c Output, double precision COND, the L1 condition. c implicit none integer n double precision a_norm double precision b_norm double precision cond a_norm = dble ( n * ( n + 1 ) ) / 2.0D+00 if ( n .eq. 1 ) then b_norm = 1.0D+00 else if ( n .eq. 2 ) then b_norm = 3.0D+00 else b_norm = 4.0D+00 end if cond = a_norm * b_norm return end subroutine minij_determinant ( n, determ ) c*********************************************************************72 c cc MINIJ_DETERMINANT returns the determinant of the MINIJ matrix. c c Licensing: c c This code is distributed under the GNU LGPL license. c c Modified: c c 11 June 2011 c c Author: c c John Burkardt c c Parameters: c c Input, integer N, the order of the matrix. c c Output, double precision DETERM, the determinant. c implicit none integer n double precision angle double precision determ integer i double precision r8_pi parameter ( r8_pi = 3.141592653589793D+00 ) determ = 1.0D+00 do i = 1, n angle = dble ( 2 * i - 1 ) * r8_pi / dble ( 2 * n + 1 ) determ = determ * 0.5D+00 / ( 1.0D+00 - cos ( angle ) ) end do return end subroutine minij_eigenvalues ( n, lambda ) c*********************************************************************72 c cc MINIJ_EIGENVALUES returns the eigenvalues of the MINIJ matrix. c c Licensing: c c This code is distributed under the GNU LGPL license. c c Modified: c c 11 June 2011 c c Author: c c John Burkardt c c Parameters: c c Input, integer N, the order of the matrix. c c Output, double precision LAMBDA(N), the eigenvalues. c implicit none integer n double precision angle integer i double precision lambda(n) double precision r8_pi parameter ( r8_pi = 3.141592653589793D+00 ) do i = 1, n angle = dble ( 2 * i - 1 ) * r8_pi / dble ( 2 * n + 1 ) lambda(i) = 0.5D+00 / ( 1.0D+00 - cos ( angle ) ) end do return end subroutine minij_inverse ( n, a ) c*********************************************************************72 c cc MINIJ_INVERSE returns the inverse of the MINIJ matrix. c c Formula: c c A(I,J) = -1 if J=I-1 or J=I+1 c A(I,J) = 2 if J=I and J is not N. c A(I,J) = 1 if J=I and J=N. c A(I,J) = 0 otherwise c c Example: c c N = 5 c c 2 -1 0 0 0 c -1 2 -1 0 0 c 0 -1 2 -1 0 c 0 0 -1 2 -1 c 0 0 0 -1 1 c c Properties: c c A is symmetric: A' = A. c c Because A is symmetric, it is normal. c c Because A is normal, it is diagonalizable. c c A is tridiagonal. c c Because A is tridiagonal, it has property A (bipartite). c c A is banded, with bandwidth 3. c c A is integral, therefore det ( A ) is integral, and c det ( A ) * inverse ( A ) is integral. c c A is "almost" equal to the second difference matrix, c as computed by DIF. c c Licensing: c c This code is distributed under the GNU LGPL license. c c Modified: c c 11 June 2011 c c Author: c c John Burkardt c c Parameters: c c Input, integer N, the order of the matrix. c c Output, double precision A(N,N), the matrix. c implicit none integer n double precision a(n,n) integer i integer j do i = 1, n do j = 1, n if ( i .eq. j ) then if ( i .lt. n ) then a(i,j) = 2.0D+00 else a(i,j) = 1.0D+00 end if else if ( i .eq. j + 1 .or. i .eq. j - 1 ) then a(i,j) = -1.0D+00 else a(i,j) = 0.0D+00 end if end do end do return end subroutine minij_llt ( n, a ) c*********************************************************************72 c cc MINIJ_LLT returns the Cholesky factor of the MINIJ matrix. c c Example: c c N = 5 c c 1 0 0 0 0 c 1 1 0 0 0 c 1 1 1 0 0 c 1 1 1 1 0 c 1 1 1 1 1 c c Licensing: c c This code is distributed under the GNU LGPL license. c c Modified: c c 11 June 2011 c c Author: c c John Burkardt c c Parameters: c c Input, integer N, the order of the matrix. c c Output, double precision A(N,N), the matrix. c implicit none integer n double precision a(n,n) integer i integer j do i = 1, n do j = 1, i a(i,j) = 1.0D+00 end do do j = i + 1, n a(i,j) = 0.0D+00 end do end do return end subroutine minij_plu ( n, p, l, u ) c*********************************************************************72 c cc MINIJ_PLU returns the PLU factors of the MINIJ matrix. c c Licensing: c c This code is distributed under the GNU LGPL license. c c Modified: c c 11 June 2011 c c Author: c c John Burkardt c c Parameters: c c Input, integer N, the order of the matrix. c c Output, double precision P(N,N), L(N,N), U(N,N) the PLU factors. c implicit none integer n integer i integer j double precision l(n,n) double precision p(n,n) double precision u(n,n) do j = 1, n do i = 1, n if ( i .eq. j ) then p(i,j) = 1.0D+00 else p(i,j) = 0.0D+00 end if end do end do do j = 1, n do i = 1, j - 1 l(i,j) = 0.0D+00 end do do i = j, n l(i,j) = 1.0D+00 end do end do do j = 1, n do i = 1, j u(i,j) = 1.0D+00 end do do i = j + 1, n u(i,j) = 0.0D+00 end do end do return end subroutine moebius ( n, mu ) c*********************************************************************72 c cc MOEBIUS returns the value of MU(N), the Moebius function of N. c c Discussion: c c MU(N) is defined as follows: c c MU(N) = 1 if N = 1; c 0 if N is divisible by the square of a prime; c (-1)**K, if N is the product of K distinct primes. c c As special cases, MU(N) is -1 if N is a prime, and MU(N) is 0 c if N is a square, cube, etc. c c The Moebius function MU(D) is related to Euler's totient c function PHI(N): c c PHI(N) = sum ( D divides N ) MU(D) * ( N / D ). c c First values: c c N MU(N) c c 1 1 c 2 -1 c 3 -1 c 4 0 c 5 -1 c 6 1 c 7 -1 c 8 0 c 9 0 c 10 1 c 11 -1 c 12 0 c 13 -1 c 14 1 c 15 1 c 16 0 c 17 -1 c 18 0 c 19 -1 c 20 0 c c Licensing: c c This code is distributed under the GNU LGPL license. c c Modified: c c 20 January 2007 c c Author: c c John Burkardt c c Parameters: c c Input, integer N, the value to be analyzed. c c Output, integer MU, the value of MU(N). c If N is less than or equal to 0, MU will be returned as -2. c If there was not enough internal space for factoring, MU c is returned as -3. c implicit none integer maxfactor parameter ( maxfactor = 20 ) integer exponent(maxfactor) integer factor(maxfactor) integer i integer mu integer n integer nfactor integer nleft if ( n .le. 0 ) then mu = -2 return end if if ( n .eq. 1 ) then mu = 1 return end if c c Factor N. c call i4_factor ( n, maxfactor, nfactor, factor, exponent, nleft ) if ( nleft .ne. 1 ) then write ( *, '(a)' ) ' ' write ( *, '(a)' ) 'MOEBIUS - Fatal error!' write ( *, '(a)' ) ' Not enough factorization space.' mu = -3 return end if mu = 1 do i = 1, nfactor mu = -mu if ( 1 .lt. exponent(i) ) then mu = 0 return end if end do return end subroutine moebius_values ( n_data, n, c ) c*********************************************************************72 c cc MOEBIUS_VALUES returns some values of the Moebius function. c c Discussion: c c MU(N) is defined as follows: c c MU(N) = 1 if N = 1; c 0 if N is divisible by the square of a prime; c (-1)**K, if N is the product of K distinct primes. c c In Mathematica, the function can be evaluated by: c c MoebiusMu[n] c c The Moebius function is related to Euler's totient function: c c PHI(N) = Sum ( D divides N ) MU(D) * ( N / D ). c c First values: c c N MU(N) c c 1 1 c 2 -1 c 3 -1 c 4 0 c 5 -1 c 6 1 c 7 -1 c 8 0 c 9 0 c 10 1 c 11 -1 c 12 0 c 13 -1 c 14 1 c 15 1 c 16 0 c 17 -1 c 18 0 c 19 -1 c 20 0 c c Note that, as special cases, MU(N) is -1 if N is a prime, and MU(N) is 0 c if N is a square, cube, etc. c c Licensing: c c This code is distributed under the GNU LGPL license. c c Modified: c c 24 March 2007 c c Author: c c John Burkardt c c Reference: c c Milton Abramowitz, Irene Stegun, c Handbook of Mathematical Functions, c National Bureau of Standards, 1964, c ISBN: 0-486-61272-4, c LC: QA47.A34. c c Stephen Wolfram, c The Mathematica Book, c Fourth Edition, c Cambridge University Press, 1999, c ISBN: 0-521-64314-7, c LC: QA76.95.W65. c c Parameters: c c Input/output, integer N_DATA. The user sets N_DATA to 0 before the c first call. On each call, the routine increments N_DATA by 1, and c returns the corresponding data; when there is no more data, the c output value of N_DATA will be 0 again. c c Output, integer N, the argument of the Moebius function. c c Output, integer C, the value of the Moebius function. c implicit none integer n_max parameter ( n_max = 20 ) integer c integer c_vec(n_max) integer n integer n_data integer n_vec(n_max) save c_vec save n_vec data c_vec / & 1, -1, -1, 0, -1, 1, -1, 0, 0, 1, & -1, 0, -1, 1, 1, 0, -1, 0, -1, 0 / data n_vec / & 1, 2, 3, 4, 5, 6, 7, 8, 9, 10, & 11, 12, 13, 14, 15, 16, 17, 18, 19, 20 / if ( n_data .lt. 0 ) then n_data = 0 end if n_data = n_data + 1 if ( n_max .lt. n_data ) then n_data = 0 n = 0 c = 0 else n = n_vec(n_data) c = c_vec(n_data) end if return end subroutine moler1 ( alpha, m, n, a ) c*********************************************************************72 c cc MOLER1 returns the MOLER1 matrix. c c Formula: c c If ( I = J ) c A(I,J) = min ( I-1, J-1 ) * ALPHA^2 + 1 c else c A(I,J) = min ( I-1, J-1 ) * ALPHA^2 + ALPHA c c Example: c c ALPHA = 2, N = 5 c c 1 2 2 2 2 c 2 5 6 6 6 c 2 6 9 10 10 c 2 6 10 13 14 c 2 6 10 14 17 c c Properties: c c Successive elements of each diagonal increase by an increment of ALPHA^2. c c A is the product of B' * B, where B is the matrix returned by c c CALL TRIW ( ALPHA, N-1, N, B ). c c A is symmetric: A' = A. c c Because A is symmetric, it is normal. c c Because A is normal, it is diagonalizable. c c A is positive definite. c c If ALPHA = -1, A(I,J) = min ( I, J ) - 2, A(I,I)=I. c c A has one small eigenvalue. c c If ALPHA is integral, then A is integral. c If A is integral, then det ( A ) is integral, and c det ( A ) * inverse ( A ) is integral. c c The family of matrices is nested as a function of N. c c Licensing: c c This code is distributed under the GNU LGPL license. c c Modified: c c 12 June 2011 c c Author: c c John Burkardt c c Reference: c c John Nash, c Compact Numerical Methods for Computers: Linear Algebra and c Function Minimisation, c Second Edition, c Taylor & Francis, 1990, c ISBN: 085274319X, c LC: QA184.N37. c c Parameters: c c Input, double precision ALPHA, the parameter. c c Input, integer M, N, the order of the matrix. c c Output, double precision A(M,N), the matrix. c implicit none integer m integer n double precision a(m,n) double precision alpha integer i integer j do i = 1, m do j = 1, n if ( i .eq. j ) then a(i,j) = dble ( min ( i-1, j-1 ) ) * alpha ** 2 + 1.0D+00 else a(i,j) = dble ( min ( i-1, j-1 ) ) * alpha ** 2 + alpha end if end do end do return end subroutine moler1_determinant ( alpha, n, determ ) c*********************************************************************72 c cc MOLER1_DETERMINANT returns the determinant of the MOLER1 matrix. c c Licensing: c c This code is distributed under the GNU LGPL license. c c Modified: c c 12 June 2011 c c Author: c c John Burkardt c c Parameters: c c Input, double precision ALPHA, the parameter. c c Input, integer N, the order of the matrix. c c Output, double precision DETERM, the determinant. c implicit none double precision alpha double precision determ integer n determ = 1.0D+00 return end subroutine moler1_inverse ( alpha, n, a ) c*********************************************************************72 c cc MOLER1_INVERSE returns the inverse of the MOLER1 matrix. c c Licensing: c c This code is distributed under the GNU LGPL license. c c Modified: c c 27 June 2011 c c Author: c c John Burkardt c c Parameters: c c Input, double precision ALPHA, the parameter. c c Input, integer N, the order of the matrix. c c Output, double precision A(N,N), the matrix. c implicit none integer n double precision a(n,n) double precision alpha double precision dot integer i integer j integer k double precision v(n) v(1) = 1.0D+00 v(2) = - alpha do i = 3, n v(i) = - ( alpha - 1.0D+00 ) * v(i-1) end do do i = 1, n do j = 1, n if ( i .le. j ) then dot = 0.0 do k = 1, n + 1 - j dot = dot + v(k+j-i) * v(k) end do a(i,j) = dot else dot = 0.0 do k = 1, n + 1 - i dot = dot + v(k) * v(k+i-j) end do a(i,j) = dot end if end do end do return end subroutine moler1_llt ( alpha, n, a ) c*********************************************************************72 c cc MOLER1_LLT returns the lower triangular Cholesky factor of the MOLER1 matrix. c c Example: c c ALPHA = 2, N = 5 c c 1 0 0 0 0 c 2 1 0 0 0 c 2 2 1 0 0 c 2 2 2 1 0 c 2 2 2 2 1 c c Licensing: c c This code is distributed under the GNU LGPL license. c c Modified: c c 16 March 2015 c c Author: c c John Burkardt c c Parameters: c c Input, double precision ALPHA, the parameter. c c Input, integer N, the order of the matrix. c c Output, double precision A(N,N), the matrix. c implicit none integer n double precision a(n,n) double precision alpha integer i integer j do j = 1, n do i = 1, j - 1 a(i,j) = 0.0D+00 end do a(j,j) = 1.0D+00 do i = j + 1, n a(i,j) = alpha end do end do return end subroutine moler1_plu ( alpha, n, p, l, u ) c*********************************************************************72 c cc MOLER1_PLU returns the PLU factors of the MOLER1 matrix. c c Licensing: c c This code is distributed under the GNU LGPL license. c c Modified: c c 12 June 2011 c c Author: c c John Burkardt c c Reference: c c John Nash, c Compact Numerical Methods for Computers: Linear Algebra and c Function Minimisation, c Second Edition, c Taylor & Francis, 1990, c ISBN: 085274319X, c LC: QA184.N37. c c Parameters: c c Input, double precision ALPHA, the parameter. c c Input, integer N, the order of the matrix. c c Output, double precision P(N,N), L(N,N), U(N,N), the PLU factors. c implicit none integer n double precision alpha integer i integer j double precision l(n,n) double precision p(n,n) double precision u(n,n) do j = 1, n do i = 1, n if ( i .eq. j ) then p(i,j) = 1.0D+00 else p(i,j) = 0.0D+00 end if end do end do do j = 1, n do i = 1, n if ( i .eq. j ) then l(i,j) = 1.0D+00 else if ( j .lt. i ) then l(i,j) = alpha else l(i,j) = 0.0D+00 end if end do end do do j = 1, n do i = 1, n if ( i .eq. j ) then u(i,j) = 1.0D+00 else if ( i .lt. j ) then u(i,j) = alpha else u(i,j) = 0.0D+00 end if end do end do return end subroutine moler2 ( a ) c*********************************************************************72 c cc MOLER2 returns the MOLER2 matrix. c c Discussion: c c This is a 5 by 5 matrix for which the challenge is to find the EXACT c eigenvalues and eigenvectors. c c Formula: c c -9 11 -21 63 -252 c 70 -69 141 -421 1684 c -575 575 -1149 3451 -13801 c 3891 -3891 7782 -23345 93365 c 1024 -1024 2048 -6144 24572 c c Properties: c c A is defective. c c The Jordan normal form of A has just one block, with eigenvalue c zero, because A**k is nonzero for K = 0, 1, 2, 3, 4, but A**5=0. c c det ( A ) = 0. c c TRACE(A) = 0. c c Licensing: c c This code is distributed under the GNU LGPL license. c c Modified: c c 12 June 2011 c c Author: c c John Burkardt c c Parameters: c c Output, double precision A(5,5), the matrix. c implicit none double precision a(5,5) a(1,1) = -9.0D+00 a(1,2) = 11.0D+00 a(1,3) = -21.0D+00 a(1,4) = 63.0D+00 a(1,5) = -252.0D+00 a(2,1) = 70.0D+00 a(2,2) = -69.0D+00 a(2,3) = 141.0D+00 a(2,4) = -421.0D+00 a(2,5) = 1684.0D+00 a(3,1) = -575.0D+00 a(3,2) = 575.0D+00 a(3,3) = -1149.0D+00 a(3,4) = 3451.0D+00 a(3,5) = -13801.0D+00 a(4,1) = 3891.0D+00 a(4,2) = -3891.0D+00 a(4,3) = 7782.0D+00 a(4,4) = -23345.0D+00 a(4,5) = 93365.0D+00 a(5,1) = 1024.0D+00 a(5,2) = -1024.0D+00 a(5,3) = 2048.0D+00 a(5,4) = -6144.0D+00 a(5,5) = 24572.0D+00 return end subroutine moler2_determinant ( determ ) c*********************************************************************72 c cc MOLER2_DETERMINANT returns the determinant of the MOLER2 matrix. c c Licensing: c c This code is distributed under the GNU LGPL license. c c Modified: c c 12 June 2011 c c Author: c c John Burkardt c c Parameters: c c Output, double precision DETERM, the determinant. c implicit none double precision determ determ = 0.0D+00 return end subroutine moler2_eigenvalues ( lambda ) c*********************************************************************72 c cc MOLER2_EIGENVALUES returns the eigenvalues of the MOLER2 matrix. c c Licensing: c c This code is distributed under the GNU LGPL license. c c Modified: c c 12 June 2011 c c Author: c c John Burkardt c c Parameters: c c Output, double precision LAMBDA(5), the eigenvalues. c implicit none double precision lambda(5) lambda(1:5) = 0.0D+00 return end subroutine moler2_null_left ( x ) c*********************************************************************72 c cc MOLER2_NULL_LEFT returns a left null vector for the MOLER2 matrix. c c Licensing: c c This code is distributed under the GNU LGPL license. c c Modified: c c 08 March 2015 c c Author: c c John Burkardt c c Parameters: c c Output, double precision X(5), the vector. c implicit none double precision x(5) double precision x_save(5) save x_save data x_save / & 4.0D+00, -8.0D+00, 20.0D+00, -64.0D+00, 255.0D+00 / call r8vec_copy ( 5, x_save, x ) return end subroutine moler2_null_right ( x ) c*********************************************************************72 c cc MOLER2_NULL_RIGHT returns a right null vector for the MOLER2 matrix. c c Licensing: c c This code is distributed under the GNU LGPL license. c c Modified: c c 08 March 2015 c c Author: c c John Burkardt c c Parameters: c c Output, double precision X(5), the vector. c implicit none double precision x(5) double precision x_save(5) save x_save data x_save / & 0.0D+00, -21.0D+00, 142.0D+00, -973.0D+00, -256.0D+00 / call r8vec_copy ( 5, x_save, x ) return end subroutine moler3 ( m, n, a ) c*********************************************************************72 c cc MOLER3 returns the MOLER3 matrix. c c Formula: c c if ( I .eq. J ) then c A(I,J) = I c else c A(I,J) = min(I,J) - 2 c c Example: c c N = 5 c c 1 -1 -1 -1 -1 c -1 2 0 0 0 c -1 0 3 1 1 c -1 0 1 4 2 c -1 0 1 2 5 c c Properties: c c A is integral, therefore det ( A ) is integral, and c det ( A ) * inverse ( A ) is integral. c c A is positive definite. c c A is symmetric: A' = A. c c Because A is symmetric, it is normal. c c Because A is normal, it is diagonalizable. c c A has a simple Cholesky factorization. c c A has one small eigenvalue. c c The family of matrices is nested as a function of N. c c Licensing: c c This code is distributed under the GNU LGPL license. c c Modified: c c 12 June 2011 c c Author: c c John Burkardt c c Parameters: c c Input, integer M, N, the order of the matrix. c c Output, double precision A(M,N), the matrix. c implicit none integer m integer n double precision a(m,n) integer i integer j do i = 1, m do j = 1, n if ( i .eq. j ) then a(i,j) = dble ( i ) else a(i,j) = dble ( min ( i, j ) - 2 ) end if end do end do return end subroutine moler3_determinant ( n, determ ) c*********************************************************************72 c cc MOLER3_DETERMINANT returns the determinant of the MOLER3 matrix. c c Licensing: c c This code is distributed under the GNU LGPL license. c c Modified: c c 12 June 2011 c c Author: c c John Burkardt c c Parameters: c c Input, integer N, the order of the matrix. c c Output, double precision DETERM, the determinant. c implicit none double precision determ integer n determ = 1.0D+00 return end subroutine moler3_inverse ( n, a ) c*********************************************************************72 c cc MOLER3_INVERSE returns the inverse of the MOLER3 matrix. c c Licensing: c c This code is distributed under the GNU LGPL license. c c Modified: c c 29 June 2011 c c Author: c c John Burkardt c c Parameters: c c Input, integer N, the order of the matrix. c c Output, double precision A(N,N), the matrix. c implicit none integer n double precision a(n,n) integer i integer j double precision l(n,n) double precision lt(n,n) double precision value do j = 1, n do i = 1, n l(i,j) = 0.0D+00 end do end do do j = 1, n l(j,j) = 1.0D+00 value = 1.0D+00 do i = j + 1, n l(i,j) = value value = value * 2.0D+00 end do end do call r8mat_transpose ( n, n, l, lt ) call r8mat_mm ( n, n, n, lt, l, a ) return end subroutine moler3_llt ( n, a ) c*********************************************************************72 c cc MOLER3_LLT returns the Cholesky factor of the MOLER3 matrix. c c Example: c c N = 5 c c 1 0 0 0 0 c -1 1 0 0 0 c -1 -1 1 0 0 c -1 -1 -1 1 0 c -1 -1 -1 -1 1 c c Licensing: c c This code is distributed under the GNU LGPL license. c c Modified: c c 12 June 2011 c c Author: c c John Burkardt c c Parameters: c c Input, integer N, the order of the matrix. c c Output, double precision A(N,N), the matrix. c implicit none integer n double precision a(n,n) integer i integer j do i = 1, n do j = 1, i - 1 a(i,j) = -1.0D+00 end do a(i,i) = 1.0D+00 do j = i + 1, n a(i,j) = 0.0D+00 end do end do return end subroutine moler3_plu ( n, p, l, u ) c*********************************************************************72 c cc MOLER3_PLU returns the PLU factors of the MOLER3 matrix. c c Licensing: c c This code is distributed under the GNU LGPL license. c c Modified: c c 26 May 2002 c c Author: c c John Burkardt c c Parameters: c c Input, integer N, the order of the matrix. c c Output, double precision P(N,N), L(N,N), U(N,N) the PLU factors. c implicit none integer n integer i integer j double precision l(n,n) double precision p(n,n) double precision u(n,n) do j = 1, n do i = 1, n if ( i .eq. j ) then p(i,j) = 1.0D+00 else p(i,j) = 0.0D+00 end if end do end do do i = 1, n do j = 1, i - 1 l(i,j) = -1.0D+00 end do l(i,i) = 1.0D+00 do j = i + 1, n l(i,j) = 0.0D+00 end do end do do j = 1, n do i = 1, j - 1 u(i,j) = -1.0D+00 end do u(j,j) = 1.0D+00 do i = j + 1, n u(i,j) = 0.0D+00 end do end do return end subroutine moler4 ( a ) c*********************************************************************72 c cc MOLER4 returns the MOLER4 matrix. c c Example: c c 0 2 0 -1 c 1 0 0 0 c 0 1 0 0 c 0 0 1 0 c c Properties: c c A is integral, therefore det ( A ) is integral, and c det ( A ) * inverse ( A ) is integral. c c A is the companion matrix of the polynomial X^4-2X^2+1=0. c c A has eigenvalues -1, -1, +1, +1. c c A can cause problems to a standard QR algorithm, which c can fail to converge. c c Licensing: c c This code is distributed under the GNU LGPL license. c c Modified: c c 24 February 2015 c c Author: c c John Burkardt c c Parameters: c c Output, double precision A(4,4), the matrix. c implicit none double precision a(4,4) double precision a_save(4,4) save a_save c c Note that the matrix entries are listed by column. c data a_save / & 0.0D+00, 1.0D+00, 0.0D+00, 0.0D+00, & 2.0D+00, 0.0D+00, 1.0D+00, 0.0D+00, & 0.0D+00, 0.0D+00, 0.0D+00, 1.0D+00, & -1.0D+00, 0.0D+00, 0.0D+00, 0.0D+00 / call r8mat_copy ( 4, 4, a_save, a ) return end subroutine moler4_condition ( value ) c*********************************************************************72 c cc MOLER4_CONDITION returns the L1 condition of the MOLER4 matrix. c c Licensing: c c This code is distributed under the GNU LGPL license. c c Modified: c c 24 February 2015 c c Author: c c John Burkardt c c Parameters: c c Output, double precision VALUE, the L1 condition. c implicit none double precision a_norm double precision b_norm double precision value a_norm = 3.0D+00 b_norm = 3.0D+00 value = a_norm * b_norm return end subroutine moler4_determinant ( value ) c*********************************************************************72 c cc MOLER4_DETERMINANT returns the determinant of the MOLER4 matrix. c c Licensing: c c This code is distributed under the GNU LGPL license. c c Modified: c c 24 February 2015 c c Author: c c John Burkardt c c Parameters: c c Output, double precision VALUE, the determinant. c implicit none double precision value value = 1.0D+00 return end subroutine moler4_eigenvalues ( lambda ) c*********************************************************************72 c cc MOLER4_EIGENVALUES returns the eigenvalues of the MOLER4 matrix. c c Licensing: c c This code is distributed under the GNU LGPL license. c c Modified: c c 24 February 2015 c c Author: c c John Burkardt c c Parameters: c c Output, double precision LAMBDA(4), the eigenvalues. c implicit none double precision lambda(4) lambda(1) = -1.0D+00 lambda(2) = -1.0D+00 lambda(3) = +1.0D+00 lambda(4) = +1.0D+00 return end subroutine moler4_inverse ( a ) c*********************************************************************72 c cc MOLER4_INVERSE returns the inverse of the MOLER4 matrix. c c Example: c c 0 1 0 0 c 0 0 1 0 c 0 0 0 1 c -1 0 2 0 c c Licensing: c c This code is distributed under the GNU LGPL license. c c Modified: c c 24 February 2015 c c Author: c c John Burkardt c c Parameters: c c Output, double precision A(4,4), the matrix. c implicit none double precision a(4,4) double precision a_save(4,4) save a_save c c Note that the matrix entries are listed by column. c data a_save / & 0.0D+00, 0.0D+00, 0.0D+00, -1.0D+00, & 1.0D+00, 0.0D+00, 0.0D+00, 0.0D+00, & 0.0D+00, 1.0D+00, 0.0D+00, 2.0D+00, & 0.0D+00, 0.0D+00, 1.0D+00, 0.0D+00 / call r8mat_copy ( 4, 4, a_save, a ) return end subroutine neumann ( nrow, ncol, a ) c*********************************************************************72 c cc NEUMANN returns the NEUMANN matrix. c c Formula: c c I1 = 1 + ( I - 1 ) / NROW c I2 = I - ( I1 - 1 ) * NROW c J1 = 1 + ( J - 1 ) / NROW c c if ( I = J ) c A(I,J) = 4 c else If ( I = J-1 ) c If ( I2 = 1 ) c A(I,J) = -2 c else c A(I,J) = -1 c else if ( I = J+1 ) c If ( I2 = NROW ) c A(I,J) = -2 c else c A(I,J) = -1 c else if ( I = J - NROW ) c if ( J1 = 2 ) c A(I,J) = -2 c else c A(I,J) = -1 c else if ( I = J + NROW ) c if ( J1 = NCOL-1 ) c A(I,J) = -2 c else c A(I,J) = -1 c else c A(I,J) = 0.0D+00 c c Example: c c NROW = NCOL = 3 c c 4 -2 0 | -2 0 0 | 0 0 0 c -1 4 -1 | 0 -2 0 | 0 0 0 c 0 -2 4 | 0 0 -2 | 0 0 0 c ---------------------------- c -1 0 0 | 4 -1 0 | -1 0 0 c 0 -1 0 | -1 4 -1 | 0 -1 0 c 0 0 -1 | 0 -1 4 | 0 0 -1 c ---------------------------- c 0 0 0 | -2 0 0 | 4 -2 0 c 0 0 0 | 0 -2 0 | -1 4 -1 c 0 0 0 | 0 0 -2 | 0 -2 4 c c Properties: c c A is integral, therefore det ( A ) is integral, and c det ( A ) * inverse ( A ) is integral. c c A is block tridiagonal. c c A results from discretizing Neumann's equation with the c 5 point operator on a mesh of NROW by NCOL points. c c A is singular. c c A has the null vector ( 1, 1, ..., 1 ). c c det ( A ) = 0. c c Licensing: c c This code is distributed under the GNU LGPL license. c c Modified: c c 13 June 2011 c c Author: c c John Burkardt c c Reference: c c Gene Golub, Charles Van Loan, c Matrix Computations, second edition, c Johns Hopkins University Press, Baltimore, Maryland, 1989 c (Section 4.5.4). c c Parameters: c c Input, integer NROW, NCOL, the number of rows and columns c in the grid. c c Output, double precision A(NROW*NCOL,NROW*NCOL), the NROW*NCOL c by NROW*NCOL matrix. c implicit none integer ncol integer nrow double precision a(nrow*ncol,nrow*ncol) integer i integer i1 integer j integer j1 integer n n = nrow * ncol do j = 1, n do i = 1, n a(i,j) = 0.0D+00 end do end do i = 0 do i1 = 1, nrow do j1 = 1, ncol i = i + 1 if ( 1 .lt. i1 ) then j = i - nrow else j = i + nrow end if a(i,j) = a(i,j) - 1.0D+00 if ( 1 .lt. j1 ) then j = i - 1 else j = i + 1 end if a(i,j) = a(i,j) - 1.0D+00 j = i a(i,j) = 4.0D+00 if ( j1 .lt. ncol ) then j = i + 1 else j = i - 1 end if a(i,j) = a(i,j) - 1.0D+00 if ( i1 .lt. nrow ) then j = i + nrow else j = i - nrow end if a(i,j) = a(i,j) - 1.0D+00 end do end do return end subroutine neumann_determinant ( n, determ ) c*********************************************************************72 c cc NEUMANN_DETERMINANT returns the determinant of the NEUMANN matrix. c c Licensing: c c This code is distributed under the GNU LGPL license. c c Modified: c c 13 June 2011 c c Author: c c John Burkardt c c Parameters: c c Input, integer N, the order of the matrix. c c Output, double precision DETERM, the determinant. c implicit none double precision determ integer n determ = 0.0D+00 return end subroutine neumann_null_right ( nrow, ncol, x ) c*********************************************************************72 c cc NEUMANN_NULL_RIGHT returns a right null vector of the NEUMANN matrix. c c Licensing: c c This code is distributed under the GNU LGPL license. c c Modified: c c 13 June 2011 c c Author: c c John Burkardt c c Parameters: c c Input, integer NROW, NCOL, the number of rows and columns c in the grid. c c Output, double precision X(NROW*NCOL), the null vector. c implicit none integer ncol integer nrow integer i double precision x(nrow*ncol) do i = 1, nrow * ncol x(i) = 1.0D+00 end do return end subroutine one ( m, n, a ) c*********************************************************************72 c cc ONE returns the ONE matrix. c c Discussion: c c The matrix is sometimes symbolized by "J". c c Example: c c N = 5 c c 1 1 1 1 1 c 1 1 1 1 1 c 1 1 1 1 1 c 1 1 1 1 1 c 1 1 1 1 1 c c Properties: c c Every entry of A is 1. c c A is symmetric. c c A is Toeplitz: constant along diagonals. c c A is Hankel: constant along antidiagonals. c c A is a circulant matrix: each row is shifted once to get the next row. c c A has constant row sums. c c A has constant column sums. c c If 1 .lt. N, A is singular. c c If 1 .lt. N, det ( A ) = 0. c c LAMBDA(1:N-1) = 0 c LAMBDA(N) = N c c The eigenvectors associated with LAMBDA = 0 can be written as c ( 1, -1, 0, ..., 0 ) c ( 1, 0, -1, ..., 0 ) c ... c ( 1, 0, 0, ..., -1 ). c The eigenvector associated with LAMBDA = N is ( 1, 1, ..., 1 ). c c A * A = N * A c c The family of matrices is nested as a function of N. c c Licensing: c c This code is distributed under the GNU LGPL license. c c Modified: c c 13 June 2011 c c Author: c c John Burkardt c c Parameters: c c Input, integer M, N, the order of the matrix. c c Output, double precision A(M,N), the matrix. c implicit none integer m integer n double precision a(m,n) integer i integer j do j = 1, n do i = 1, m a(i,j) = 1.0D+00 end do end do return end subroutine one_determinant ( n, determ ) c*********************************************************************72 c cc ONE_DETERMINANT returns the determinant of the ONE matrix. c c Licensing: c c This code is distributed under the GNU LGPL license. c c Modified: c c 13 June 2011 c c Author: c c John Burkardt c c Parameters: c c Input, integer N, the order of the matrix. c c Output, double precision DETERM, the determinant. c implicit none double precision determ integer n if ( n .eq. 1 ) then determ = 1.0D+00 else determ = 0.0D+00 end if return end subroutine one_eigen_right ( n, x ) c*********************************************************************72 c cc ONE_EIGEN_RIGHT returns right eigenvectors of the ONE matrix. c c Licensing: c c This code is distributed under the GNU LGPL license. c c Modified: c c 13 June 2011 c c Author: c c John Burkardt c c Parameters: c c Input, integer N, the order of the matrix. c c Output, double precision X(N,N), the right eigenvectors. c implicit none integer n integer i integer j double precision x(n,n) do j = 1, n do i = 1, n x(i,j) = 0.0D+00 end do end do do j = 1, n - 1 x( 1,j) = +1.0D+00 x(j+1,j) = -1.0D+00 end do j = n x(1:n,j) = 1.0D+00 return end subroutine one_eigenvalues ( n, lambda ) c*********************************************************************72 c cc ONE_EIGENVALUES returns the eigenvalues of the ONE matrix. c c Licensing: c c This code is distributed under the GNU LGPL license. c c Modified: c c 13 June 2011 c c Author: c c John Burkardt c c Parameters: c c Input, integer N, the order of the matrix. c c Output, double precision LAMBDA(N), the eigenvalues. c implicit none integer n integer i double precision lambda(n) do i = 1, n - 1 lambda(i) = 0.0D+00 end do lambda(n) = dble ( n ) return end subroutine one_null_left ( m, n, x ) c*********************************************************************72 c cc ONE_NULL_LEFT returns a left null vector of the ONE matrix. c c Licensing: c c This code is distributed under the GNU LGPL license. c c Modified: c c 12 March 2015 c c Author: c c John Burkardt c c Parameters: c c Input, integer M, N, the order of the matrix. c c Output, double precision X(M), the null vector. c implicit none integer m integer n integer i double precision x(m) if ( m .eq. 1 ) then write ( *, '(a)' ) ' ' write ( *, '(a)' ) 'ONE_NULL_LEFT - Fatal error!' write ( *, '(a)' ) ' Matrix is nonsingular for M = 1.' stop 1 end if x(1) = 1.0D+00 do i = 2, m - 1 x(i) = 0.0D+00 end do x(m) = -1.0D+00 return end subroutine one_null_right ( m, n, x ) c*********************************************************************72 c cc ONE_NULL_RIGHT returns a right null vector of the ONE matrix. c c Licensing: c c This code is distributed under the GNU LGPL license. c c Modified: c c 13 June 2011 c c Author: c c John Burkardt c c Parameters: c c Input, integer M, N, the order of the matrix. c c Output, double precision X(N), the null vector. c implicit none integer m integer n integer i double precision x(n) if ( n .eq. 1 ) then write ( *, '(a)' ) ' ' write ( *, '(a)' ) 'ONE_NULL_RIGHT - Fatal error!' write ( *, '(a)' ) ' Matrix is nonsingular for N = 1.' stop 1 end if x(1) = 1.0D+00 do i = 2, n - 1 x(i) = 0.0D+00 end do x(n) = -1.0D+00 return end subroutine ortega ( n, u, v, d, a ) c*********************************************************************72 c cc ORTEGA returns the ORTEGA matrix. c c Licensing: c c This code is distributed under the GNU LGPL license. c c Modified: c c 23 September 2008 c c Author: c c John Burkardt c c Reference: c c James Ortega, c Generation of Test Matrices by Similarity Transformations, c Communications of the ACM, c Volume 7, 1964, pages 377-378. c c Parameters: c c Input, integer N, the order of the matrix. c 2 <= N. c c Input, double precision U(N), V(N), vectors which define the matrix. c U'V must not equal -1.0. If, in fact, U'V = 0, and U, V and D are c integers, then the matrix, inverse, eigenvalues, and eigenvectors c will be integers. c c Input, double precision D(N), the desired eigenvalues. c c Output, double precision A(N,N), the matrix. c implicit none integer n double precision a(n,n) double precision beta double precision bik double precision ckj double precision d(n) integer i integer j integer k double precision r8vec_dot_product double precision u(n) double precision v(n) double precision vtu vtu = r8vec_dot_product ( n, v, u ) beta = 1.0D+00 / ( 1.0D+00 + vtu ) do j = 1, n do i = 1, n a(i,j) = 0.0D+00 do k = 1, n if ( i .eq. k ) then bik = 1.0D+00 + u(i) * v(k) else bik = u(i) * v(k) end if if ( k .eq. j ) then ckj = 1.0D+00 - beta * u(k) * v(j) else ckj = - beta * u(k) * v(j) end if a(i,j) = a(i,j) + bik * d(k) * ckj end do end do end do return end subroutine ortega_determinant ( n, u, v, d, determ ) c*********************************************************************72 c cc ORTEGA_DETERMINANT returns the determinant of the ORTEGA matrix. c c Licensing: c c This code is distributed under the GNU LGPL license. c c Modified: c c 23 September 2008 c c Author: c c John Burkardt c c Reference: c c James Ortega, c Generation of Test Matrices by Similarity Transformations, c Communications of the ACM, c Volume 7, 1964, pages 377-378. c c Parameters: c c Input, integer N, the order of the matrix. c 2 <= N. c c Input, double precision U(N), V(N), vectors which define the matrix. c U'V must not equal -1.0. If, in fact, U'V = 0, and U, V and D are c integers, then the matrix, inverse, eigenvalues, and eigenvectors c will be integers. c c Input, double precision D(N), the desired eigenvalues. c c Output, double precision DETERM, the determinant. c implicit none integer n double precision d(n) double precision determ double precision r8vec_product double precision u(n) double precision v(n) determ = r8vec_product ( n, d ) return end subroutine ortega_eigen_right ( n, u, v, d, x ) c*********************************************************************72 c cc ORTEGA_EIGEN_RIGHT returns right eigenvectors of the ORTEGA matrix. c c Licensing: c c This code is distributed under the GNU LGPL license. c c Modified: c c 23 September 2008 c c Author: c c John Burkardt c c Reference: c c James Ortega, c Generation of Test Matrices by Similarity Transformations, c Communications of the ACM, c Volume 7, 1964, pages 377-378. c c Parameters: c c Input, integer N, the order of the matrix. c 2 <= N. c c Input, double precision U(N), V(N), vectors which define the matrix. c U'V must not equal -1.0. If, in fact, U'V = 0, and U, V and D are c integers, then the matrix, inverse, eigenvalues, and eigenvectors c will be integers. c c Input, double precision D(N), the desired eigenvalues. c c Output, double precision X(N,N), the determinant. c implicit none integer n double precision d(n) integer i integer j double precision u(n) double precision v(n) double precision x(n,n) do j = 1, n do i = 1, n if ( i .eq. j ) then x(i,j) = 1.0D+00 + u(i) * v(j) else x(i,j) = u(i) * v(j) end if end do end do return end subroutine ortega_eigenvalues ( n, u, v, d, lambda ) c*********************************************************************72 c cc ORTEGA_EIGENVALUES returns the eigenvalues of the ORTEGA matrix. c c Licensing: c c This code is distributed under the GNU LGPL license. c c Modified: c c 23 September 2008 c c Author: c c John Burkardt c c Reference: c c James Ortega, c Generation of Test Matrices by Similarity Transformations, c Communications of the ACM, c Volume 7, 1964, pages 377-378. c c Parameters: c c Input, integer N, the order of the matrix. c 2 <= N. c c Input, double precision U(N), V(N), vectors which define the matrix. c U'V must not equal -1.0. If, in fact, U'V = 0, and U, V and D are c integers, then the matrix, inverse, eigenvalues, and eigenvectors c will be integers. c c Input, double precision D(N), the desired eigenvalues. c c Output, double precision LAMBDA(N), the determinant. c implicit none integer n double precision d(n) integer i double precision lambda(n) double precision u(n) double precision v(n) do i = 1, n lambda(i) = d(i) end do return end subroutine ortega_inverse ( n, u, v, d, a ) c*********************************************************************72 c cc ORTEGA_INVERSE returns the inverse of the ORTEGA matrix. c c Licensing: c c This code is distributed under the GNU LGPL license. c c Modified: c c 29 June 2011 c c Author: c c John Burkardt c c Reference: c c James Ortega, c Generation of Test Matrices by Similarity Transformations, c Communications of the ACM, c Volume 7, 1964, pages 377-378. c c Parameters: c c Input, integer N, the order of the matrix. c 2 <= N. c c Input, double precision U(N), V(N), vectors which define the matrix. c U'V must not equal -1.0. If, in fact, U'V = 0, and U, V and D are c integers, then the matrix, inverse, eigenvalues, and eigenvectors c will be integers. c c Input, double precision D(N), the desired eigenvalues. c c Output, double precision A(N,N), the matrix. c implicit none integer n double precision a(n,n) double precision beta double precision bik double precision ckj double precision d(n) integer i integer j integer k double precision r8vec_dot_product double precision u(n) double precision v(n) double precision vtu vtu = r8vec_dot_product ( n, v, u ) do i = 1, n if ( d(i) .eq. 0.0D+00 ) then write ( *, '(a)' ) ' ' write ( *, '(a)' ) 'ORTEGA_INVERSE - Fatal error!' write ( *, '(a)' ) ' Some D(1:N) entries are zero.' stop 1 end if end do beta = 1.0D+00 / ( 1.0D+00 + vtu ) do j = 1, n do i = 1, n a(i,j) = 0.0D+00 do k = 1, n if ( i .eq. k ) then bik = 1.0D+00 + u(i) * v(k) else bik = + u(i) * v(k) end if if ( k .eq. j ) then ckj = 1.0D+00 - beta * u(k) * v(j) else ckj = - beta * u(k) * v(j) end if a(i,j) = a(i,j) + ( bik / d(k) ) * ckj end do end do end do return end subroutine orth_random ( n, key, a ) c*********************************************************************72 c cc ORTH_RANDOM returns the ORTH_RANDOM matrix. c c Discussion: c c The matrix is a random orthogonal matrix. c c Properties: c c The inverse of A is equal to A'. c c A is orthogonal: A * A' = A' * A = I. c c Because A is orthogonal, it is normal: A' * A = A * A'. c c Columns and rows of A have unit Euclidean norm. c c Distinct pairs of columns of A are orthogonal. c c Distinct pairs of rows of A are orthogonal. c c The L2 vector norm of A*x = the L2 vector norm of x for any vector x. c c The L2 matrix norm of A*B = the L2 matrix norm of B for any matrix B. c c det ( A ) = +1 or -1. c c A is unimodular. c c All the eigenvalues of A have modulus 1. c c All singular values of A are 1. c c All entries of A are between -1 and 1. c c Discussion: c c Thanks to Eugene Petrov, B I Stepanov Institute of Physics, c National Academy of Sciences of Belarus, for convincingly c pointing out the severe deficiencies of an earlier version of c this routine. c c Essentially, the computation involves saving the Q factor of the c QR factorization of a matrix whose entries are normally distributed. c However, it is only necessary to generate this matrix a column at c a time, since it can be shown that when it comes time to annihilate c the subdiagonal elements of column K, these (transformed) elements of c column K are still normally distributed random values. Hence, there c is no need to generate them at the beginning of the process and c transform them K-1 times. c c For computational efficiency, the individual Householder transformations c could be saved, as recommended in the reference, instead of being c accumulated into an explicit matrix format. c c Licensing: c c This code is distributed under the GNU LGPL license. c c Modified: c c 11 June 2011 c c Author: c c John Burkardt c c Reference: c c Pete Stewart, c Efficient Generation of Random Orthogonal Matrices With an Application c to Condition Estimators, c SIAM Journal on Numerical Analysis, c Volume 17, Number 3, June 1980, pages 403-409. c c Parameters: c c Input, integer N, the order of the matrix. c c Input, integer KEY, a positive integer that selects the data. c c Output, double precision A(N,N), the matrix. c implicit none integer n double precision a(n,n) integer i integer j integer key double precision r8_normal_01 integer seed double precision v(n) double precision x(n) c c Start with A = the identity matrix. c do i = 1, n do j = 1, n if ( i .eq. j ) then a(i,j) = 1.0D+00 else a(i,j) = 0.0D+00 end if end do end do c c Now behave as though we were computing the QR factorization of c some other random matrix. Generate the N elements of the first column, c compute the Householder matrix H1 that annihilates the subdiagonal elements, c and set A := A * H1' = A * H. c c On the second step, generate the lower N-1 elements of the second column, c compute the Householder matrix H2 that annihilates them, c and set A := A * H2' = A * H2 = H1 * H2. c c On the N-1 step, generate the lower 2 elements of column N-1, c compute the Householder matrix HN-1 that annihilates them, and c and set A := A * H(N-1)' = A * H(N-1) = H1 * H2 * ... * H(N-1). c This is our random orthogonal matrix. c seed = key do j = 1, n - 1 c c Set the vector that represents the J-th column to be annihilated. c do i = 1, j - 1 x(i) = 0.0D+00 end do do i = j, n x(i) = r8_normal_01 ( seed ) end do c c Compute the vector V that defines a Householder transformation matrix c H(V) that annihilates the subdiagonal elements of X. c call r8vec_house_column ( n, x, j, v ) c c Postmultiply the matrix A by H'(V) = H(V). c call r8mat_house_axh ( n, a, v, a ) end do return end subroutine orth_random_determinant ( n, key, determinant ) c*********************************************************************72 c cc ORTH_RANDOM_DETERMINANT returns the determinant of the ORTH_RANDOM matrix. c c Licensing: c c This code is distributed under the GNU LGPL license. c c Modified: c c 22 June 2011 c c Author: c c John Burkardt c c Parameters: c c Input, integer N, the order of the matrix. c c Input, integer KEY, a positive integer that selects the data. c c Output, double precision DETERMINANT, the determinant. c implicit none integer n double precision determinant integer key determinant = 1.0D+00 return end subroutine orth_random_inverse ( n, key, a ) c*********************************************************************72 c cc ORTH_RANDOM_INVERSE returns the inverse of the ORTH_RANDOM matrix. c c Discussion: c c This routine will only work properly if the input value of SEED c is exactly the same as the value used to generate the original matrix. c c Licensing: c c This code is distributed under the GNU LGPL license. c c Modified: c c 22 June 2011 c c Author: c c John Burkardt c c Parameters: c c Input, integer N, the order of the matrix. c c Input, integer KEY, a positive integer that selects the data. c c Output, double precision A(N,N), the matrix. c implicit none integer n double precision a(n,n) integer key call orth_random ( n, key, a ) return end subroutine orth_symm ( n, a ) c*********************************************************************72 c cc ORTH_SYMM returns the ORTH_SYMM matrix. c c Formula: c c A(I,J) = sqrt ( 2 ) * sin ( I * J * pi / ( N + 1 ) ) / sqrt ( N + 1 ) c c Example: c c N = 5 c c 0.326019 0.548529 0.596885 0.455734 0.169891 c 0.548529 0.455734 -0.169891 -0.596885 -0.326019 c 0.596885 -0.169891 -0.548529 0.326019 0.455734 c 0.455734 -0.596885 0.326019 0.169891 -0.548528 c 0.169891 -0.326019 0.455734 -0.548528 0.596885 c c Properties: c c A is orthogonal: A' * A = A * A' = I. c c A is symmetric: A' = A. c c A is not positive definite (unless N = 1 ). c c Because A is symmetric, it is normal. c c Because A is symmetric, its eigenvalues are real. c c Because A is orthogonal, its eigenvalues have unit norm. c c Only +1 and -1 can be eigenvalues of A. c c Because A is normal, it is diagonalizable. c c A is involutional: A * A = I. c c If N is even, trace ( A ) = 0; if N is odd, trace ( A ) = 1. c c LAMBDA(1:(N+1)/2) = 1; LAMBDA((N+1)/2+1:N) = -1. c c A is the left and right eigenvector matrix for the c second difference matrix. c c Licensing: c c This code is distributed under the GNU LGPL license. c c Modified: c c 22 June 2011 c c Author: c c John Burkardt c c Reference: c c Morris Newman, John Todd, c The evaluation of matrix inversion programs, c Journal of the Society for Industrial and Applied Mathematics, c Volume 6, Number 4, pages 466-476, 1958. c c Parameters: c c Input, integer N, the order of the matrix. c c Output, double precision A(N,N), the matrix. c implicit none integer n double precision a(n,n) double precision angle integer i integer j double precision r8_pi parameter ( r8_pi = 3.141592653589793D+00 ) do i = 1, n do j = 1, n angle = 2.0D+00 * dble ( i * j ) * r8_pi & / dble ( 2 * n + 1 ) a(i,j) = 2.0D+00 * sin ( angle ) & / sqrt ( dble ( 2 * n + 1 ) ) end do end do return end subroutine orth_symm_condition ( n, cond ) c*********************************************************************72 c cc ORTH_SYMM_CONDITION returns the L1 condition of the ORTH_SYMM matrix. c c Licensing: c c This code is distributed under the GNU LGPL license. c c Modified: c c 29 January 2015 c c Author: c c John Burkardt c c Parameters: c c Input, integer N, the order of the matrix. c c Output, double precision COND, the L1 condition. c implicit none integer n double precision a_norm double precision angle double precision b_norm double precision cond integer i integer j double precision r8_pi parameter ( r8_pi = 3.141592653589793D+00 ) a_norm = 0.0D+00 j = 1 do i = 1, n angle = 2.0D+00 * dble ( i * j ) * r8_pi & / dble ( 2 * n + 1 ) a_norm = a_norm + 2.0D+00 * abs ( sin ( angle ) ) & / sqrt ( dble ( 2 * n + 1 ) ) end do b_norm = a_norm cond = a_norm * b_norm return end subroutine orth_symm_determinant ( n, determ ) c*********************************************************************72 c cc ORTH_SYMM_DETERMINANT returns the determinant of the ORTH_SYMM matrix. c c Licensing: c c This code is distributed under the GNU LGPL license. c c Modified: c c 22 June 2011 c c Author: c c John Burkardt c c Parameters: c c Input, integer N, the order of the matrix. c c Output, double precision DETERM, the determinant. c implicit none integer n double precision determ determ = 1.0D+00 return end subroutine orth_symm_eigenvalues ( n, lambda ) c*********************************************************************72 c cc ORTH_SYMM_EIGENVALUES returns eigenvalues of the ORTH_SYMM matrix. c c Licensing: c c This code is distributed under the GNU LGPL license. c c Modified: c c 22 June 2011 c c Author: c c John Burkardt c c Parameters: c c Input, integer N, the order of the matrix. c c Output, double precision LAMBDA(N), the eigenvalues. c implicit none integer n integer i double precision lambda(n) integer split split = ( n + 1 ) / 2 do i = 1, split lambda(i) = +1.0D+00 end do do i = split + 1, n lambda(i) = -1.0D+00 end do return end subroutine orth_symm_inverse ( n, a ) c*********************************************************************72 c cc ORTH_SYMM_INVERSE returns the inverse of the ORTH_SYMM matrix. c c Licensing: c c This code is distributed under the GNU LGPL license. c c Modified: c c 22 June 2011 c c Author: c c John Burkardt c c Parameters: c c Input, integer N, the order of the matrix. c c Output, double precision A(N,N), the matrix. c implicit none integer n double precision a(n,n) call orth_symm ( n, a ) return end subroutine oto ( m, n, a ) c*********************************************************************72 c cc OTO returns the OTO matrix. c c Discussion: c c The name is meant to suggest "One, Two, One". c c Example: c c N = 5 c c 2 1 . . . c 1 2 1 . . c . 1 2 1 . c . . 1 2 1 c . . . 1 2 c c Properties: c c A is banded, with bandwidth 3. c c A is tridiagonal. c c Because A is tridiagonal, it has property A (bipartite). c c A is integral: int ( A ) = A. c c A is Toeplitz: constant along diagonals. c c A is symmetric: A' = A. c c Because A is symmetric, it is normal. c c Because A is normal, it is diagonalizable. c c A is persymmetric: A(I,J) = A(N+1-J,N+1-I). c c A is weakly diagonally dominant, but not strictly diagonally dominant. c c The family of matrices is nested as a function of N. c c Licensing: c c This code is distributed under the GNU LGPL license. c c Modified: c c 11 June 2011 c c Author: c c John Burkardt c c Parameters: c c Input, integer M, N, the order of the matrix. c c Output, double precision A(M,N), the matrix. c implicit none integer m integer n double precision a(m,n) integer i integer j do i = 1, m do j = 1, n if ( j .eq. i - 1 ) then a(i,j) = 1.0D+00 else if ( j .eq. i ) then a(i,j) = 2.0D+00 else if ( j .eq. i + 1 ) then a(i,j) = 1.0D+00 else a(i,j) = 0.0D+00 end if end do end do return end subroutine oto_condition ( n, value ) c*********************************************************************72 c cc OTO_CONDITION returns the L1 condition of the OTO matrix. c c Licensing: c c This code is distributed under the GNU LGPL license. c c Modified: c c 14 March 2015 c c Author: c c John Burkardt c c Parameters: c c Input, integer N, the order of the matrix. c c Output, double precision VALUE, the L1 condition. c implicit none double precision a_norm double precision b_norm integer i1 integer i2 integer n integer n1 integer n2 integer s double precision value if ( n .eq. 1 ) then a_norm = 2.0D+00 else if ( n .eq. 2 ) then a_norm = 3.0D+00 else a_norm = 4.0D+00 end if n1 = ( n + 1 ) / 2 n2 = ( n + 2 ) / 2 s = 0 i1 = n1 i2 = 0 10 continue if ( i2 .lt. n2 ) then i2 = i2 + 1 s = s + i1 * i2 go to 10 end if 20 continue if ( 1 .lt. i1 ) then i1 = i1 - 1 s = s + i1 * i2 go to 20 end if b_norm = dble ( s ) / dble ( n + 1 ) value = a_norm * b_norm return end subroutine oto_determinant ( n, determ ) c*********************************************************************72 c cc OTO_DETERMINANT returns the determinant of the OTO matrix. c c Licensing: c c This code is distributed under the GNU LGPL license. c c Modified: c c 11 June 2011 c c Author: c c John Burkardt c c Parameters: c c Input, integer N, the order of the matrix. c c Output, double precision DETERM, the determinant of the matrix. c implicit none double precision determ integer n determ = dble ( n + 1 ) return end subroutine oto_eigen_right ( n, a ) c*********************************************************************72 c cc OTO_EIGEN_RIGHT returns right eigenvectors of the OTO matrix. c c Licensing: c c This code is distributed under the GNU LGPL license. c c Modified: c c 11 June 2011 c c Author: c c John Burkardt c c Parameters: c c Input, integer N, the order of the matrix. c c Output, double precision A(N,N), the right eigenvector matrix. c implicit none integer n double precision a(n,n) double precision angle integer i integer j double precision r8_pi parameter ( r8_pi = 3.141592653589793D+00 ) double precision r8_mop do i = 1, n do j = 1, n angle = dble ( i * j ) * r8_pi / dble ( n + 1 ) a(i,j) = r8_mop ( i + j ) & * sqrt ( 2.0D+00 / dble ( n + 1 ) ) * sin ( angle ) end do end do return end subroutine oto_eigenvalues ( n, lambda ) c*********************************************************************72 c cc OTO_EIGENVALUES returns the eigenvalues of the OTO matrix. c c Licensing: c c This code is distributed under the GNU LGPL license. c c Modified: c c 11 June 2011 c c Author: c c John Burkardt c c Parameters: c c Input, integer N, the order of the matrix. c c Output, double precision LAMBDA(N), the eigenvalues. c implicit none integer n double precision angle integer i double precision lambda(n) double precision r8_pi parameter ( r8_pi = 3.141592653589793D+00 ) do i = 1, n angle = dble ( i ) * r8_pi / dble ( 2 * ( n + 1 ) ) lambda(i) = 4.0D+00 * ( sin ( angle ) ) ** 2 end do return end subroutine oto_inverse ( n, a ) c*********************************************************************72 c cc OTO_INVERSE returns the inverse of the OTO matrix. c c Formula: c c if ( I <= J ) c A(I,J) = (-1)^(I+J) * I * (N-J+1) / (N+1) c else c A(I,J) = (-1)^(I+J) * J * (N-I+1) / (N+1) c c Example: c c N = 4 c c 4 -3 2 -1 c (1/5) * -3 6 -4 2 c 2 -4 6 -3 c -1 2 -3 4 c c Licensing: c c This code is distributed under the GNU LGPL license. c c Modified: c c 11 June 2011 c c Author: c c John Burkardt c c Parameters: c c Input, integer N, the order of the matrix. c c Output, double precision A(N,N), the matrix. c implicit none integer n double precision a(n,n) integer i integer j double precision r8_mop do i = 1, n do j = 1, n if ( i .le. j ) then a(i,j) = r8_mop ( i + j ) & * dble ( i * ( n - j + 1 ) ) / dble ( n + 1 ) else a(i,j) = r8_mop ( i + j ) & * dble ( j * ( n - i + 1 ) ) / dble ( n + 1 ) end if end do end do return end subroutine oto_llt ( n, a ) c*********************************************************************72 c cc OTO_LLT returns the Cholesky factor of the OTO matrix. c c Example: c c N = 5 c c 1.4142 0 0 0 0 c 0.7071 1.2247 0 0 0 c 0 0.8165 1.1547 0 0 c 0 0 0.8660 1.1180 0 c 0 0 0 0.8944 1.0954 c c Licensing: c c This code is distributed under the GNU LGPL license. c c Modified: c c 09 April 2015 c c Author: c c John Burkardt c c Parameters: c c Input, integer N, the order of the matrix. c c Output, double precision A(N,N), the matrix. c implicit none integer n double precision a(n,n) integer i integer j do j = 1, n do i = 1, n a(i,j) = 0.0D+00 end do end do do i = 1, n a(i,i) = sqrt ( dble ( i + 1 ) / dble ( i ) ) end do do i = 2, n a(i,i-1) = sqrt ( dble ( i - 1 ) / dble ( i ) ) end do return end subroutine oto_plu ( n, p, l, u ) c*********************************************************************72 c cc OTO_PLU returns the PLU factors of the OTO matrix. c c Licensing: c c This code is distributed under the GNU LGPL license. c c Modified: c c 11 June 2011 c c Author: c c John Burkardt c c Parameters: c c Input, integer N, the order of the matrix. c c Output, double precision P(N,N), L(N,N), U(N,N), the PLU factors. c implicit none integer n integer i integer j double precision l(n,n) double precision p(n,n) double precision u(n,n) do j = 1, n do i = 1, n if ( i .eq. j ) then p(i,j) = 1.0D+00 else p(i,j) = 0.0D+00 end if end do end do do j = 1, n do i = 1, n if ( i .eq. j ) then l(i,j) = 1.0D+00 else if ( i .eq. j + 1 ) then l(i,j) = dble ( j ) / dble ( j + 1 ) else l(i,j) = 0.0D+00 end if end do end do do j = 1, n do i = 1, n if ( i .eq. j ) then u(i,j) = dble ( i + 1 ) / dble ( i ) else if ( i .eq. j - 1 ) then u(i,j) = 1.0D+00 else u(i,j) = 0.0D+00 end if end do end do return end subroutine parlett ( a ) c*********************************************************************72 c cc PARLETT returns the PARLETT matrix. c c Formula: c c N = 100 c c if ( I < J ) c if ( I = 1 and J = 2 ) c A(I,J) = 40 / 102 c else if ( I = 1 and J = 100 ) c A(I,J) = 40 c else c A(I,J) = 0 c else if ( I = J ) c A(I,J) = 101 - I c else if ( J < I ) c A(I,J) = (-1)^(I+J+1) * 40 / ( I + J - 2 ) c c Example: c c 100.00 0.39 0 0 0 ... 40.00 c 40.00 99.00 0 0 0 ... 0 c -20.00 13.33 98.00 0 0 ... 0 c 13.33 -10.00 8.00 97.00 0 ... 0 c -10.00 8.00 -6.67 5.71 96.00 ... 0 c ... ... ... ... ... ... ... c 0.40 -0.40 0.39 -0.39 0.38 ... 1.00 c c Properties: c c A is not symmetric: A' /= A. c c The eigenvalues of A are c c LAMBDA(I) = I. c c det ( A ) = 100! c c Licensing: c c This code is distributed under the GNU LGPL license. c c Modified: c c 22 June 2011 c c Author: c c John Burkardt c c Reference: c c Robert Gregory, David Karney, c A Collection of Matrices for Testing Computational Algorithms, c Wiley, 1969, c ISBN: 0882756494, c LC: QA263.G68. c c Joan Westlake, c A Handbook of Numerical Matrix Inversion and Solution of c Linear Equations, c John Wiley, 1968, c ISBN13: 978-0471936756, c LC: QA263.W47. c c Parameters: c c Output, double precision A(100,100), the matrix. c implicit none integer n parameter ( n = 100 ) double precision a(n,n) integer i integer j double precision r8_mop do i = 1, n do j = 1, n if ( i .lt. j ) then if ( i .eq. 1 .and. j .eq. 2 ) then a(i,j) = 40.0D+00 / 102.0D+00 else if ( i .eq. 1 .and. j .eq. 100 ) then a(i,j) = 40.0D+00 else a(i,j) = 0.0D+00 end if else if ( i .eq. j ) then a(i,j) = 101.0D+00 - dble ( i ) else if ( j < i ) then a(i,j) = r8_mop ( i + j + 1 ) * 40.0D+00 & / dble ( i + j - 2 ) end if end do end do return end subroutine parlett_eigenvalues ( lambda ) c*********************************************************************72 c cc PARLETT_EIGENVALUES returns the eigenvalues of the PARLETT matrix. c c Licensing: c c This code is distributed under the GNU LGPL license. c c Modified: c c 22 June 2011 c c Author: c c John Burkardt c c Parameters: c c Output, double precision LAMBDA(100), the eigenvalues. c implicit none integer i double precision lambda(100) do i = 1, 100 lambda(i) = dble ( i ) end do return end subroutine parter ( m, n, a ) c*********************************************************************72 c cc PARTER returns the PARTER matrix. c c Formula: c c A(I,J) = 1 / ( i - j + 0.5 ) c c Example: c c N = 5 c c 2 -2 -2/3 -2/5 -2/7 c 2/3 2 -2 -2/3 -2/5 c 2/5 2/3 2 -2 -2/3 c 2/7 2/5 2/3 2 -2 c 2/9 2/7 2/5 2/3 2 c c Properties: c c The diagonal entries are all 2, the first superdiagonals all -2. c c A is Toeplitz: constant along diagonals. c c A is generally not symmetric: A' /= A. c c A is persymmetric: A(I,J) = A(N+1-J,N+1-I). c c The PARTER matrix is a special case of the CAUCHY matrix. c c Most of the singular values are very close to Pi. c c The family of matrices is nested as a function of N. c c Licensing: c c This code is distributed under the GNU LGPL license. c c Modified: c c 22 June 2011 c c Author: c c John Burkardt c c Reference: c c Seymour Parter, c On the distribution of the singular values of Toeplitz matrices, c Linear Algebra and Applications, c Volume 80, August 1986, pages 115-130. c c Evgeny Tyrtyshnikov, c Cauchy-Toeplitz matrices and some applications, c Linear Algebra and Applications, c Volume 149, 15 April 1991, pages 1-18. c c Parameters: c c Input, integer M, N, the order of the matrix. c c Output, double precision A(M,N), the matrix. c implicit none integer m integer n double precision a(m,n) integer i integer j do i = 1, m do j = 1, n a(i,j) = 1.0D+00 / ( dble ( i - j ) + 0.5D+00 ) end do end do return end subroutine parter_determinant ( n, determ ) c*********************************************************************72 c cc PARTER_DETERMINANT returns the determinant of the PARTER matrix. c c Licensing: c c This code is distributed under the GNU LGPL license. c c Modified: c c 22 June 2011 c c Author: c c John Burkardt c c Parameters: c c Input, integer N, the order of the matrix. c c Output, double precision DETERM, the determinant. c implicit none integer n double precision bottom double precision determ integer i integer j double precision top top = 1.0D+00 do i = 1, n do j = i + 1, n top = top * dble ( j - i ) * dble ( i - j ) end do end do bottom = 1.0D+00 do i = 1, n do j = 1, n bottom = bottom * ( dble ( i - j ) + 0.5D+00 ) end do end do determ = top / bottom return end subroutine parter_inverse ( n, a ) c*********************************************************************72 c cc PARTER_INVERSE returns the inverse of the PARTER matrix. c c Licensing: c c This code is distributed under the GNU LGPL license. c c Modified: c c 22 June 2011 c c Author: c c John Burkardt c c Parameters: c c Input, integer N, the order of the matrix. c c Output, double precision A(N,N), the matrix. c implicit none integer n double precision a(n,n) double precision bot1 double precision bot2 integer i integer j integer k double precision top do i = 1, n do j = 1, n top = 1.0D+00 bot1 = 1.0D+00 bot2 = 1.0D+00 do k = 1, n top = top * ( 0.5D+00 + dble ( j - k ) ) & * ( 0.5D+00 + dble ( k - i ) ) if ( k .ne. j ) then bot1 = bot1 * dble ( j - k ) end if if ( k .ne. i ) then bot2 = bot2 * dble ( k - i ) end if end do a(i,j) = top / ( ( 0.5D+00 + dble ( j - i ) ) * bot1 * bot2 ) end do end do return end subroutine pascal1 ( n, a ) c*********************************************************************72 c cc PASCAL1 returns the PASCAL1 matrix. c c Formula: c c if ( J = 1 ) then c A(I,J) = 1 c else if ( I = 0 ) then c A(1,J) = 0 c else c A(I,J) = A(I-1,J) + A(I-1,J-1) c c Example: c c N = 5 c c 1 0 0 0 0 c 1 1 0 0 0 c 1 2 1 0 0 c 1 3 3 1 0 c 1 4 6 4 1 c c Properties: c c A is a "chunk" of the Pascal binomial combinatorial triangle. c c A is generally not symmetric: A' /= A. c c A is nonsingular. c c A is lower triangular. c c A is integral, therefore det ( A ) is integral, and c det ( A ) * inverse ( A ) is integral. c c det ( A ) = 1. c c A is unimodular. c c LAMBDA(1:N) = 1. c c (0, 0, ..., 0, 1) is an eigenvector. c c The inverse of A is the same as A, except that entries in "odd" c positions have changed sign: c c B(I,J) = (-1)^(I+J) * A(I,J) c c The product A*A' is a Pascal matrix c of the sort created by subroutine PASCAL2. c c Let the matrix C have the same entries as A, except that c the even columns are negated. Then Inverse(C) = C, and c C' * C = the Pascal matrix created by PASCAL2. c c The family of matrices is nested as a function of N. c c Licensing: c c This code is distributed under the GNU LGPL license. c c Modified: c c 12 June 2011 c c Author: c c John Burkardt c c Reference: c c Robert Gregory, David Karney, c A Collection of Matrices for Testing Computational Algorithms, c Wiley, 1969, c ISBN: 0882756494, c LC: QA263.68 c c Parameters: c c Input, integer N, the order of the matrix. c c Output, double precision A(N,N), the matrix. c implicit none integer n double precision a(n,n) integer i integer j do i = 1, n do j = 1, n if ( j .eq. 1 ) then a(i,j) = 1.0D+00 else if ( i .eq. 1 ) then a(i,j) = 0.0D+00 else a(i,j) = a(i-1,j-1) + a(i-1,j) end if end do end do return end subroutine pascal1_condition ( n, value ) c*********************************************************************72 c cc PASCAL1_CONDITION returns the L1 condition of the PASCAL1 matrix. c c Licensing: c c This code is distributed under the GNU LGPL license. c c Modified: c c 13 March 2015 c c Author: c c John Burkardt c c Parameters: c c Input, integer N, the order of the matrix. c c Output, double precision VALUE, the L1 condition. c implicit none double precision a_norm double precision b_norm integer n integer nhalf double precision r8_choose double precision value nhalf = ( n + 1 ) / 2 a_norm = r8_choose ( n, nhalf ) b_norm = r8_choose ( n, nhalf ) value = a_norm * b_norm return end subroutine pascal1_determinant ( n, determ ) c*********************************************************************72 c cc PASCAL1_DETERMINANT returns the determinant of the PASCAL1 matrix. c c Licensing: c c This code is distributed under the GNU LGPL license. c c Modified: c c 12 June 2011 c c Author: c c John Burkardt c c Parameters: c c Input, integer N, the order of the matrix. c c Output, double precision DETERM, the determinant. c implicit none double precision determ integer n determ = 1.0D+00 return end subroutine pascal1_eigenvalues ( n, lambda ) c*********************************************************************72 c cc PASCAL1_EIGENVALUES returns eigenvalues of the PASCAL1 matrix. c c Licensing: c c This code is distributed under the GNU LGPL license. c c Modified: c c 12 June 2011 c c Author: c c John Burkardt c c Parameters: c c Input, integer N, the order of the matrix. c c Output, double precision LAMBDA(N), the eigenvalues. c implicit none integer n integer i double precision lambda(n) do i = 1, n lambda(i) = 1.0D+00 end do return end subroutine pascal1_inverse ( n, a ) c*********************************************************************72 c cc PASCAL1_INVERSE returns the inverse of the PASCAL1 matrix. c c Formula: c c if ( J = 1 ) c A(I,J) = (-1)^(I+J) c else if ( I = 1 ) c A(I,J) = 0 c else c A(I,J) = A(I-1,J) - A(I,J-1) c c Example: c c N = 5 c c 1 0 0 0 0 c -1 1 0 0 0 c 1 -2 1 0 0 c -1 3 -3 1 0 c 1 -4 6 -4 1 c c Properties: c c A is nonsingular. c c A is lower triangular. c c A is integral, therefore det ( A ) is integral, and c det ( A ) * inverse ( A ) is integral. c c det ( A ) = 1. c c A is unimodular. c c LAMBDA(1:N) = 1. c c (0, 0, ..., 0, 1) is an eigenvector. c c The inverse of A is the same as A, except that entries in "odd" c positions have changed sign: c c B(I,J) = (-1)^(I+J) * A(I,J) c c Licensing: c c This code is distributed under the GNU LGPL license. c c Modified: c c 12 June 2011 c c Author: c c John Burkardt c c Parameters: c c Input, integer N, the order of the matrix. c c Output, double precision A(N,N), the matrix. c implicit none integer n double precision a(n,n) integer i integer j double precision r8_mop do i = 1, n do j = 1, n if ( j .eq. 1 ) then a(i,j) = r8_mop ( i + j ) else if ( i .eq. 1 ) then a(i,j) = 0.0D+00 else a(i,j) = a(i-1,j-1) - a(i-1,j) end if end do end do return end subroutine pascal2 ( n, a ) c*********************************************************************72 c cc PASCAL2 returns the PASCAL2 matrix. c c Discussion: c c See page 172 of the Todd reference. c c Formula: c c If ( I = 1 or J = 1 ) c A(I,J) = 1 c else c A(I,J) = A(I-1,J) + A(I,J-1) c c Example: c c N = 5 c c 1 1 1 1 1 c 1 2 3 4 5 c 1 3 6 10 15 c 1 4 10 20 35 c 1 5 15 35 70 c c Properties: c c A is a "chunk" of the Pascal binomial combinatorial triangle. c c A is positive definite. c c A is symmetric: A' = A. c c Because A is symmetric, it is normal. c c Because A is normal, it is diagonalizable. c c A is integral, therefore det ( A ) is integral, and c det ( A ) * inverse ( A ) is integral. c c A is nonsingular. c c det ( A ) = 1. c c A is unimodular. c c Eigenvalues of A occur in reciprocal pairs. c c The condition number of A is approximately 16^N / ( N*PI ). c c The elements of the inverse of A are integers. c c A(I,J) = (I+J-2)! / ( (I-1)! * (J-1)! ) c c The Cholesky factor of A is a lower triangular matrix R, c such that A = R * R'. The matrix R is a Pascal c matrix of the type generated by subroutine PASCAL. In other c words, PASCAL2 = PASCAL * PASCAL'. c c If the (N,N) entry of A is decreased by 1, the matrix is singular. c c Gregory and Karney consider a generalization of this matrix as c their test matrix 3.7, in which every element is multiplied by a c nonzero constant K. They point out that if K is the reciprocal of c an integer, then the inverse matrix has all integer entries. c c The family of matrices is nested as a function of N. c c Licensing: c c This code is distributed under the GNU LGPL license. c c Modified: c c 12 June 2011 c c Author: c c John Burkardt c c Reference: c c Robert Brawer, Magnus Pirovino, c The linear algebra of the Pascal matrix, c Linear Algebra and Applications, c Volume 174, 1992, pages 13-23. c c Robert Gregory, David Karney, c A Collection of Matrices for Testing Computational Algorithms, c Wiley, 1969, c ISBN: 0882756494, c LC: QA263.68 c c Nicholas Higham, c Accuracy and Stability of Numerical Algorithms, c Society for Industrial and Applied Mathematics, c Philadelphia, PA, USA, 1996; section 26.4. c c Sam Karlin, c Total Positivity, Volume 1, c Stanford University Press, 1968. c c Morris Newman, John Todd, c The evaluation of matrix inversion programs, c Journal of the Society for Industrial and Applied Mathematics, c Volume 6, Number 4, pages 466-476, 1958. c c Heinz Rutishauser, c On test matrices, c Programmation en Mathematiques Numeriques, c Centre National de la Recherche Scientifique, c 1966, pages 349-365. c c John Todd, c Basic Numerical Mathematics, c Volume 2: Numerical Algebra, c Birkhauser, 1980, c ISBN: 0817608117, c LC: QA297.T58. c c HW Turnbull, c The Theory of Determinants, Matrices, and Invariants, c Blackie, 1929. c c Parameters: c c Input, integer N, the order of the matrix. c c Output, double precision A(N,N), the matrix. c implicit none integer n double precision a(n,n) integer i integer j do j = 1, n do i = 1, n if ( i .eq. 1 ) then a(i,j) = 1.0D+00 else if ( j .eq. 1 ) then a(i,j) = 1.0D+00 else a(i,j) = a(i,j-1) + a(i-1,j) end if end do end do return end subroutine pascal2_determinant ( n, determ ) c*********************************************************************72 c cc PASCAL2_DETERMINANT returns the determinant of the PASCAL2 matrix. c c Licensing: c c This code is distributed under the GNU LGPL license. c c Modified: c c 12 June 2011 c c Author: c c John Burkardt c c Parameters: c c Input, integer N, the order of the matrix. c c Output, double precision DETERM, the determinant. c implicit none double precision determ integer n determ = 1.0D+00 return end subroutine pascal2_inverse ( n, a ) c*********************************************************************72 c cc PASCAL2_INVERSE returns the inverse of the PASCAL2 matrix. c c Formula: c c A(I,J) = sum ( max(I,J) <= K <= N ) c (-1)^(J+I) * COMB(K-1,I-1) * COMB(K-1,J-1) c c Example: c c N = 5 c c 5 -10 10 -5 1 c -10 30 -35 19 -4 c 10 -35 46 -27 6 c -5 19 -27 17 -4 c 1 -4 6 -4 1 c c Properties: c c A is symmetric: A' = A. c c Because A is symmetric, it is normal. c c Because A is normal, it is diagonalizable. c c A is integral, therefore det ( A ) is integral, and c det ( A ) * inverse ( A ) is integral. c c The first row sums to 1, the others to 0. c c The first column sums to 1, the others to 0. c c Licensing: c c This code is distributed under the GNU LGPL license. c c Modified: c c 02 June 2008 c c Author: c c John Burkardt c c Parameters: c c Input, integer N, the order of the matrix. c c Output, double precision A(N,N), the matrix. c implicit none integer n double precision a(n,n) integer i integer j integer k integer klo double precision r8_choose double precision r8_mop do i = 1, n do j = 1, n a(i,j) = 0.0D+00 klo = max ( i, j ) do k = klo, n a(i,j) = a(i,j) + r8_mop ( i + j ) & * r8_choose ( k - 1, i - 1 ) & * r8_choose ( k - 1, j - 1 ) end do end do end do return end subroutine pascal2_llt ( n, a ) c*********************************************************************72 c cc PASCAL2_LLT returns the Cholesky factor of the PASCAL2 matrix. c c Example: c c N = 5 c c 1 0 0 0 0 c 1 1 0 0 0 c 1 2 1 0 0 c 1 3 3 1 0 c 1 4 6 4 1 c c Licensing: c c This code is distributed under the GNU LGPL license. c c Modified: c c 26 May 2002 c c Author: c c John Burkardt c c Parameters: c c Input, integer N, the order of the matrix. c c Output, double precision A(N,N), the matrix. c implicit none integer n double precision a(n,n) call pascal1 ( n, a ) return end subroutine pascal2_plu ( n, p, l, u ) c*********************************************************************72 c cc PASCAL2_PLU returns the PLU factors of the PASCAL2 matrix. c c Licensing: c c This code is distributed under the GNU LGPL license. c c Modified: c c 12 June 2011 c c Author: c c John Burkardt c c Parameters: c c Input, integer N, the order of the matrix. c c Output, double precision P(N,N), L(N,N), U(N,N), the PLU factors. c implicit none integer n integer i integer j double precision l(n,n) double precision p(n,n) double precision u(n,n) do j = 1, n do i = 1, n if ( i .eq. j ) then p(i,j) = 1.0D+00 else p(i,j) = 0.0D+00 end if end do end do call pascal1 ( n, l ) do j = 1, n do i = 1, n u(i,j) = l(j,i) end do end do return end subroutine pascal3 ( n, alpha, a ) c*********************************************************************72 c cc PASCAL3 returns the PASCAL3 matrix. c c Formula: c c if ( J = 1 ) then c A(I,J) = 1 c else if ( I = 0 ) then c A(1,J) = 0 c else c A(I,J) = ALPHA * A(I-1,J) + A(I-1,J-1) ) c c Example: c c N = 5, ALPHA = 2 c c 1 0 0 0 0 c 2 1 0 0 0 c 4 4 1 0 0 c 8 12 6 1 0 c 16 32 24 8 1 c c Properties: c c A is generally not symmetric: A' /= A. c c A[0] is the identity matrix. c c A[1] is the usual (lower triangular) Pascal matrix. c c A is nonsingular. c c A is lower triangular. c c If ALPHA is integral, then A is integral. c If A is integral, then det ( A ) is integral, and c det ( A ) * inverse ( A ) is integral. c c det ( A ) = 1. c c A is unimodular. c c LAMBDA(1:N) = 1. c c (0, 0, ..., 0, 1) is an eigenvector. c c The inverse of A[X] is A[-X]. c c A[ALPHA] * A[BETA] = A[ALPHA*BETA]. c c A[1/2] is the "square root" of A[1], and so on. c c The family of matrices is nested as a function of N. c c Licensing: c c This code is distributed under the GNU LGPL license. c c Modified: c c 12 June 2011 c c Author: c c John Burkardt c c Reference: c c Gregory Call, Daniel Velleman, c Pascal's Matrices, c American Mathematical Monthly, c Volume 100, Number 4, April 1993, pages 372-376. c c Parameters: c c Input, integer N, the order of the matrix. c c Input, double precision ALPHA, the parameter. c c Output, double precision A(N,N), the matrix. c implicit none integer n double precision a(n,n) double precision alpha integer i integer j do i = 1, n do j = 1, n if ( i .eq. 1 ) then if ( j .eq. 1 ) then a(i,j) = 1.0D+00 else a(i,j) = 0.0D+00 end if else if ( j .eq. 1 ) then a(i,j) = alpha * a(i-1,j) else a(i,j) = a(i-1,j-1) + alpha * a(i-1,j) end if end do end do return end subroutine pascal3_condition ( n, alpha, value ) c*********************************************************************72 c cc PASCAL3_CONDITION returns the L1 condition of the PASCAL3 matrix. c c Licensing: c c This code is distributed under the GNU LGPL license. c c Modified: c c 05 April 2015 c c Author: c c John Burkardt c c Parameters: c c Input, integer N, the order of the matrix. c c Input, double precision ALPHA, the parameter. c c Output, double precision VALUE, the L1 condition. c implicit none integer n double precision a(n,n) double precision a_norm double precision alpha double precision b_norm double precision r8mat_norm_l1 double precision value call pascal3 ( n, alpha, a ) a_norm = r8mat_norm_l1 ( n, n, a ) b_norm = a_norm value = a_norm * b_norm return end subroutine pascal3_determinant ( n, alpha, determ ) c*********************************************************************72 c cc PASCAL3_DETERMINANT returns the determinant of the PASCAL3 matrix. c c Licensing: c c This code is distributed under the GNU LGPL license. c c Modified: c c 08 October 2007 c c Author: c c John Burkardt c c Parameters: c c Input, integer N, the order of the matrix. c c Input, double precision ALPHA, the parameter. c c Output, double precision DETERM, the determinant. c implicit none double precision alpha double precision determ integer n determ = 1.0D+00 return end subroutine pascal3_inverse ( n, alpha, a ) c*********************************************************************72 c cc PASCAL3_INVERSE returns the inverse of the PASCAL3 matrix. c c Licensing: c c This code is distributed under the GNU LGPL license. c c Modified: c c 12 June 2011 c c Author: c c John Burkardt c c Parameters: c c Input, integer N, the order of the matrix. c c Input, double precision ALPHA, the parameter. c c Output, double precision A(N,N), the matrix. c implicit none integer n double precision a(n,n) double precision alpha integer i integer j do i = 1, n do j = 1, n if ( i .eq. 1 ) then if ( j .eq. 1 ) then a(i,j) = 1.0D+00 else a(i,j) = 0.0D+00 end if else if ( j .eq. 1 ) then a(i,j) = - alpha * a(i-1,j) else a(i,j) = a(i-1,j-1) - alpha * a(i-1,j) end if end do end do return end subroutine pds_random ( n, key, a ) c*********************************************************************72 c cc PDS_RANDOM returns the PDS_RANDOM matrix. c c Discussion: c c The matrix is a "random" positive definite symmetric matrix. c c The matrix returned will have eigenvalues in the range [0,1]. c c Properties: c c A is symmetric: A' = A. c c A is positive definite: 0 < x'*A*x for nonzero x. c c The eigenvalues of A will be real. c c Licensing: c c This code is distributed under the GNU LGPL license. c c Modified: c c 22 June 2011 c c Author: c c John Burkardt c c Parameters: c c Input, integer N, the order of the matrix. c c Input, integer KEY, a positive integer that selects the data. c c Output, double precision A(N,N), the matrix. c implicit none integer n double precision a(n,n) integer i integer j integer k integer key double precision lambda(n) double precision q(n,n) integer seed c c Get a random set of eigenvalues. c seed = key call r8vec_uniform_01 ( n, seed, lambda ) c c Get a random orthogonal matrix Q. c call orth_random ( n, key, q ) c c Set A = Q * Lambda * Q'. c do i = 1, n do j = 1, n a(i,j) = 0.0D+00 do k = 1, n a(i,j) = a(i,j) + q(i,k) * lambda(k) * q(j,k) end do end do end do return end subroutine pds_random_determinant ( n, key, determ ) c*********************************************************************72 c cc PDS_RANDOM_DETERMINANT returns the determinant of the PDS_RANDOM matrix. c c Discussion: c c This routine will only work properly if the SAME value of SEED c is input that was input to PDS_RANDOM. c c Licensing: c c This code is distributed under the GNU LGPL license. c c Modified: c c 22 June 2011 c c Author: c c John Burkardt c c Parameters: c c Input, integer N, the order of the matrix. c c Input, integer KEY, a positive integer that selects the data. c c Output, double precision DETERM, the determinant. c implicit none integer n double precision determ integer key double precision lambda(n) double precision r8vec_product integer seed seed = key call r8vec_uniform_01 ( n, seed, lambda ) determ = r8vec_product ( n, lambda ) return end subroutine pds_random_eigen_right ( n, key, q ) c*********************************************************************72 c cc PDS_RANDOM_EIGEN_RIGHT returns right eigenvectors of the PDS_RANDOM matrix. c c Licensing: c c This code is distributed under the GNU LGPL license. c c Modified: c c 22 June 2011 c c Author: c c John Burkardt c c Parameters: c c Input, integer N, the order of the matrix. c c Input, integer KEY, a positive integer that selects the data. c c Output, double precision Q(N,N), the matrix. c implicit none integer n integer key double precision lambda(n) double precision q(n,n) integer seed c c Get a random set of eigenvalues. c seed = key call r8vec_uniform_01 ( n, seed, lambda ) c c Get a random orthogonal matrix Q. c call orth_random ( n, key, q ) return end subroutine pds_random_eigenvalues ( n, key, lambda ) c*********************************************************************72 c cc PDS_RANDOM_EIGENVALUES returns the eigenvalues of the PDS_RANDOM matrix. c c Discussion: c c This routine will only work properly if the SAME value of SEED c is input that was input to PDS_RANDOM. c c Licensing: c c This code is distributed under the GNU LGPL license. c c Modified: c c 22 June 2011 c c Author: c c John Burkardt c c Parameters: c c Input, integer N, the order of the matrix. c c Input, integer KEY, a positive integer that selects the data. c c Output, double precision LAMBDA(N), the eigenvalues. c implicit none integer n integer key double precision lambda(n) integer seed seed = key call r8vec_uniform_01 ( n, seed, lambda ) return end subroutine pds_random_inverse ( n, key, a ) c*********************************************************************72 c cc PDS_RANDOM_INVERSE returns the inverse of the PDS_RANDOM matrix. c c Discussion: c c The matrix is a "random" positive definite symmetric matrix. c c The matrix returned will have eigenvalues in the range [0,1]. c c Properties: c c A is symmetric: A' = A. c c A is positive definite: 0 < x'*A*x for nonzero x. c c The eigenvalues of A will be real. c c Licensing: c c This code is distributed under the GNU LGPL license. c c Modified: c c 22 June 2011 c c Author: c c John Burkardt c c Parameters: c c Input, integer N, the order of the matrix. c c Input, integer KEY, a positive integer that selects the data. c c Output, double precision A(N,N), the matrix. c implicit none integer n double precision a(n,n) integer i integer j integer k integer key double precision lambda(n) double precision q(n,n) integer seed c c Get a random set of eigenvalues. c seed = key call r8vec_uniform_01 ( n, seed, lambda ) c c Get a random orthogonal matrix Q. c call orth_random ( n, key, q ) c c Set A = Q * Lambda * Q'. c do i = 1, n do j = 1, n a(i,j) = 0.0D+00 do k = 1, n a(i,j) = a(i,j) + q(i,k) * ( 1.0 / lambda(k) ) * q(j,k) end do end do end do return end subroutine pei ( alpha, n, a ) c*********************************************************************72 c cc PEI returns the PEI matrix. c c Formula: c c if ( I = J ) then c A(I,J) = 1.0D+00 + ALPHA c else c A(I,J) = 1.0D+00 c c Example: c c ALPHA = 2, N = 5 c c 3 1 1 1 1 c 1 3 1 1 1 c 1 1 3 1 1 c 1 1 1 3 1 c 1 1 1 1 3 c c Properties: c c A is symmetric: A' = A. c c Because A is symmetric, it is normal. c c Because A is normal, it is diagonalizable. c c A is persymmetric: A(I,J) = A(N+1-J,N+1-I). c c A is positive definite for 0 < ALPHA. c c A is Toeplitz: constant along diagonals. c c A is a circulant matrix: each row is shifted once to get the next row. c c A is singular if and only if ALPHA = 0 or ALPHA = -N. c c A becomes more ill-conditioned as ALPHA approaches 0. c c The condition number under the spectral norm is c abs ( ( ALPHA + N ) / ALPHA ) c c The eigenvalues of A are c c LAMBDA(1:N-1) = ALPHA c LAMBDA(N) = ALPHA + N c c A has constant row sum of ALPHA + N. c c Because it has a constant row sum of ALPHA + N, c A has an eigenvalue of ALPHA + N, and c a right eigenvector of ( 1, 1, 1, ..., 1 ). c c A has constant column sum of ALPHA + N. c c Because it has a constant column sum of ALPHA + N, c A has an eigenvalue of ALPHA + N, and c a left eigenvector of ( 1, 1, 1, ..., 1 ). c c The eigenvectors are: c c V1 = 1 / sqrt ( N ) * ( 1, 1, 1, ... , 1 ) c VR = 1 / sqrt ( R * (R-1) ) * ( 1, 1, 1, ... 1, -R+1, 0, 0, 0, ... 0 ) c c where the "-R+1" occurs at index R. c c det ( A ) = ALPHA^(N-1) * ( N + ALPHA ). c c The family of matrices is nested as a function of N. c c Licensing: c c This code is distributed under the GNU LGPL license. c c Modified: c c 22 June 2011 c c Author: c c John Burkardt c c Reference: c c Morris Newman, John Todd, c Example A3, c The evaluation of matrix inversion programs, c Journal of the Society for Industrial and Applied Mathematics, c Volume 6, Number 4, pages 466-476, 1958. c c ML Pei, c A test matrix for inversion procedures, c Communications of the ACM, c Volume 5, 1962, page 508. c c Joan Westlake, c A Handbook of Numerical Matrix Inversion and Solution of c Linear Equations, c John Wiley, 1968, c ISBN13: 978-0471936756, c LC: QA263.W47. c c Parameters: c c Input, double precision ALPHA, the scalar that defines the Pei matrix. A c typical value of ALPHA is 1.0. c c Input, integer N, the order of the matrix. c c Output, double precision A(N,N), the matrix. c implicit none integer n double precision a(n,n) double precision alpha integer i integer j do i = 1, n do j = 1, n if ( i .eq. j ) then a(i,j) = 1.0D+00 + alpha else a(i,j) = 1.0D+00 end if end do end do return end subroutine pei_condition ( alpha, n, cond ) c*********************************************************************72 c cc PEI_CONDITION returns the L1 condition of the PEI matrix. c c Licensing: c c This code is distributed under the GNU LGPL license. c c Modified: c c 28 January 2015 c c Author: c c John Burkardt c c Parameters: c c Input, double precision ALPHA, the scalar that defines the Pei matrix. A c typical value of ALPHA is 1.0. c c Input, integer N, the order of the matrix. c c Output, double precision COND, the L1 condition. c implicit none double precision a_norm double precision alpha double precision b_norm double precision cond integer n double precision n_r8 n_r8 = dble ( n ) a_norm = abs ( alpha + 1.0D+00 ) + n_r8 - 1.0D+00 b_norm = ( abs ( alpha + n_r8 - 1.0D+00 ) + n_r8 - 1.0D+00 ) & / abs ( alpha * ( alpha + n_r8 ) ) cond = a_norm * b_norm return end subroutine pei_determinant ( alpha, n, determ ) c*********************************************************************72 c cc PEI_DETERMINANT returns the determinant of the PEI matrix. c c Licensing: c c This code is distributed under the GNU LGPL license. c c Modified: c c 22 June 2011 c c Author: c c John Burkardt c c Parameters: c c Input, double precision ALPHA, the scalar that defines the Pei matrix. A c typical value of ALPHA is 1.0. c c Input, integer N, the order of the matrix. c c Output, double precision DETERM, the determinant. c implicit none double precision alpha double precision determ integer n determ = alpha ** ( n - 1 ) * ( alpha + dble ( n ) ) return end subroutine pei_eigen_right ( alpha, n, x ) c*********************************************************************72 c cc PEI_EIGEN_RIGHT returns right eigenvectors of the PEI matrix. c c Licensing: c c This code is distributed under the GNU LGPL license. c c Modified: c c 22 June 2011 c c Author: c c John Burkardt c c Parameters: c c Input, double precision ALPHA, the scalar that defines A. c c Input, integer N, the order of the matrix. c c Output, double precision X(N,N), the right eigenvectors. c implicit none integer n double precision alpha integer i integer j double precision x(n,n) do j = 1, n do i = 1, n x(i,j) = 0.0D+00 end do end do do j = 1, n - 1 x( 1,j) = +1.0D+00 x(j+1,j) = -1.0D+00 end do j = n do i = 1, n x(i,j) = 1.0D+00 end do return end subroutine pei_eigenvalues ( alpha, n, lambda ) c*********************************************************************72 c cc PEI_EIGENVALUES returns the eigenvalues of the PEI matrix. c c Licensing: c c This code is distributed under the GNU LGPL license. c c Modified: c c 22 June 2011 c c Author: c c John Burkardt c c Parameters: c c Input, double precision ALPHA, the scalar that defines the Pei matrix. A c typical value of ALPHA is 1.0. c c Input, integer N, the order of the matrix. c c Output, double precision LAMBDA(N), the eigenvalues. c implicit none integer n double precision alpha integer i double precision lambda(n) do i = 1, n - 1 lambda(i) = alpha end do lambda(n) = alpha + dble ( n ) return end subroutine pei_inverse ( alpha, n, a ) c*********************************************************************72 c cc PEI_INVERSE returns the inverse of the PEI matrix. c c Formula: c c if ( I = J ) c A(I,J) = (ALPHA+N-1) / ( (ALPHA+1)*(ALPHA+N-1)-(N-1) ) c else c A(I,J) = -1 / ( (ALPHA+1)*(ALPHA+N-1)-(N-1) ) c c Example: c c ALPHA = 2, N = 5 c c 6 -1 -1 -1 -1 c -1 6 -1 -1 -1 c 1/14 * -1 -1 6 -1 -1 c -1 -1 -1 6 -1 c -1 -1 -1 -1 6 c c Properties: c c A is symmetric: A' = A. c c Because A is symmetric, it is normal. c c Because A is normal, it is diagonalizable. c c A is persymmetric: A(I,J) = A(N+1-J,N+1-I). c c A is a "combinatorial" matrix. See routine COMBIN. c c A is Toeplitz: constant along diagonals. c c A is a circulant matrix: each row is shifted once to get the next row. c c A has constant row sum. c c Because it has a constant row sum of 1 / ( ALPHA + N ), c A has an eigenvalue of 1 / ( ALPHA + N ), and c a right eigenvector of ( 1, 1, 1, ..., 1 ). c c A has constant column sum. c c Because it has constant column sum of 1 / ( ALPHA + N ), c A has an eigenvalue of 1 / ( ALPHA + N ), and c a left eigenvector of ( 1, 1, 1, ..., 1 ). c c The eigenvalues of A are c LAMBDA(1:N-1) = 1 / ALPHA c LAMBDA(N) = 1 / ( ALPHA + N ) c c Licensing: c c This code is distributed under the GNU LGPL license. c c Modified: c c 22 June 2011 c c Author: c c John Burkardt c c Reference: c c ML Pei, c A test matrix for inversion procedures, c Communications of the ACM, c Volume 5, 1962, page 508. c c Parameters: c c Input, double precision ALPHA, the scalar that defines the inverse c of the Pei matrix. c c Input, integer N, the order of the matrix. c c Output, double precision A(N,N), the matrix. c implicit none integer n double precision a(n,n) double precision alpha double precision alpha1 double precision beta1 double precision bottom integer i integer j bottom = ( alpha + 1.0D+00 ) * & ( alpha + dble ( n ) - 1.0D+00 ) - dble ( n ) + 1.0D+00 if ( bottom .eq. 0.0D+00 ) then write ( *, '(a)' ) ' ' write ( *, '(a)' ) 'PEI_INVERSE - Fatal error!' write ( *, '(a)' ) ' The matrix is not invertible.' write ( *, '(a)' ) ' (ALPHA+1)*(ALPHA+N-1)-N+1 is zero.' stop 1 end if alpha1 = ( alpha + dble ( n ) - 1.0D+00 ) / bottom beta1 = - 1.0D+00 / bottom do i = 1, n do j = 1, n if ( i .eq. j ) then a(i,j) = alpha1 else a(i,j) = beta1 end if end do end do return end subroutine perm_check ( n, p, ierror ) c*********************************************************************72 c cc PERM_CHECK checks that a vector represents a permutation. c c Discussion: c c The routine verifies that each of the integers from 1 to c to N occurs among the N entries of the permutation. c c Licensing: c c This code is distributed under the GNU LGPL license. c c Modified: c c 03 June 2009 c c Author: c c John Burkardt c c Parameters: c c Input, integer N, the number of entries. c c Input, integer P(N), the array to check. c c Output, integer IERROR, error flag. c 0, the array represents a permutation. c nonzero, the array does not represent a permutation. The smallest c missing value is equal to IERROR. c implicit none integer n integer find integer ierror integer p(n) integer seek ierror = 0 do seek = 1, n ierror = 1 do find = 1, n if ( p(find) .eq. seek ) then ierror = 0 go to 10 end if end do 10 continue if ( ierror .ne. 0 ) then write ( *, '(a)' ) ' ' write ( *, '(a)' ) 'PERM_CHECK - Fatal error!' write ( *, '(a)' ) ' The input array does not represent' write ( *, '(a)' ) ' a proper permutation.' stop 1 end if end do return end subroutine perm_inverse ( n, p ) c*********************************************************************72 c cc PERM_INVERSE inverts a permutation "in place". c c Discussion: c c This algorithm assumes that the entries in the permutation vector are c strictly positive. In particular, the value 0 must not occur. c c When necessary, this function shifts the data temporarily so that c this requirement is satisfied. c c Licensing: c c This code is distributed under the GNU LGPL license. c c Modified: c c 03 June 2009 c c Parameters: c c Input, integer N, the number of objects being permuted. c c Input/output, integer P(N), the permutation, in standard index form. c On output, P describes the inverse permutation c implicit none integer n integer i integer i0 integer i1 integer i2 integer ierror integer is integer p(n) if ( n .le. 0 ) then write ( *, '(a)' ) ' ' write ( *, '(a)' ) 'PERM_INVERSE - Fatal error!' write ( *, '(a,i8)' ) ' Input value of N = ', n stop 1 end if c c Check the permutation. c call perm_check ( n, p, ierror ) if ( ierror .ne. 0 ) then write ( *, '(a)' ) ' ' write ( *, '(a)' ) 'PERM_INVERSE - Fatal error!' write ( *, '(a)' ) ' PERM_CHECK rejects this permutation.' stop 1 end if c c Invert the permutation. c is = 1 do i = 1, n i1 = p(i) 10 continue if ( i .lt. i1 ) then i2 = p(i1) p(i1) = -i2 i1 = i2 go to 10 end if is = -sign ( 1, p(i) ) p(i) = sign ( p(i), is ) end do do i = 1, n i1 = -p(i) if ( 0 .le. i1 ) then i0 = i 20 continue i2 = p(i1) p(i1) = i0 if ( i2 .lt. 0 ) then go to 30 end if i0 = i1 i1 = i2 go to 20 30 continue end if end do return end subroutine perm_mat_to_vec ( n, a, p ) c*********************************************************************72 c cc PERM_MAT_TO_VEC returns a permutation from a permutation matrix. c c Example: c c N = 5 c c A = 0 1 0 0 0 c 0 0 0 1 0 c 1 0 0 0 0 c 0 0 1 0 0 c 0 0 0 0 1 c c p = ( 2, 4, 1, 3, 5 ) c c Licensing: c c This code is distributed under the GNU LGPL license. c c Modified: c c 19 June 2011 c c Author: c c John Burkardt c c Parameters: c c Input, integer N, the order of the matrix. c c Input, double precision A(N,N), the permutation matrix. c c Output, integer P(N), a permutation of the indices 1 through c N, which corresponds to the matrix. c implicit none integer n double precision a(n,n) integer i integer ival integer j integer p(n) call r8mat_is_perm ( n, a, ival ) if ( ival .ne. 1 ) then write ( *, '(a)' ) ' ' write ( *, '(a)' ) 'PERM_MAT_TO_VEC - Fatal error!' write ( *, '(a)' ) & ' The input matrix does not define a permutation.' write ( *, '(a,i8)' ) ' R8MAT_IS_PERM returned IVAL = ', ival stop 1 end if do i = 1, n do j = 1, n if ( a(i,j) .eq. 1.0D+00 ) then p(i) = j end if end do end do return end subroutine perm_sign ( n, p, p_sign ) c*********************************************************************72 c cc PERM_SIGN returns the sign of a permutation. c c Discussion: c c A permutation can always be replaced by a sequence of pairwise c transpositions. A given permutation can be represented by c many different such transposition sequences, but the number of c such transpositions will always be odd or always be even. c If the number of transpositions is even or odd, the permutation is c said to be even or odd. c c Example: c c Input: c c N = 9 c P = 2, 3, 9, 6, 7, 8, 5, 4, 1 c c Output: c c P_SIGN = +1 c c Licensing: c c This code is distributed under the GNU LGPL license. c c Modified: c c 19 June 2011 c c Author: c c Original FORTRAN77 version by Albert Nijenhuis, Herbert Wilf. c This FORTRAN77 version by John Burkardt c c Reference: c c Albert Nijenhuis, Herbert Wilf, c Combinatorial Algorithms, c Academic Press, 1978, second edition, c ISBN 0-12-519260-6. c c Parameters: c c Input, integer N, the number of objects permuted. c c Input, integer P(N), a permutation, in standard index form. c c Output, integer P_SIGN, the "sign" of the permutation. c +1, the permutation is even, c -1, the permutation is odd. c implicit none integer n integer i integer ierror integer i4vec_index integer j integer k integer p(n) integer p_sign integer q(n) call perm_check ( n, p, ierror ) if ( ierror .ne. 0 ) then write ( *, '(a)' ) ' ' write ( *, '(a)' ) 'PERM_SIGN - Fatal error!' write ( *, '(a)' ) ' The input array does not represent' write ( *, '(a)' ) ' a proper permutation. In particular, the' write ( *, '(a,i8)' ) ' array is missing the value ', ierror stop 1 end if c c Make a temporary copy of the permutation. c do i = 1, n q(i) = p(i) end do c c Start with P_SIGN indicating an even permutation. c Restore each element of the permutation to its correct position, c updating P_SIGN as you go. c p_sign = 1 do i = 1, n - 1 j = i4vec_index ( n, q, i ) if ( j .ne. i ) then k = q(i) q(i) = q(j) q(j) = k p_sign = - p_sign end if end do return end subroutine perm_vec_to_mat ( n, p, a ) c*********************************************************************72 c cc PERM_VEC_TO_MAT returns a permutation matrix. c c Formula: c c if ( J = P(I) ) c A(I,J) = 1 c else c A(I,J) = 0 c c Example: c c N = 5, P = ( 2, 4, 1, 3, 5 ) c c 0 1 0 0 0 c 0 0 0 1 0 c 1 0 0 0 0 c 0 0 1 0 0 c 0 0 0 0 1 c c Properties: c c A is integral, therefore det ( A ) is integral, and c det ( A ) * inverse ( A ) is integral. c c A is a zero/one matrix. c c P is a proper definition of a permutation if and only if c every value from 1 to N occurs exactly once. The matrix A c will be a permutation matrix if and only if P is a proper c definition of a permutation. c c A is nonsingular. c c The inverse of A is the transpose of A, inverse ( A ) = A'. c c The inverse of A is the permutation matrix corresponding to the c inverse permutation of the one that formed A. c c det ( A ) = +1 or -1. c c A is unimodular. c c The determinant of A is +1 or -1, depending on the sign of c the permutation; Any permutation can be written as the product c of pairwise transpositions. An odd permutation can be written c as an odd number of such transpositions, and the corresponding c matrix has a determinant of -1. c c The product of two permutation matrices is a permutation matrix. c c Licensing: c c This code is distributed under the GNU LGPL license. c c Modified: c c 19 June 2011 c c Author: c c John Burkardt c c Parameters: c c Input, integer N, the order of the matrix. c c Input, integer P(N), contains the permutation. The c entries of P should be a permutation of the indices 1 through N. c c Output, double precision A(N,N), the matrix. c implicit none integer n double precision a(n,n) integer i integer ierror integer j integer p(n) call perm_check ( n, p, ierror ) if ( ierror .ne. 0 ) then write ( *, '(a)' ) ' ' write ( *, '(a)' ) 'PERM_VEC_TO_MAT - Fatal error!' write ( *, '(a)' ) ' The input does not define a permutation.' write ( *, '(a,i8)' ) ' PERM_CHECK returned IERROR = ', ierror call i4vec_print ( n, p, ' The permutation:' ) stop 1 end if do i = 1, n do j = 1, n if ( j .eq. p(i) ) then a(i,j) = 1.0D+00 else a(i,j) = 0.0D+00 end if end do end do return end subroutine permutation_determinant ( n, a, determ ) c*********************************************************************72 c cc PERMUTATION_DETERMINANT returns the determinant of a PERMUTATION matrix. c c Licensing: c c This code is distributed under the GNU LGPL license. c c Modified: c c 22 June 2011 c c Author: c c John Burkardt c c Parameters: c c Input, integer N, the order of the matrix. c c Input, double precision A(N,N), the matrix. c c Output, double precision DETERM, the determinant. c implicit none integer n double precision a(n,n) double precision determ integer p(n) integer p_sign call perm_mat_to_vec ( n, a, p ) call perm_sign ( n, p, p_sign ) determ = dble ( p_sign ) return end subroutine permutation_random ( n, key, a ) c*********************************************************************72 c cc PERMUTATION_RANDOM returns the PERMUTATION_RANDOM matrix. c c Licensing: c c This code is distributed under the GNU LGPL license. c c Modified: c c 22 June 2011 c c Author: c c John Burkardt c c Reference: c c Albert Nijenhuis, Herbert Wilf, c Combinatorial Algorithms, c Academic Press, 1978, second edition, c ISBN 0-12-519260-6. c c Parameters: c c Input, integer N, the order of the matrix. c c Input, integer KEY, a positive integer that selects the data. c c Output, double precision A(N,N), the matrix. c implicit none integer n double precision a(n,n) integer i integer i4_uniform_ab integer j integer key integer p(n) integer seed integer t call i4vec_indicator ( n, p ) seed = key do i = 1, n j = i4_uniform_ab ( i, n, seed ) t = p(j) p(j) = p(i) p(i) = t end do call perm_vec_to_mat ( n, p, a ) return end subroutine permutation_random_determinant ( n, key, determ ) c*********************************************************************72 c cc PERMUTATION_RANDOM_DETERMINANT: determinant of PERMUTATION_RANDOM matrix. c c Discussion: c c This routine will only work properly if it is given as input the c same value of SEED that was given to PERMUTATION_RANDOM. c c Licensing: c c This code is distributed under the GNU LGPL license. c c Modified: c c 22 June 2011 c c Author: c c John Burkardt c c Parameters: c c Input, integer N, the order of the matrix. c c Input, integer KEY, a positive integer that selects the data. c c Output, double precision DETERM, the determinant. c implicit none integer n double precision determ integer i integer i4_uniform_ab integer j integer key integer p(n) integer p_sign integer seed integer t call i4vec_indicator ( n, p ) seed = key do i = 1, n j = i4_uniform_ab ( i, n, seed ) t = p(j) p(j) = p(i) p(i) = t end do call perm_sign ( n, p, p_sign ) determ = dble ( p_sign ) return end subroutine permutation_random_inverse ( n, key, a ) c*********************************************************************72 c cc PERMUTATION_RANDOM_INVERSE: inverse of PERMUTATION_RANDOM matrix. c c Discussion: c c This routine will only work properly if it is given as input the c same value of SEED that was given to PERMUTATION_RANDOM. c c Licensing: c c This code is distributed under the GNU LGPL license. c c Modified: c c 22 June 2011 c c Author: c c John Burkardt c c Parameters: c c Input, integer N, the order of the matrix. c c Input, integer KEY, a positive integer that selects the data. c c Output, double precision A(N,N), the inverse matrix. c implicit none integer n double precision a(n,n) integer i integer i4_uniform_ab integer j integer key integer p(n) integer p_sign integer seed integer t call i4vec_indicator ( n, p ) seed = key do i = 1, n j = i4_uniform_ab ( i, n, seed ) t = p(j) p(j) = p(i) p(i) = t end do call perm_inverse ( n, p ) call perm_vec_to_mat ( n, p, a ) return end subroutine pick ( n, w, z, a ) c*********************************************************************72 c cc PICK returns the PICK matrix. c c Formula: c c A(I,J) = ( 1 - conjg ( W(I) ) * W(J) ) c / ( 1 - conjg ( Z(I) ) * Z(J) ) c c Properties: c c A is Hermitian: A* = A. c c Discussion: c c Pick's matrix is related to an interpolation problem in the c complex unit disk |z| < 1. c c If z(1:n) are distinct points in the complex unit disk, and c w(1:n) are complex values, then Pick's matrix is positive c semidefinite if and only if there is a holomorphic function c phi from the unit disk to itself such that phi(z(i)) = w(i). c c phi is unique if and only if Pick's matrix is singular. c c Licensing: c c This code is distributed under the GNU LGPL license. c c Modified: c c 22 June 2011 c c Author: c c John Burkardt c c Reference: c c John McCarthy, c Pick's Theorem: What's the Big Deal? c American Mathematical Monthly, c Volume 110, Number 1, January 2003, pages 36-45. c c Parameters: c c Input, integer N, the order of the matrix. c c Input, double complex W(N), the parameters associated with the c numerator. c c Input, double complex Z(N), the parameters associated with the c denominator. Normally, the z's are distinct, and each of norm less c than 1. c c Output, double complex A(N,N), the matrix. c implicit none integer n double complex a(n,n) integer i integer j double complex one double complex w(n) double complex z(n) one = dcmplx ( 1.0D+00, 0.0D+00 ) do j = 1, n do i = 1, n a(i,j) = ( one - dconjg ( w(i) ) * w(j) ) & / ( one - dconjg ( z(i) ) * z(j) ) end do end do return end subroutine plu ( n, pivot, a ) c*********************************************************************72 c cc PLU returns a PLU matrix. c c Example: c c Input: c c N = 5 c PIVOT = ( 1, 3, 3, 5, 5 ) c c Output: c c A: c c 11 12 13 14 15 c 1.375 9.75 43.25 44.75 46.25 c 2.75 25 26.25 27.5 28.75 c 0.34375 2.4375 7.71875 17.625 73.125 c 0.6875 4.875 15.4375 60 61.5625 c c P: c c 1 0 0 0 0 c 0 0 1 0 0 c 0 1 0 0 0 c 0 0 0 0 1 c 0 0 0 1 0 c c L: c c 1 0 0 0 0 c 0.25 1 0 0 0 c 0.125 0.375 1 0 0 c 0.0625 0.1875 0.3125 1 0 c 0.03125 0.09375 0.15625 0.21875 1 c c U: c c 11 12 13 14 15 c 0 22 23 24 25 c 0 0 33 34 35 c 0 0 0 44 45 c 0 0 0 0 55 c c Note: c c The LINPACK routine DGEFA will factor the above A as: c c 11 12 13 14 15 c -0.125 22 23 24 25 c -0.25 -0.375 33 34 35 c -0.03125 -0.09375 -0.15625 44 45 c -0.0625 -0.1875 -0.3125 -0.21875 55 c c and the pivot information in the vector IPVT as: c c ( 1, 3, 3, 5, 5 ). c c The LAPACK routine DGETRF will factor the above A as: c c 11 12 13 14 15 c 0.25 22 23 24 25 c 0.125 0.375 33 34 35 c 0.0625 0.1875 0.3125 44 45 c 0.03125 0.09375 0.15625 0.21875 55 c c and the pivot information in the vector PIVOT as: c c ( 1, 3, 3, 5, 5 ). c c Method: c c The L factor will have unit diagonal, and subdiagonal entries c L(I,J) = ( 2 * J - 1 ) / 2^I, which should result in a unique c value for every entry. c c The U factor of A will have entries c U(I,J) = 10 * I + J, which should result in "nice" entries as long c as N < 10. c c The P factor can be deduced by applying the pivoting operations c specified by PIVOT in reverse order to the rows of the identity. c c Licensing: c c This code is distributed under the GNU LGPL license. c c Modified: c c 25 March 2015 c c Author: c c John Burkardt c c Parameters: c c Input, integer N, the order of the matrix. c c Input, integer PIVOT(N), the list of pivot rows. PIVOT(I) c must be a value between I and N, reflecting the choice of c pivot row on the I-th step. For no pivoting, set PIVOT(I) = I. c c Output, double precision A(N,N), the matrix. c implicit none integer n double precision a(n,n) double precision l(n,n) double precision p(n,n) integer pivot(n) double precision pl(n,n) double precision u(n,n) call plu_plu ( n, pivot, p, l, u ) call r8mat_mm ( n, n, n, p, l, pl ) call r8mat_mm ( n, n, n, pl, u, a ) return end subroutine plu_determinant ( n, pivot, value ) c*********************************************************************72 c cc PLU_DETERMINANT returns the determinant of the PLU matrix. c c Licensing: c c This code is distributed under the GNU LGPL license. c c Modified: c c 25 March 2015 c c Author: c c John Burkardt c c Parameters: c c Input, integer N, the order of the matrix. c c Input, integer PIVOT(N), the list of pivot rows. PIVOT(I) c must be a value between I and N, reflecting the choice of c pivot row on the I-th step. For no pivoting, set PIVOT(I) = I. c c Output, double precision VALUE, the determinant. c implicit none integer n logical found integer i integer i2 integer j double precision l(n,n) double precision p(n,n) integer pivot(n) double precision t double precision u(n,n) double precision value call plu_plu ( n, pivot, p, l, u ) value = 1.0D+00 do i = 1, n value = value * u(i,i) end do do i = 1, n found = .false. do i2 = i, n if ( p(i2,i) .eq. 1.0D+00 ) then found = .true. if ( i2 .ne. i ) then do j = 1, n t = p(i2,j) p(i2,j) = p(i,j) p(i,j) = t end do value = - value end if end if end do if ( .not. found ) then write ( *, '(a)' ) '' write ( *, '(a)' ) 'PLU_DETERMINANT - Fatal error!' write ( *, '(a)' ) ' Permutation matrix is illegal.' stop 1 end if end do return end subroutine plu_inverse ( n, pivot, a ) c*********************************************************************72 c cc PLU_INVERSE returns the inverse of a PLU matrix. c c Licensing: c c This code is distributed under the GNU LGPL license. c c Modified: c c 25 March 2015 c c Author: c c John Burkardt c c Parameters: c c Input, integer N, the order of the matrix. c c Input, integer PIVOT(N), the list of pivot rows. PIVOT(I) c must be a value between I and N, reflecting the choice of c pivot row on the I-th step. For no pivoting, set PIVOT(I) = I. c c Output, double precision A(N,N), the inverse matrix. c implicit none integer n double precision a(n,n) double precision l(n,n) double precision l_inverse(n,n) double precision p(n,n) double precision p_inverse(n,n) integer pivot(n) double precision pl_inverse(n,n) double precision u(n,n) double precision u_inverse(n,n) call plu_plu ( n, pivot, p, l, u ) call r8mat_transpose ( n, n, p, p_inverse ) call tri_l1_inverse ( n, l, l_inverse ) call tri_u_inverse ( n, u, u_inverse ) call r8mat_mm ( n, n, n, l_inverse, p_inverse, pl_inverse ) call r8mat_mm ( n, n, n, u_inverse, pl_inverse, a ) return end subroutine plu_plu ( n, pivot, p, l, u ) c*********************************************************************72 c cc PLU_PLU returns the PLU factors of the PLU matrix. c c Example: c c Input: c c N = 5 c PIVOT = ( 1, 3, 3, 5, 5 ) c c Output: c c P: c c 1 0 0 0 0 c 0 0 1 0 0 c 0 1 0 0 0 c 0 0 0 0 1 c 0 0 0 1 0 c c L: c c 1 0 0 0 0 c 0.25 1 0 0 0 c 0.125 0.375 1 0 0 c 0.0625 0.1875 0.3125 1 0 c 0.03125 0.09375 0.15625 0.21875 1 c c U: c c 11 12 13 14 15 c 0 22 23 24 25 c 0 0 33 34 35 c 0 0 0 44 45 c 0 0 0 0 55 c c Licensing: c c This code is distributed under the GNU LGPL license. c c Modified: c c 25 March 2015 c c Author: c c John Burkardt c c Parameters: c c Input, integer N, the order of the matrix. c c Input, integer PIVOT(N), the list of pivot rows. PIVOT(I) c must be a value between I and N, reflecting the choice of c pivot row on the I-th step. For no pivoting, set PIVOT(I) = I. c c Output, double precision P(N,N), L(N,N), U(N,N), the P, L and U factors c of A, as defined by Gaussian elimination with partial pivoting. c P is a permutation matrix, L is unit lower triangular, and U c is upper triangular. c implicit none integer n integer i integer j integer k double precision l(n,n) double precision p(n,n) integer pivot(n) double precision t double precision u(n,n) c c Check that the pivot vector is legal. c do i = 1, n if ( pivot(i) .lt. i ) then write ( *, '(a)' ) ' ' write ( *, '(a)' ) 'PLU_PLU - Fatal error!' write ( *, '(a,i8,a,i8)' ) ' PIVOT(', i, ') = ', pivot(i) write ( *, '(a)' ) ' but PIVOT(I) must be no less than I.' stop 1 else if ( n .lt. pivot(i) ) then write ( *, '(a)' ) ' ' write ( *, '(a)' ) 'PLU_PLU - Fatal error!' write ( *, '(a,i8,a,i8)' ) ' PIVOT(', i, ') = ', pivot(i) write ( *, '(a)' ) ' but PIVOT(I) must be no greater than N' write ( *, '(a,i8)' ) ' and N = ', n stop 1 end if end do c c Compute U. c do i = 1, n do j = 1, n if ( i .le. j ) then u(i,j) = dble ( 10 * i + j ) else u(i,j) = 0.0D+00 end if end do end do c c Compute L. c do i = 1, n do j = 1, n if ( i .lt. j ) then l(i,j) = 0.0D+00 else if ( j .eq. i ) then l(i,j) = 1.0D+00 else l(i,j) = dble ( 2 * j - 1 ) / dble ( 2 ** i ) end if end do end do c c Compute P. c do i = 1, n do j = 1, n if ( i .eq. j ) then p(i,j) = 1.0D+00 else p(i,j) = 0.0D+00 end if end do end do c c Apply the pivot permutations, in reverse order. c do i = n, 1, -1 if ( pivot(i) .ne. i ) then do j = 1, n t = p(i,j) p(i,j) = p(pivot(i),j) p(pivot(i),j) = t end do end if end do return end subroutine poisson ( nrow, ncol, a ) c*********************************************************************72 c cc POISSON returns the POISSON matrix. c c Formula: c c if ( I = J ) c A(I,J) = 4.0D+00 c else if ( I = J+1 or I = J-1 or I = J+NROW or I = J-NROW ) c A(I,J) = -1.0D+00 c else c A(I,J) = 0.0D+00 c c Example: c c NROW = NCOL = 3 c c 4 -1 0 | -1 0 0 | 0 0 0 c -1 4 -1 | 0 -1 0 | 0 0 0 c 0 -1 4 | 0 0 -1 | 0 0 0 c ---------------------------- c -1 0 0 | 4 -1 0 | -1 0 0 c 0 -1 0 | -1 4 -1 | 0 -1 0 c 0 0 -1 | 0 -1 4 | 0 0 -1 c ---------------------------- c 0 0 0 | -1 0 0 | 4 -1 0 c 0 0 0 | 0 -1 0 | -1 4 -1 c 0 0 0 | 0 0 -1 | 0 -1 4 c c Properties: c c A is symmetric: A' = A. c c Because A is symmetric, it is normal. c c Because A is normal, it is diagonalizable. c c A is integral, therefore det ( A ) is integral, and c det ( A ) * inverse ( A ) is integral. c c A is persymmetric: A(I,J) = A(N+1-J,N+1-I). c c A results from discretizing Poisson's equation with the c 5 point operator on a mesh of NROW by NCOL points. c c A has eigenvalues c c LAMBDA(I,J) = 4 - 2 * COS(I*PI/(NROW+1)) c - 2 * COS(J*PI/(NCOL+1)), I = 1 to NROW, J = 1 to NCOL. c c Licensing: c c This code is distributed under the GNU LGPL license. c c Modified: c c 05 March 2015 c c Author: c c John Burkardt c c Reference: c c Gene Golub, Charles Van Loan, c Matrix Computations, second edition, c Johns Hopkins University Press, Baltimore, Maryland, 1989 c (Section 4.5.4). c c Parameters: c c Input, integer NROW, NCOL, the number of rows and columns c in the grid. c c Output, double precision A(NROW*NCOL,NROW*NCOL), the matrix. c implicit none integer ncol integer nrow double precision a(nrow*ncol,nrow*ncol) integer i integer i1 integer j integer j1 integer n n = nrow * ncol do j = 1, n do i = 1, n a(i,j) = 0.0D+00 end do end do i = 0 do i1 = 1, nrow do j1 = 1, ncol i = i + 1 if ( 1 .lt. i1 ) then j = i - ncol a(i,j) = -1.0D+00 end if if ( 1 .lt. j1 ) then j = i - 1 a(i,j) = -1.0D+00 end if j = i a(i,j) = 4.0D+00 if ( j1 .lt. ncol ) then j = i + 1 a(i,j) = -1.0D+00 end if if ( i1 .lt. nrow ) then j = i + ncol a(i,j) = -1.0D+00 end if end do end do return end subroutine poisson_determinant ( nrow, ncol, determ ) c*********************************************************************72 c cc POISSON_DETERMINANT returns the determinant of the POISSON matrix. c c Licensing: c c This code is distributed under the GNU LGPL license. c c Modified: c c 05 March 2015 c c Author: c c John Burkardt c c Parameters: c c Input, integer NROW, NCOL, the number of rows and columns c in the grid. c c Output, double precision DETERM, the determinant. c implicit none integer ncol integer nrow double precision angle double precision cc(ncol) double precision cr(nrow) double precision determ integer i integer j integer k double precision r8_pi parameter ( r8_pi = 3.141592653589793D+00 ) do i = 1, nrow angle = dble ( i ) * r8_pi / dble ( nrow + 1 ) cr(i) = cos ( angle ) end do do i = 1, ncol angle = dble ( i ) * r8_pi / dble ( ncol + 1 ) cc(i) = cos ( angle ) end do determ = 1.0D+00 do i = 1, nrow do j = 1, ncol determ = determ & * ( 4.0D+00 - 2.0D+00 * cr(i) - 2.0D+00 * cc(j) ) end do end do return end subroutine poisson_eigenvalues ( nrow, ncol, lambda ) c*********************************************************************72 c cc POISSON_EIGENVALUES returns the eigenvalues of the POISSON matrix. c c Licensing: c c This code is distributed under the GNU LGPL license. c c Modified: c c 05 March 2015 c c Author: c c John Burkardt c c Parameters: c c Input, integer NROW, NCOL, the number of rows and columns c in the grid. c c Output, double precision LAMBDA(NROW*NCOL), the eigenvalues. c implicit none integer ncol integer nrow double precision angle double precision cc(ncol) double precision cr(nrow) double precision lambda(nrow*ncol) integer i integer j integer k double precision r8_pi parameter ( r8_pi = 3.141592653589793D+00 ) do i = 1, nrow angle = dble ( i ) * r8_pi / dble ( nrow + 1 ) cr(i) = cos ( angle ) end do do i = 1, ncol angle = dble ( i ) * r8_pi / dble ( ncol + 1 ) cc(i) = cos ( angle ) end do k = 0 do i = 1, nrow do j = 1, ncol k = k + 1 lambda(k) = 4.0D+00 - 2.0D+00 * cr(i) - 2.0D+00 * cc(j) end do end do return end subroutine poisson_rhs ( nrow, ncol, b ) c*********************************************************************72 c cc POISSON_RHS returns the right hand side of a Poisson linear system. c c Discussion: c c The Poisson matrix is associated with an NROW by NCOL rectangular c grid of points. c c Assume that the points are numbered from left to right, bottom to top. c c If the K-th point is in row I and column J, set X = I + J. c c This will be the solution to the linear system. c c The right hand side is easily determined from X. It is 0 for every c interior point. c c Example: c c NROW = 3, NCOL = 3 c c ^ c | 7 8 9 c J 4 5 6 c | 1 2 3 c | c +-----I----> c c Solution vector X = ( 2, 3, 4, 3, 4, 5, 4, 5, 6 ) c c Right hand side B = ( 2, 2, 8, 2, 0, 6, 8, 6, 14 ). c c Licensing: c c This code is distributed under the GNU LGPL license. c c Modified: c c 05 March 2015 c c Author: c c John Burkardt c c Reference: c c Gene Golub, Charles Van Loan, c Matrix Computations, second edition, c Johns Hopkins University Press, Baltimore, Maryland, 1989 c (Section 4.5.4). c c Parameters: c c Input, integer NROW, NCOL, the number of rows and columns c in the grid. c c Output, double precision B(NROW*NCOL), the right hand side. c implicit none integer ncol integer nrow double precision b(nrow*ncol) integer i integer j integer k integer n k = 0 do j = 1, nrow do i = 1, ncol k = k + 1 b(k) = 0.0D+00 if ( i .eq. 1 ) then b(k) = b(k) + dble ( i + j - 1 ) end if if ( j .eq. 1 ) then b(k) = b(k) + dble ( i + j - 1 ) end if if ( i .eq. ncol ) then b(k) = b(k) + dble ( i + j + 1 ) end if if ( j .eq. nrow ) then b(k) = b(k) + dble ( i + j + 1 ) end if end do end do return end subroutine poisson_solution ( nrow, ncol, x ) c*********************************************************************72 c cc POISSON_SOLUTION returns the solution of a Poisson linear system. c c Discussion: c c The Poisson matrix is associated with an NROW by NCOL rectangular c grid of points. c c Assume that the points are numbered from left to right, bottom to top. c c If the K-th point is in row I and column J, set X = I + J. c c This will be the solution to the linear system. c c Example: c c NROW = 3, NCOL = 3 c c ^ c | 7 8 9 c J 4 5 6 c | 1 2 3 c | c +-----I----> c c Solution vector X = ( 2, 3, 4, 3, 4, 5, 4, 5, 6 ) c c Licensing: c c This code is distributed under the GNU LGPL license. c c Modified: c c 05 March 2015 c c Author: c c John Burkardt c c Reference: c c Gene Golub, Charles Van Loan, c Matrix Computations, second edition, c Johns Hopkins University Press, Baltimore, Maryland, 1989 c (Section 4.5.4). c c Parameters: c c Input, integer NROW, NCOL, the number of rows and columns c in the grid. c c Output, double precision X(NROW*NCOL), the solution. c implicit none integer ncol integer nrow integer i integer j integer k double precision x(nrow*ncol) k = 0 do j = 1, nrow do i = 1, ncol k = k + 1 x(k) = dble ( i + j ) end do end do return end function prime ( n ) c*********************************************************************72 c cc PRIME returns any of the first PRIME_MAX prime numbers. c c Discussion: c c PRIME_MAX is 1600, and the largest prime stored is 13499. c c Thanks to Bart Vandewoestyne for pointing out a typo, 18 February 2005. c c Licensing: c c This code is distributed under the GNU LGPL license. c c Modified: c c 21 January 2007 c c Author: c c John Burkardt c c Reference: c c Milton Abramowitz, Irene Stegun, c Handbook of Mathematical Functions, c National Bureau of Standards, 1964, c ISBN: 0-486-61272-4, c LC: QA47.A34. c c Daniel Zwillinger, c CRC Standard Mathematical Tables and Formulae, c 30th Edition, c CRC Press, 1996, pages 95-98. c c Parameters: c c Input, integer N, the index of the desired prime number. c In general, is should be true that 0 <= N <= PRIME_MAX. c N = -1 returns PRIME_MAX, the index of the largest prime available. c N = 0 is legal, returning PRIME = 1. c c Output, integer PRIME, the N-th prime. If N is out of range, c PRIME is returned as -1. c implicit none integer prime_max parameter ( prime_max = 1600 ) integer i integer n integer npvec(prime_max) integer prime save npvec data ( npvec(i), i = 1, 100 ) / & 2, 3, 5, 7, 11, 13, 17, 19, 23, 29, & 31, 37, 41, 43, 47, 53, 59, 61, 67, 71, & 73, 79, 83, 89, 97, 101, 103, 107, 109, 113, & 127, 131, 137, 139, 149, 151, 157, 163, 167, 173, & 179, 181, 191, 193, 197, 199, 211, 223, 227, 229, & 233, 239, 241, 251, 257, 263, 269, 271, 277, 281, & 283, 293, 307, 311, 313, 317, 331, 337, 347, 349, & 353, 359, 367, 373, 379, 383, 389, 397, 401, 409, & 419, 421, 431, 433, 439, 443, 449, 457, 461, 463, & 467, 479, 487, 491, 499, 503, 509, 521, 523, 541 / data ( npvec(i), i = 101, 200 ) / & 547, 557, 563, 569, 571, 577, 587, 593, 599, 601, & 607, 613, 617, 619, 631, 641, 643, 647, 653, 659, & 661, 673, 677, 683, 691, 701, 709, 719, 727, 733, & 739, 743, 751, 757, 761, 769, 773, 787, 797, 809, & 811, 821, 823, 827, 829, 839, 853, 857, 859, 863, & 877, 881, 883, 887, 907, 911, 919, 929, 937, 941, & 947, 953, 967, 971, 977, 983, 991, 997, 1009, 1013, & 1019, 1021, 1031, 1033, 1039, 1049, 1051, 1061, 1063, 1069, & 1087, 1091, 1093, 1097, 1103, 1109, 1117, 1123, 1129, 1151, & 1153, 1163, 1171, 1181, 1187, 1193, 1201, 1213, 1217, 1223 / data ( npvec(i), i = 201, 300 ) / & 1229, 1231, 1237, 1249, 1259, 1277, 1279, 1283, 1289, 1291, & 1297, 1301, 1303, 1307, 1319, 1321, 1327, 1361, 1367, 1373, & 1381, 1399, 1409, 1423, 1427, 1429, 1433, 1439, 1447, 1451, & 1453, 1459, 1471, 1481, 1483, 1487, 1489, 1493, 1499, 1511, & 1523, 1531, 1543, 1549, 1553, 1559, 1567, 1571, 1579, 1583, & 1597, 1601, 1607, 1609, 1613, 1619, 1621, 1627, 1637, 1657, & 1663, 1667, 1669, 1693, 1697, 1699, 1709, 1721, 1723, 1733, & 1741, 1747, 1753, 1759, 1777, 1783, 1787, 1789, 1801, 1811, & 1823, 1831, 1847, 1861, 1867, 1871, 1873, 1877, 1879, 1889, & 1901, 1907, 1913, 1931, 1933, 1949, 1951, 1973, 1979, 1987 / data ( npvec(i), i = 301, 400 ) / & 1993, 1997, 1999, 2003, 2011, 2017, 2027, 2029, 2039, 2053, & 2063, 2069, 2081, 2083, 2087, 2089, 2099, 2111, 2113, 2129, & 2131, 2137, 2141, 2143, 2153, 2161, 2179, 2203, 2207, 2213, & 2221, 2237, 2239, 2243, 2251, 2267, 2269, 2273, 2281, 2287, & 2293, 2297, 2309, 2311, 2333, 2339, 2341, 2347, 2351, 2357, & 2371, 2377, 2381, 2383, 2389, 2393, 2399, 2411, 2417, 2423, & 2437, 2441, 2447, 2459, 2467, 2473, 2477, 2503, 2521, 2531, & 2539, 2543, 2549, 2551, 2557, 2579, 2591, 2593, 2609, 2617, & 2621, 2633, 2647, 2657, 2659, 2663, 2671, 2677, 2683, 2687, & 2689, 2693, 2699, 2707, 2711, 2713, 2719, 2729, 2731, 2741 / data ( npvec(i), i = 401, 500 ) / & 2749, 2753, 2767, 2777, 2789, 2791, 2797, 2801, 2803, 2819, & 2833, 2837, 2843, 2851, 2857, 2861, 2879, 2887, 2897, 2903, & 2909, 2917, 2927, 2939, 2953, 2957, 2963, 2969, 2971, 2999, & 3001, 3011, 3019, 3023, 3037, 3041, 3049, 3061, 3067, 3079, & 3083, 3089, 3109, 3119, 3121, 3137, 3163, 3167, 3169, 3181, & 3187, 3191, 3203, 3209, 3217, 3221, 3229, 3251, 3253, 3257, & 3259, 3271, 3299, 3301, 3307, 3313, 3319, 3323, 3329, 3331, & 3343, 3347, 3359, 3361, 3371, 3373, 3389, 3391, 3407, 3413, & 3433, 3449, 3457, 3461, 3463, 3467, 3469, 3491, 3499, 3511, & 3517, 3527, 3529, 3533, 3539, 3541, 3547, 3557, 3559, 3571 / data ( npvec(i), i = 501, 600 ) / & 3581, 3583, 3593, 3607, 3613, 3617, 3623, 3631, 3637, 3643, & 3659, 3671, 3673, 3677, 3691, 3697, 3701, 3709, 3719, 3727, & 3733, 3739, 3761, 3767, 3769, 3779, 3793, 3797, 3803, 3821, & 3823, 3833, 3847, 3851, 3853, 3863, 3877, 3881, 3889, 3907, & 3911, 3917, 3919, 3923, 3929, 3931, 3943, 3947, 3967, 3989, & 4001, 4003, 4007, 4013, 4019, 4021, 4027, 4049, 4051, 4057, & 4073, 4079, 4091, 4093, 4099, 4111, 4127, 4129, 4133, 4139, & 4153, 4157, 4159, 4177, 4201, 4211, 4217, 4219, 4229, 4231, & 4241, 4243, 4253, 4259, 4261, 4271, 4273, 4283, 4289, 4297, & 4327, 4337, 4339, 4349, 4357, 4363, 4373, 4391, 4397, 4409 / data ( npvec(i), i = 601, 700 ) / & 4421, 4423, 4441, 4447, 4451, 4457, 4463, 4481, 4483, 4493, & 4507, 4513, 4517, 4519, 4523, 4547, 4549, 4561, 4567, 4583, & 4591, 4597, 4603, 4621, 4637, 4639, 4643, 4649, 4651, 4657, & 4663, 4673, 4679, 4691, 4703, 4721, 4723, 4729, 4733, 4751, & 4759, 4783, 4787, 4789, 4793, 4799, 4801, 4813, 4817, 4831, & 4861, 4871, 4877, 4889, 4903, 4909, 4919, 4931, 4933, 4937, & 4943, 4951, 4957, 4967, 4969, 4973, 4987, 4993, 4999, 5003, & 5009, 5011, 5021, 5023, 5039, 5051, 5059, 5077, 5081, 5087, & 5099, 5101, 5107, 5113, 5119, 5147, 5153, 5167, 5171, 5179, & 5189, 5197, 5209, 5227, 5231, 5233, 5237, 5261, 5273, 5279 / data ( npvec(i), i = 701, 800 ) / & 5281, 5297, 5303, 5309, 5323, 5333, 5347, 5351, 5381, 5387, & 5393, 5399, 5407, 5413, 5417, 5419, 5431, 5437, 5441, 5443, & 5449, 5471, 5477, 5479, 5483, 5501, 5503, 5507, 5519, 5521, & 5527, 5531, 5557, 5563, 5569, 5573, 5581, 5591, 5623, 5639, & 5641, 5647, 5651, 5653, 5657, 5659, 5669, 5683, 5689, 5693, & 5701, 5711, 5717, 5737, 5741, 5743, 5749, 5779, 5783, 5791, & 5801, 5807, 5813, 5821, 5827, 5839, 5843, 5849, 5851, 5857, & 5861, 5867, 5869, 5879, 5881, 5897, 5903, 5923, 5927, 5939, & 5953, 5981, 5987, 6007, 6011, 6029, 6037, 6043, 6047, 6053, & 6067, 6073, 6079, 6089, 6091, 6101, 6113, 6121, 6131, 6133 / data ( npvec(i), i = 801, 900 ) / & 6143, 6151, 6163, 6173, 6197, 6199, 6203, 6211, 6217, 6221, & 6229, 6247, 6257, 6263, 6269, 6271, 6277, 6287, 6299, 6301, & 6311, 6317, 6323, 6329, 6337, 6343, 6353, 6359, 6361, 6367, & 6373, 6379, 6389, 6397, 6421, 6427, 6449, 6451, 6469, 6473, & 6481, 6491, 6521, 6529, 6547, 6551, 6553, 6563, 6569, 6571, & 6577, 6581, 6599, 6607, 6619, 6637, 6653, 6659, 6661, 6673, & 6679, 6689, 6691, 6701, 6703, 6709, 6719, 6733, 6737, 6761, & 6763, 6779, 6781, 6791, 6793, 6803, 6823, 6827, 6829, 6833, & 6841, 6857, 6863, 6869, 6871, 6883, 6899, 6907, 6911, 6917, & 6947, 6949, 6959, 6961, 6967, 6971, 6977, 6983, 6991, 6997 / data ( npvec(i), i = 901, 1000 ) / & 7001, 7013, 7019, 7027, 7039, 7043, 7057, 7069, 7079, 7103, & 7109, 7121, 7127, 7129, 7151, 7159, 7177, 7187, 7193, 7207, & 7211, 7213, 7219, 7229, 7237, 7243, 7247, 7253, 7283, 7297, & 7307, 7309, 7321, 7331, 7333, 7349, 7351, 7369, 7393, 7411, & 7417, 7433, 7451, 7457, 7459, 7477, 7481, 7487, 7489, 7499, & 7507, 7517, 7523, 7529, 7537, 7541, 7547, 7549, 7559, 7561, & 7573, 7577, 7583, 7589, 7591, 7603, 7607, 7621, 7639, 7643, & 7649, 7669, 7673, 7681, 7687, 7691, 7699, 7703, 7717, 7723, & 7727, 7741, 7753, 7757, 7759, 7789, 7793, 7817, 7823, 7829, & 7841, 7853, 7867, 7873, 7877, 7879, 7883, 7901, 7907, 7919 / data ( npvec(i), i = 1001, 1100 ) / & 7927, 7933, 7937, 7949, 7951, 7963, 7993, 8009, 8011, 8017, & 8039, 8053, 8059, 8069, 8081, 8087, 8089, 8093, 8101, 8111, & 8117, 8123, 8147, 8161, 8167, 8171, 8179, 8191, 8209, 8219, & 8221, 8231, 8233, 8237, 8243, 8263, 8269, 8273, 8287, 8291, & 8293, 8297, 8311, 8317, 8329, 8353, 8363, 8369, 8377, 8387, & 8389, 8419, 8423, 8429, 8431, 8443, 8447, 8461, 8467, 8501, & 8513, 8521, 8527, 8537, 8539, 8543, 8563, 8573, 8581, 8597, & 8599, 8609, 8623, 8627, 8629, 8641, 8647, 8663, 8669, 8677, & 8681, 8689, 8693, 8699, 8707, 8713, 8719, 8731, 8737, 8741, & 8747, 8753, 8761, 8779, 8783, 8803, 8807, 8819, 8821, 8831 / data ( npvec(i), i = 1101, 1200 ) / & 8837, 8839, 8849, 8861, 8863, 8867, 8887, 8893, 8923, 8929, & 8933, 8941, 8951, 8963, 8969, 8971, 8999, 9001, 9007, 9011, & 9013, 9029, 9041, 9043, 9049, 9059, 9067, 9091, 9103, 9109, & 9127, 9133, 9137, 9151, 9157, 9161, 9173, 9181, 9187, 9199, & 9203, 9209, 9221, 9227, 9239, 9241, 9257, 9277, 9281, 9283, & 9293, 9311, 9319, 9323, 9337, 9341, 9343, 9349, 9371, 9377, & 9391, 9397, 9403, 9413, 9419, 9421, 9431, 9433, 9437, 9439, & 9461, 9463, 9467, 9473, 9479, 9491, 9497, 9511, 9521, 9533, & 9539, 9547, 9551, 9587, 9601, 9613, 9619, 9623, 9629, 9631, & 9643, 9649, 9661, 9677, 9679, 9689, 9697, 9719, 9721, 9733 / data ( npvec(i), i = 1201, 1300 ) / & 9739, 9743, 9749, 9767, 9769, 9781, 9787, 9791, 9803, 9811, & 9817, 9829, 9833, 9839, 9851, 9857, 9859, 9871, 9883, 9887, & 9901, 9907, 9923, 9929, 9931, 9941, 9949, 9967, 9973,10007, & 10009,10037,10039,10061,10067,10069,10079,10091,10093,10099, & 10103,10111,10133,10139,10141,10151,10159,10163,10169,10177, & 10181,10193,10211,10223,10243,10247,10253,10259,10267,10271, & 10273,10289,10301,10303,10313,10321,10331,10333,10337,10343, & 10357,10369,10391,10399,10427,10429,10433,10453,10457,10459, & 10463,10477,10487,10499,10501,10513,10529,10531,10559,10567, & 10589,10597,10601,10607,10613,10627,10631,10639,10651,10657 / data ( npvec(i), i = 1301, 1400 ) / & 10663,10667,10687,10691,10709,10711,10723,10729,10733,10739, & 10753,10771,10781,10789,10799,10831,10837,10847,10853,10859, & 10861,10867,10883,10889,10891,10903,10909,10937,10939,10949, & 10957,10973,10979,10987,10993,11003,11027,11047,11057,11059, & 11069,11071,11083,11087,11093,11113,11117,11119,11131,11149, & 11159,11161,11171,11173,11177,11197,11213,11239,11243,11251, & 11257,11261,11273,11279,11287,11299,11311,11317,11321,11329, & 11351,11353,11369,11383,11393,11399,11411,11423,11437,11443, & 11447,11467,11471,11483,11489,11491,11497,11503,11519,11527, & 11549,11551,11579,11587,11593,11597,11617,11621,11633,11657 / data ( npvec(i), i = 1401, 1500 ) / & 11677,11681,11689,11699,11701,11717,11719,11731,11743,11777, & 11779,11783,11789,11801,11807,11813,11821,11827,11831,11833, & 11839,11863,11867,11887,11897,11903,11909,11923,11927,11933, & 11939,11941,11953,11959,11969,11971,11981,11987,12007,12011, & 12037,12041,12043,12049,12071,12073,12097,12101,12107,12109, & 12113,12119,12143,12149,12157,12161,12163,12197,12203,12211, & 12227,12239,12241,12251,12253,12263,12269,12277,12281,12289, & 12301,12323,12329,12343,12347,12373,12377,12379,12391,12401, & 12409,12413,12421,12433,12437,12451,12457,12473,12479,12487, & 12491,12497,12503,12511,12517,12527,12539,12541,12547,12553 / data ( npvec(i), i = 1501, 1600 ) / & 12569,12577,12583,12589,12601,12611,12613,12619,12637,12641, & 12647,12653,12659,12671,12689,12697,12703,12713,12721,12739, & 12743,12757,12763,12781,12791,12799,12809,12821,12823,12829, & 12841,12853,12889,12893,12899,12907,12911,12917,12919,12923, & 12941,12953,12959,12967,12973,12979,12983,13001,13003,13007, & 13009,13033,13037,13043,13049,13063,13093,13099,13103,13109, & 13121,13127,13147,13151,13159,13163,13171,13177,13183,13187, & 13217,13219,13229,13241,13249,13259,13267,13291,13297,13309, & 13313,13327,13331,13337,13339,13367,13381,13397,13399,13411, & 13417,13421,13441,13451,13457,13463,13469,13477,13487,13499 / if ( n .eq. -1 ) then prime = prime_max else if ( n .eq. 0 ) then prime = 1 else if ( n .le. prime_max ) then prime = npvec(n) else prime = -1 write ( *, '(a)' ) ' ' write ( *, '(a)' ) 'PRIME - Fatal error!' write ( *, '(a,i8)' ) ' Illegal prime index N = ', n write ( *, '(a,i8)' ) & ' N should be between 1 and PRIME_MAX =', prime_max stop 1 end if return end subroutine prolate ( alpha, n, a ) c*********************************************************************72 c cc PROLATE returns the PROLATE matrix. c c Formula: c c If ( I .eq. J ) then c A(I,J) = 2 * ALPHA c else c K = abs ( I - J ) + 1 c A(I,J) = sin ( 2 * pi * ALPHA * K ) / ( pi * K ) c c Example: c c N = 5, ALPHA = 0.25 c c 0.5 0.0D+00 -0.106103 0.0 0.0636620 c 0.0D+00 0.5 0.0 -0.106103 0.0D+00 c -0.106103 0.0D+00 0.5 0.0 -0.106103 c 0.0D+00 -0.106103 0.0 0.5 0.0D+00 c 0.0636620 0.0D+00 -0.106103 0.0 0.5 c c Properties: c c A is symmetric: A' = A. c c Because A is symmetric, it is normal. c c Because A is normal, it is diagonalizable. c c A is persymmetric: A(I,J) = A(N+1-J,N+1-I). c c A is centrosymmetric: A(I,J) = A(N+1-I,N+1-J). c c A is Toeplitz: constant along diagonals. c c If 0 .lt. ALPHA .lt. 0.5, then c A is positive definite, c the eigenvalues of A are distinct, c the eigenvalues lie in (0,1) and cluster around 0 and 1. c c The family of matrices is nested as a function of N. c c Licensing: c c This code is distributed under the GNU LGPL license. c c Modified: c c 21 June 2011 c c Author: c c John Burkardt c c Reference: c c James Varah, c The Prolate Matrix, c Linear Algebra and Applications, c Volume 187, pages 269-278, 1993. c c Parameters: c c Input, double precision ALPHA, the parameter. c c Input, integer N, the order of the matrix. c c Output, double precision A(N,N), the matrix. c implicit none integer n double precision a(n,n) double precision alpha double precision angle integer i integer j integer k double precision r8_pi parameter ( r8_pi = 3.141592653589793D+00 ) do j = 1, n do i = 1, n if ( i .eq. j ) then a(i,j) = 2.0D+00 * alpha else k = abs ( i - j ) + 1 angle = 2.0D+00 * r8_pi * alpha * dble ( k ) a(i,j) = sin ( angle ) / ( r8_pi * dble ( k ) ) end if end do end do return end subroutine propa_no_random ( prob, k, n, key, a ) c*********************************************************************72 c cc PROPA_NO_RANDOM returns a PROPA_NO_RANDOM matrix. c c Discussion: c c The matrix is a random matrix that does not have property A. c c Licensing: c c This code is distributed under the GNU LGPL license. c c Modified: c c 21 June 2011 c c Author: c c John Burkardt c c Parameters: c c Input, double precision PROB, the probability that a link between c two eligible nodes will be made. c c Input, integer K, the number of illegal links between nodes c to make. The routine will TRY to make this many illegal links. However, c it is obviously possible to make K too big. c c Input, integer N, the order of the matrix. c c Input, integer KEY, a positive integer that selects the data. c c Output, double precision A(N,N), the matrix. c implicit none integer n double precision a(n,n) integer bad double precision chance integer i integer i4_uniform_ab integer j integer k integer key double precision prob double precision r8_uniform_01 integer seed integer set(n) integer tries do j = 1, n do i = 1, n a(i,j) = 0.0D+00 end do end do c c Assign each index randomly to one of two sets. c SET(I) is 0 if I is in set 0, and 1 if it is in set 1. c seed = key call subset_random ( n, seed, set ) do j = 1, n do i = 1, n if ( set(i) .ne. set(j) ) then chance = r8_uniform_01 ( seed ) if ( chance .le. prob ) then a(i,j) = 1.0D+00 end if end if end do end do c c Now repeatedly pick a pair of indices, and consider setting the c corresponding entry of A to 1. c bad = 0 tries = 0 10 continue tries = tries + 1 if ( 1000 .lt. tries ) then go to 20 end if if ( k .le. bad ) then go to 20 end if i = i4_uniform_ab ( 1, n, seed ) j = i4_uniform_ab ( 1, n, seed ) if ( i .eq. j ) then go to 10 end if if ( set(i) .ne. set(j) ) then go to 10 end if if ( a(i,j) .ne. 0.0D+00 .and. a(j,i) .ne. 0.0D+00 ) then go to 10 end if if ( a(i,j) .eq. 0.0D+00 ) then a(i,j) = 1.0D+00 else a(j,i) = 1.0D+00 end if bad = bad + 1 go to 10 20 continue return end subroutine propa_yes_random ( prob, n, key, a ) c*********************************************************************72 c cc PROPA_YES_RANDOM returns a PROPA_YES_RANDOM matrix. c c Discussion: c c The matrix is a random matrix with property A. c c Licensing: c c This code is distributed under the GNU LGPL license. c c Modified: c c 21 June 2011 c c Author: c c John Burkardt c c Parameters: c c Input, double precision PROB, the probability that a link between c two eligible nodes will be made. c c Input, integer N, the order of the matrix. c c Input, integer KEY, a positive integer that selects the data. c c Output, double precision A(N,N), the matrix. c implicit none integer n double precision a(n,n) double precision chance integer i integer j integer key double precision prob double precision r8_uniform_01 integer seed integer set(n) do j = 1, n do i = 1, n a(i,j) = 0.0D+00 end do end do c c Assign each index randomly to one of two sets. c SET(I) is 0 if I is in set 0, and 1 if it is in set 1. c seed = key call subset_random ( n, seed, set ) do i = 1, n do j = 1, n if ( set(i) .ne. set(j) ) then chance = r8_uniform_01 ( seed ) if ( chance .le. prob ) then a(i,j) = 1.0D+00 end if end if end do end do return end subroutine quaternion_i ( a ) c*********************************************************************72 c cc QUATERNION_I returns a 4 by 4 matrix that behaves like the quaternion unit I. c c Formula: c c 0 1 0 0 c -1 0 0 0 c 0 0 0 -1 c 0 0 1 0 c c Properties: c c I * 1 = I c I * I = - 1 c I * J = K c I * K = - J c c Licensing: c c This code is distributed under the GNU LGPL license. c c Modified: c c 21 June 2011 c c Author: c c John Burkardt c c Parameters: c c Output, double precision A(4,4), the matrix. c implicit none double precision a(4,4) double precision a_save(4,4) save a_save c c Note that the matrix entries are listed by column. c data a_save / & 0.0D+00, -1.0D+00, 0.0D+00, 0.0D+00, & 1.0D+00, 0.0D+00, 0.0D+00, 0.0D+00, & 0.0D+00, 0.0D+00, 0.0D+00, 1.0D+00, & 0.0D+00, 0.0D+00, -1.0D+00, 0.0D+00 / call r8mat_copy ( 4, 4, a_save, a ) return end subroutine quaternion_j ( a ) c*********************************************************************72 c cc QUATERNION_J returns a 4 by 4 matrix that behaves like the quaternion unit J. c c Formula: c c 0 0 1 0 c 0 0 0 1 c -1 0 0 0 c 0 -1 0 0 c c Properties: c c J * 1 = J c J * I = - K c J * J = - 1 c J * K = I c c Licensing: c c This code is distributed under the GNU LGPL license. c c Modified: c c 21 June 2011 c c Author: c c John Burkardt c c Parameters: c c Output, double precision A(4,4), the matrix. c implicit none double precision a(4,4) double precision a_save(4,4) save a_save c c Note that the matrix entries are listed by column. c data a_save / & 0.0D+00, 0.0D+00, -1.0D+00, 0.0D+00, & 0.0D+00, 0.0D+00, 0.0D+00, -1.0D+00, & 1.0D+00, 0.0D+00, 0.0D+00, 0.0D+00, & 0.0D+00, 1.0D+00, 0.0D+00, 0.0D+00 / call r8mat_copy ( 4, 4, a_save, a ) return end subroutine quaternion_k ( a ) c*********************************************************************72 c cc QUATERNION_K returns a 4 by 4 matrix that behaves like the quaternion unit K. c c Formula: c c 0 0 0 1 c 0 0 -1 0 c 0 1 0 0 c -1 0 0 0 c c Properties: c c K * 1 = K c K * I = J c K * J = - I c K * K = - 1 c c Licensing: c c This code is distributed under the GNU LGPL license. c c Modified: c c 21 June 2011 c c Author: c c John Burkardt c c Parameters: c c Output, double precision A(4,4), the matrix. c implicit none double precision a(4,4) a(1,1) = 0.0D+00 a(2,1) = 0.0D+00 a(3,1) = 0.0D+00 a(4,1) = -1.0D+00 a(1,2) = 0.0D+00 a(2,2) = 0.0D+00 a(3,2) = 1.0D+00 a(4,2) = 0.0D+00 a(1,3) = 0.0D+00 a(2,3) = -1.0D+00 a(3,3) = 0.0D+00 a(4,3) = 0.0D+00 a(1,4) = 1.0D+00 a(2,4) = 0.0D+00 a(3,4) = 0.0D+00 a(4,4) = 0.0D+00 return end function r4_uniform_01 ( seed ) c*********************************************************************72 c cc R4_UNIFORM_01 returns a unit pseudorandom R4. c c Discussion: c c This routine implements the recursion c c seed = 16807 * seed mod ( 2^31 - 1 ) c r4_uniform_01 = seed / ( 2^31 - 1 ) c c The integer arithmetic never requires more than 32 bits, c including a sign bit. c c If the initial seed is 12345, then the first three computations are c c Input Output R4_UNIFORM_01 c SEED SEED c c 12345 207482415 0.096616 c 207482415 1790989824 0.833995 c 1790989824 2035175616 0.947702 c c Licensing: c c This code is distributed under the GNU LGPL license. c c Modified: c c 11 August 2004 c c Author: c c John Burkardt c c Reference: c c Paul Bratley, Bennett Fox, Linus Schrage, c A Guide to Simulation, c Second Edition, c Springer, 1987, c ISBN: 0387964673, c LC: QA76.9.C65.B73. c c Bennett Fox, c Algorithm 647: c Implementation and Relative Efficiency of Quasirandom c Sequence Generators, c ACM Transactions on Mathematical Software, c Volume 12, Number 4, December 1986, pages 362-376. c c Pierre L'Ecuyer, c Random Number Generation, c in Handbook of Simulation, c edited by Jerry Banks, c Wiley, 1998, c ISBN: 0471134031, c LC: T57.62.H37. c c Peter Lewis, Allen Goodman, James Miller, c A Pseudo-Random Number Generator for the System/360, c IBM Systems Journal, c Volume 8, Number 2, 1969, pages 136-143. c c Parameters: c c Input/output, integer SEED, the "seed" value, which should NOT be 0. c On output, SEED has been updated. c c Output, real R4_UNIFORM_01, a new pseudorandom variate, c strictly between 0 and 1. c implicit none integer i4_huge parameter ( i4_huge = 2147483647 ) integer k integer seed real r4_uniform_01 if ( seed .eq. 0 ) then write ( *, '(a)' ) ' ' write ( *, '(a)' ) 'R4_UNIFORM_01 - Fatal error!' write ( *, '(a)' ) ' Input value of SEED = 0.' stop 1 end if k = seed / 127773 seed = 16807 * ( seed - k * 127773 ) - k * 2836 if ( seed .lt. 0 ) then seed = seed + i4_huge end if c c Although SEED can be represented exactly as a 32 bit integer, c it generally cannot be represented exactly as a 32 bit real number! c r4_uniform_01 = real ( dble ( seed ) * 4.656612875D-10 ) return end function r8_choose ( n, k ) c*********************************************************************72 c cc R8_CHOOSE computes the binomial coefficient C(N,K) as an R8. c c Discussion: c c The value is calculated in such a way as to avoid overflow and c roundoff. The calculation is done in R8 arithmetic. c c The formula used is: c c C(N,K) = N! / ( K! * (N-K)! ) c c Licensing: c c This code is distributed under the GNU LGPL license. c c Modified: c c 07 June 2008 c c Author: c c John Burkardt c c Reference: c c ML Wolfson, HV Wright, c Algorithm 160: c Combinatorial of M Things Taken N at a Time, c Communications of the ACM, c Volume 6, Number 4, April 1963, page 161. c c Parameters: c c Input, integer N, K, are the values of N and K. c c Output, double precision R8_CHOOSE, the number of combinations of N c things taken K at a time. c implicit none integer i integer k integer mn integer mx integer n double precision r8_choose double precision value mn = min ( k, n - k ) if ( mn .lt. 0 ) then value = 0.0D+00 else if ( mn .eq. 0 ) then value = 1.0D+00 else mx = max ( k, n - k ) value = dble ( mx + 1 ) do i = 2, mn value = ( value * dble ( mx + i ) ) / dble ( i ) end do end if r8_choose = value return end function r8_epsilon ( ) c*********************************************************************72 c cc R8_EPSILON returns the R8 roundoff unit. c c Discussion: c c The roundoff unit is a number R which is a power of 2 with the c property that, to the precision of the computer's arithmetic, c 1 .lt. 1 + R c but c 1 = ( 1 + R / 2 ) c c FORTRAN90 provides the superior library routine c c EPSILON ( X ) c c Licensing: c c This code is distributed under the GNU LGPL license. c c Modified: c c 01 September 2012 c c Author: c c John Burkardt c c Parameters: c c Output, double precision R8_EPSILON, the R8 roundoff unit. c implicit none double precision r8_epsilon r8_epsilon = 2.220446049250313D-016 return end function r8_factorial ( n ) c*********************************************************************72 c cc R8_FACTORIAL computes the factorial of N. c c Discussion: c c factorial ( N ) = product ( 1 <= I <= N ) I c c Licensing: c c This code is distributed under the GNU LGPL license. c c Modified: c c 07 June 2008 c c Author: c c John Burkardt c c Parameters: c c Input, integer N, the argument of the factorial function. c If N is less than 1, the function value is returned as 1. c c Output, double precision R8_FACTORIAL, the factorial of N. c implicit none integer i integer n double precision r8_factorial r8_factorial = 1.0D+00 do i = 1, n r8_factorial = r8_factorial * dble ( i ) end do return end function r8_huge ( ) c*********************************************************************72 c cc R8_HUGE returns a "huge" R8. c c Licensing: c c This code is distributed under the GNU LGPL license. c c Modified: c c 13 April 2004 c c Author: c c John Burkardt c c Parameters: c c Output, double precision R8_HUGE, a huge number. c implicit none double precision r8_huge r8_huge = 1.0D+30 return end function r8_mop ( i ) c*********************************************************************72 c cc R8_MOP returns the I-th power of -1 as an R8 value. c c Discussion: c c An R8 is a double precision real value. c c Licensing: c c This code is distributed under the GNU LGPL license. c c Modified: c c 26 July 2008 c c Author: c c John Burkardt c c Parameters: c c Input, integer I, the power of -1. c c Output, double precision R8_MOP, the I-th power of -1. c implicit none integer i double precision r8_mop if ( mod ( i, 2 ) .eq. 0 ) then r8_mop = + 1.0D+00 else r8_mop = - 1.0D+00 end if return end function r8_normal_01 ( seed ) c*********************************************************************72 c cc R8_NORMAL_01 returns a unit pseudonormal R8. c c Discussion: c c Because this routine uses the Box Muller method, it requires pairs c of uniform random values to generate a pair of normal random values. c This means that on every other call, the code can use the second c value that it calculated. c c However, if the user has changed the SEED value between calls, c the routine automatically resets itself and discards the saved data. c c Licensing: c c This code is distributed under the GNU LGPL license. c c Modified: c c 08 January 2007 c c Author: c c John Burkardt c c Parameters: c c Input/output, integer SEED, a seed for the random number generator. c c Output, double precision R8_NORMAL_01, a sample of the standard normal PDF. c implicit none double precision r8_pi parameter ( r8_pi = 3.141592653589793D+00 ) double precision r1 double precision r2 double precision r8_normal_01 double precision r8_uniform_01 integer seed integer seed1 integer seed2 integer seed3 integer used double precision v1 double precision v2 save seed1 save seed2 save seed3 save used save v2 data seed2 / 0 / data used / 0 / data v2 / 0.0D+00 / c c If USED is odd, but the input SEED does not match c the output SEED on the previous call, then the user has changed c the seed. Wipe out internal memory. c if ( mod ( used, 2 ) .eq. 1 ) then if ( seed .ne. seed2 ) then used = 0 seed1 = 0 seed2 = 0 seed3 = 0 v2 = 0.0D+00 end if end if c c If USED is even, generate two uniforms, create two normals, c return the first normal and its corresponding seed. c if ( mod ( used, 2 ) .eq. 0 ) then seed1 = seed r1 = r8_uniform_01 ( seed ) if ( r1 .eq. 0.0D+00 ) then write ( *, '(a)' ) ' ' write ( *, '(a)' ) 'R8_NORMAL_01 - Fatal error!' write ( *, '(a)' ) ' R8_UNIFORM_01 returned a value of 0.' stop 1 end if seed2 = seed r2 = r8_uniform_01 ( seed ) seed3 = seed v1 = sqrt ( -2.0D+00 * log ( r1 ) ) & * cos ( 2.0D+00 * r8_pi * r2 ) v2 = sqrt ( -2.0D+00 * log ( r1 ) ) & * sin ( 2.0D+00 * r8_pi * r2 ) r8_normal_01 = v1 seed = seed2 c c If USED is odd (and the input SEED matched the output value from c the previous call), return the second normal and its corresponding seed. c else r8_normal_01 = v2 seed = seed3 end if used = used + 1 return end function r8_pi ( ) c*********************************************************************72 c cc R8_PI returns the value of pi as an R8. c c Licensing: c c This code is distributed under the GNU LGPL license. c c Modified: c c 01 January 2007 c c Author: c c John Burkardt c c Parameters: c c Output, double precision R8_PI, the value of pi. c implicit none double precision r8_pi r8_pi = 3.141592653589793D+00 return end subroutine r8_swap ( x, y ) c*********************************************************************72 c cc R8_SWAP switches two R8's. c c Licensing: c c This code is distributed under the GNU LGPL license. c c Modified: c c 30 November 1998 c c Author: c c John Burkardt c c Parameters: c c Input/output, double precision X, Y. On output, the values of X and c Y have been interchanged. c implicit none double precision x double precision y double precision z z = x x = y y = z return end function r8_uniform_01 ( seed ) c*********************************************************************72 c cc R8_UNIFORM_01 returns a unit pseudorandom R8. c c Discussion: c c This routine implements the recursion c c seed = 16807 * seed mod ( 2^31 - 1 ) c r8_uniform_01 = seed / ( 2^31 - 1 ) c c The integer arithmetic never requires more than 32 bits, c including a sign bit. c c If the initial seed is 12345, then the first three computations are c c Input Output R8_UNIFORM_01 c SEED SEED c c 12345 207482415 0.096616 c 207482415 1790989824 0.833995 c 1790989824 2035175616 0.947702 c c Licensing: c c This code is distributed under the GNU LGPL license. c c Modified: c c 11 August 2004 c c Author: c c John Burkardt c c Reference: c c Paul Bratley, Bennett Fox, Linus Schrage, c A Guide to Simulation, c Springer Verlag, pages 201-202, 1983. c c Pierre L'Ecuyer, c Random Number Generation, c in Handbook of Simulation, c edited by Jerry Banks, c Wiley Interscience, page 95, 1998. c c Bennett Fox, c Algorithm 647: c Implementation and Relative Efficiency of Quasirandom c Sequence Generators, c ACM Transactions on Mathematical Software, c Volume 12, Number 4, pages 362-376, 1986. c c Peter Lewis, Allen Goodman, James Miller, c A Pseudo-Random Number Generator for the System/360, c IBM Systems Journal, c Volume 8, pages 136-143, 1969. c c Parameters: c c Input/output, integer SEED, the "seed" value, which should NOT be 0. c On output, SEED has been updated. c c Output, double precision R8_UNIFORM_01, a new pseudorandom variate, c strictly between 0 and 1. c implicit none double precision r8_uniform_01 integer k integer seed if ( seed .eq. 0 ) then write ( *, '(a)' ) ' ' write ( *, '(a)' ) 'R8_UNIFORM_01 - Fatal error!' write ( *, '(a)' ) ' Input value of SEED = 0.' stop 1 end if k = seed / 127773 seed = 16807 * ( seed - k * 127773 ) - k * 2836 if ( seed .lt. 0 ) then seed = seed + 2147483647 end if c c Although SEED can be represented exactly as a 32 bit integer, c it generally cannot be represented exactly as a 32 bit real number! c r8_uniform_01 = dble ( seed ) * 4.656612875D-10 return end function r8_uniform_ab ( a, b, seed ) c*********************************************************************72 c cc R8_UNIFORM_AB returns a pseudorandom R8 scaled to [A,B]. c c Licensing: c c This code is distributed under the GNU LGPL license. c c Modified: c c 06 January 2006 c c Author: c c John Burkardt c c Parameters: c c Input, double precision A, B, the limits of the interval. c c Input/output, integer SEED, the "seed" value, which should NOT be 0. c On output, SEED has been updated. c c Output, double precision R8_UNIFORM_AB, a number strictly between A and B. c implicit none double precision a double precision b integer i4_huge parameter ( i4_huge = 2147483647 ) integer k double precision r8_uniform_ab integer seed if ( seed .eq. 0 ) then write ( *, '(a)' ) ' ' write ( *, '(a)' ) 'R8_UNIFORM_AB - Fatal error!' write ( *, '(a)' ) ' Input value of SEED = 0.' stop 1 end if k = seed / 127773 seed = 16807 * ( seed - k * 127773 ) - k * 2836 if ( seed .lt. 0 ) then seed = seed + i4_huge end if r8_uniform_ab = a + ( b - a ) * dble ( seed ) * 4.656612875D-10 return end subroutine r8col_swap ( m, n, a, j1, j2 ) c*********************************************************************72 c cc R8COL_SWAP swaps columns I and J of an R8COL. c c Discussion: c c An R8COL is an M by N array of R8's, regarded as an array of N columns, c each of length M. c c Example: c c Input: c c M = 3, N = 4, J1 = 2, J2 = 4 c c A = ( c 1. 2. 3. 4. c 5. 6. 7. 8. c 9. 10. 11. 12. ) c c Output: c c A = ( c 1. 4. 3. 2. c 5. 8. 7. 6. c 9. 12. 11. 10. ) c c Licensing: c c This code is distributed under the GNU LGPL license. c c Modified: c c 05 March 2010 c c Author: c c John Burkardt c c Parameters: c c Input, integer M, N, the number of rows and columns. c c Input/output, double precision A(M,N), the M by N array. c c Input, integer J1, J2, the columns to be swapped. c implicit none integer m integer n double precision a(m,n) integer i integer j1 integer j2 double precision temp if ( j1 .lt. 1 .or. n .lt. j1 .or. j2 .lt. 1 .or. n .lt. j2 ) then write ( *, '(a)' ) ' ' write ( *, '(a)' ) 'R8COL_SWAP - Fatal error!' write ( *, '(a)' ) ' J1 or J2 is out of bounds.' write ( *, '(a,i8)' ) ' J1 = ', j1 write ( *, '(a,i8)' ) ' J2 = ', j2 write ( *, '(a,i8)' ) ' NCOL = ', n stop 1 end if if ( j1 .eq. j2 ) then return end if do i = 1, m temp = a(i,j1) a(i,j1) = a(i,j2) a(i,j2) = temp end do return end subroutine r8col_to_r8vec ( m, n, a, x ) c*********************************************************************72 c cc R8COL_TO_R8VEC converts an R8COL to an R8VEC. c c Discussion: c c An R8COL is an M by N array of R8's, regarded as an array of N columns, c each of length M. c c An R8VEC is a vector of R8's. c c Example: c c M = 3, N = 4 c c A = c 11 12 13 14 c 21 22 23 24 c 31 32 33 34 c c X = ( 11, 21, 31, 12, 22, 32, 13, 23, 33, 14, 24, 34 ) c c Licensing: c c This code is distributed under the GNU LGPL license. c c Modified: c c 08 May 2010 c c Author: c c John Burkardt c c Parameters: c c Input, integer M, N, the number of rows and columns. c c Input, double precision A(M,N), the array. c c Output, double precision X(M*N), a vector containing the N columns of A. c implicit none integer m integer n double precision a(m,n) integer i integer j integer k double precision x(m*n) k = 1 do j = 1, n do i = 1, m x(k) = a(i,j) k = k + 1 end do end do return end subroutine r8mat_cholesky_factor ( n, a, c ) c*********************************************************************72 c cc R8MAT_CHOLESKY_FACTOR computes the Cholesky factor of a symmetric matrix. c c Discussion: c c An R8MAT is an array of R8's. c c The matrix must be symmetric and positive semidefinite. c c For a positive semidefinite symmetric matrix A, the Cholesky factorization c is a lower triangular matrix L such that: c c A = L * L' c c Licensing: c c This code is distributed under the GNU LGPL license. c c Modified: c c 08 April 2009 c c Author: c c John Burkardt c c Parameters: c c Input, integer N, the number of rows and columns of c the matrix A. c c Input, double precision A(N,N), the N by N matrix. c c Output, double precision C(N,N), the N by N lower triangular c Cholesky factor. c implicit none integer n double precision a(n,n) double precision c(n,n) integer i integer j integer k double precision sum2 do j = 1, n do i = 1, n c(i,j) = a(i,j) end do end do do j = 1, n do i = 1, j - 1 c(i,j) = 0.0D+00 end do do i = j, n sum2 = 0.0D+00 do k = 1, j - 1 sum2 = sum2 + c(j,k) * c(i,k) end do sum2 = c(j,i) - sum2 if ( i .eq. j ) then if ( sum2 .le. 0.0D+00 ) then write ( *, '(a)' ) ' ' write ( *, '(a)' ) 'R8MAT_CHOLESKY_FACTOR - Fatal error!' write ( *, '(a)' ) ' Matrix is not positive definite.' stop 1 else c(i,j) = sqrt ( sum2 ) end if else if ( c(j,j) .ne. 0.0D+00 ) then c(i,j) = sum2 / c(j,j) else c(i,j) = 0.0D+00 end if end if end do end do return end subroutine r8mat_copy ( m, n, a, b ) c*********************************************************************72 c cc R8MAT_COPY copies an R8MAT. c c Discussion: c c An R8MAT is an array of R8 values. c c Licensing: c c This code is distributed under the GNU LGPL license. c c Modified: c c 26 July 2008 c c Author: c c John Burkardt c c Parameters: c c Input, integer M, N, the order of the matrix. c c Input, double precision A(M,N), the matrix to be copied. c c Output, double precision B(M,N), a copy of the matrix. c implicit none integer m integer n double precision a(m,n) double precision b(m,n) integer i integer j do j = 1, n do i = 1, m b(i,j) = a(i,j) end do end do return end subroutine r8mat_determinant ( n, a, determ ) c*********************************************************************72 c cc R8MAT_DETERMINANT computes the determinant of a square R8MAT. c c Discussion: c c An R8MAT is a matrix of R8 values. c c Licensing: c c This code is distributed under the GNU LGPL license. c c Modified: c c 21 May 2002 c c Author: c c John Burkardt c c Parameters: c c Input, integer N, the order of the matrix A. c c Input, double precision A(N,N), the matrix. c c Output, double precision DETERM, the determinant. c implicit none integer n integer n_max parameter ( n_max = 200 ) double precision a(n,n) double precision b(n_max,n_max) double precision determ integer info integer pivot(n_max) if ( n_max .lt. n ) then write ( *, '(a)' ) ' ' write ( *, '(a)' ) 'R8MAT_DETERMINANT - Fatal error!' write ( *, '(a)' ) ' Input N exceeds internal limit N_MAX.' stop 1 end if call r8mat_copy ( n, n, a, b ) call r8mat_gefa ( b, n, pivot, info ) call r8mat_gedet ( b, n, pivot, determ ) return end subroutine r8mat_diag_get_vector ( n, a, v ) c*********************************************************************72 c cc R8MAT_DIAG_GET_VECTOR gets the value of the diagonal of an R8MAT. c c Discussion: c c An R8MAT is an array of R8's. c c Licensing: c c This code is distributed under the GNU LGPL license. c c Modified: c c 02 July 2009 c c Author: c c John Burkardt c c Parameters: c c Input, integer N, the number of rows and columns of c the matrix. c c Input, double precision A(N,N), the N by N matrix. c c Output, double precision V(N), the diagonal entries c of the matrix. c implicit none integer n double precision a(n,n) integer i double precision v(n) do i = 1, n v(i) = a(i,i) end do return end subroutine r8mat_eigenvalues ( n, a, lambda ) c*********************************************************************72 c cc R8MAT_EIGENVALUES computes the eigenvalues of a square R8MAT. c c Discussion: c c An R8MAT is a matrix of double precision values. c c This subroutine calls the recommended sequence of EISPACK routines. c c Licensing: c c This code is distributed under the GNU LGPL license. c c Modified: c c 19 June 2011 c c Author: c c John Burkardt c c Parameters: c c Input, integer N, the order of the matrix. c c Input, double precision A(N,N), the matrix. c c Output, double complex LAMBDA(N), the eigenvalues. c implicit none integer n double precision a(n,n) double precision a_copy(n,n) double precision fv1(n) integer i integer ierr integer is1 integer is2 integer iv1(n) integer j double complex lambda(n) double precision wi(n) double precision wr(n) do j = 1, n do i = 1, n a_copy(i,j) = a(i,j) end do end do call balanc ( n, n, a_copy, is1, is2, fv1 ) call elmhes ( n, n, is1, is2, a_copy, iv1 ) call hqr ( n, n, is1, is2, a_copy, wr, wi, ierr ) do i = 1, n lambda(i) = dcmplx ( wr(i), wi(i) ) end do return end subroutine r8mat_gedet ( a, n, pivot, determ ) c*********************************************************************72 c cc R8MAT_GEDET computes the determinant of an R8MAT factored by R8MAT_GEFA. c c Discussion: c c An R8MAT is a matrix of R8 values. c c This is a modified version of the LINPACK routine DGEDI. c c Licensing: c c This code is distributed under the GNU LGPL license. c c Modified: c c 26 July 2008 c c Author: c c John Burkardt c c Reference: c c Jack Dongarra, Cleve Moler, Jim Bunch, Pete Stewart, c LINPACK User's Guide, c SIAM, (Society for Industrial and Applied Mathematics), c 3600 University City Science Center, c Philadelphia, PA, 19104-2688. c ISBN 0-89871-172-X c c Parameters: c c Input, double precision A(N,N), the LU factors computed by R8MAT_GEFA. c c Input, integer N, the order of the matrix. c N must be positive. c c Input, integer PIVOT(N), as computed by R8MAT_GEFA. c c Output, double precision DETERM, the determinant of the matrix. c implicit none integer n double precision a(n,n) double precision determ integer i integer pivot(n) determ = 1.0D+00 do i = 1, n determ = determ * a(i,i) if ( pivot(i) .ne. i ) then determ = - determ end if end do return end subroutine r8mat_gefa ( a, n, pivot, info ) c*********************************************************************72 c cc R8MAT_GEFA factors an R8MAT. c c Discussion: c c An R8MAT is a matrix of R8 values. c c This is a simplified version of the LINPACK routine DGEFA. c c Licensing: c c This code is distributed under the GNU LGPL license. c c Modified: c c 26 July 2008 c c Author: c c John Burkardt c c Reference: c c Jack Dongarra, Cleve Moler, Jim Bunch, Pete Stewart, c LINPACK User's Guide, c SIAM, (Society for Industrial and Applied Mathematics), c 3600 University City Science Center, c Philadelphia, PA, 19104-2688. c ISBN 0-89871-172-X c c Parameters: c c Input/output, double precision A(N,N), the matrix to be factored. c On output, A contains an upper triangular matrix and the multipliers c which were used to obtain it. The factorization can be written c A = L * U, where L is a product of permutation and unit lower c triangular matrices and U is upper triangular. c c Input, integer N, the order of the matrix. c N must be positive. c c Output, integer PIVOT(N), a vector of pivot indices. c c Output, integer INFO, singularity flag. c 0, no singularity detected. c nonzero, the factorization failed on the INFO-th step. c implicit none integer n double precision a(n,n) logical debug parameter ( debug = .false. ) integer i integer info integer pivot(n) integer j integer k integer l info = 0 do k = 1, n - 1 c c Find L, the index of the pivot row. c l = k do i = k + 1, n if ( abs ( a(l,k) ) .lt. abs ( a(i,k) ) ) then l = i end if end do pivot(k) = l c c If the pivot index is zero, the algorithm has failed. c if ( a(l,k) .eq. 0.0D+00 ) then info = k if ( debug ) then write ( *, '(a)' ) ' ' write ( *, '(a)' ) 'R8MAT_GEFA - Warning!' write ( *, '(a,i8)' ) ' Zero pivot on step ', info end if return end if c c Interchange rows L and K if necessary. c if ( l .ne. k ) then call r8_swap ( a(l,k), a(k,k) ) end if c c Normalize the values that lie below the pivot entry A(K,K). c do i = k + 1, n a(i,k) = - a(i,k) / a(k,k) end do c c Row elimination with column indexing. c do j = k + 1, n if ( l .ne. k ) then call r8_swap ( a(l,j), a(k,j) ) end if do i = k + 1, n a(i,j) = a(i,j) + a(i,k) * a(k,j) end do end do end do pivot(n) = n if ( a(n,n) .eq. 0.0D+00 ) then info = n if ( debug ) then write ( *, '(a)' ) ' ' write ( *, '(a)' ) 'R8MAT_GEFA - Warning!' write ( *, '(a,i8)' ) ' Zero pivot on step ', info end if end if return end subroutine r8mat_geinverse ( a, n, pivot ) c*********************************************************************72 c cc R8MAT_GEINVERSE computes the inverse of an R8MAT factored by R8MAT_GEFA. c c Discussion: c c An R8MAT is a matrix of double precision values. c c R8MAT_GEINVERSE is a modified version of the LINPACK routine DGEDI. c c Licensing: c c This code is distributed under the GNU LGPL license. c c Modified: c c 09 June 2011 c c Author: c c John Burkardt c c Reference: c c Jack Dongarra, Cleve Moler, Jim Bunch, Pete Stewart, c LINPACK User's Guide, c SIAM, (Society for Industrial and Applied Mathematics), c 3600 University City Science Center, c Philadelphia, PA, 19104-2688. c ISBN 0-89871-172-X c c Parameters: c c Input/output, double precision A(N,N). c On input, the factor information computed by R8MAT_GEFA. c On output, the inverse matrix. c c Input, integer N, the order of the matrix A. c c Input, integer PIVOT(N), the pivot vector from R8MAT_GEFA. c implicit none integer n double precision a(n,n) integer i integer pivot(n) integer j integer k double precision temp double precision work(n) c c Compute Inverse(U). c do k = 1, n a(k,k) = 1.0D+00 / a(k,k) do i = 1, k - 1 a(i,k) = - a(i,k) * a(k,k) end do do j = k + 1, n temp = a(k,j) a(k,j) = 0.0D+00 do i = 1, k a(i,j) = a(i,j) + temp * a(i,k) end do end do end do c c Form Inverse(U) * Inverse(L). c do k = n - 1, 1, -1 do i = k + 1, n work(i) = a(i,k) a(i,k) = 0.0D+00 end do do j = k + 1, n do i = 1, n a(i,k) = a(i,k) + work(j) * a(i,j) end do end do if ( pivot(k) .ne. k ) then do i = 1, n call r8_swap ( a(i,k), a(i,pivot(k)) ) end do end if end do return end subroutine r8mat_geplu ( m, n, a, p, l, u ) c*********************************************************************72 c cc R8MAT_GEPLU produces the PLU factors of an R8MAT. c c Discussion: c c An R8MAT is a matrix of double precision values. c c The PLU factors of the M by N matrix A are: c c P, an M by M permutation matrix P, c L, an M by M unit lower triangular matrix, c U, an M by N upper triangular matrix. c c Licensing: c c This code is distributed under the GNU LGPL license. c c Modified: c c 13 June 2011 c c Author: c c John Burkardt c c Parameters: c c Input, integer M, N, the order of the matrix. c c Input, double precision A(M,N), the matrix to be factored. c c Output, double precision P(M,M), the permutation factor. c c Output, double precision L(M,M), the unit lower triangular factor. c c Output, double precision U(M,N), the upper triangular factor. c implicit none integer m integer n double precision a(m,n) integer i integer j integer k double precision l(m,m) double precision p(m,m) integer pivot_row double precision pivot_value double precision u(m,n) c c Initialize: c c P:=Identity c L:=Identity c U:=A c call identity ( m, m, p ) call identity ( m, m, l ) do j = 1, n do i = 1, m u(i,j) = a(i,j) end do end do c c On step J, find the pivot row and the pivot value. c do j = 1, min ( m - 1, n ) pivot_value = 0.0D+00 pivot_row = 0 do i = j, m if ( pivot_value .lt. abs ( u(i,j) ) ) then pivot_value = abs ( u(i,j) ) pivot_row = i end if end do c c If the pivot row is nonzero, swap rows J and PIVOT_ROW. c if ( pivot_row .ne. 0 ) then call r8row_swap ( m, n, u, j, pivot_row ) call r8row_swap ( m, m, l, j, pivot_row ) call r8col_swap ( m, m, l, j, pivot_row ) call r8col_swap ( m, m, p, j, pivot_row ) c c Zero out the entries in column J, from row J+1 to M. c do i = j + 1, m if ( u(i,j) .ne. 0.0D+00 ) then l(i,j) = u(i,j) / u(j,j) u(i,j) = 0.0D+00 do k = j + 1, n u(i,k) = u(i,k) - l(i,j) * u(j,k) end do end if end do end if end do return end subroutine r8mat_gesl ( a, n, pivot, b, job ) c*********************************************************************72 c cc R8MAT_GESL solves a system factored by R8MAT_GEFA. c c Discussion: c c An R8MAT is a matrix of double precision values. c c This is a simplified version of the LINPACK routine DGESL. c c Licensing: c c This code is distributed under the GNU LGPL license. c c Modified: c c 21 June 2011 c c Author: c c John Burkardt c c Reference: c c Jack Dongarra, Cleve Moler, Jim Bunch, Pete Stewart, c LINPACK User's Guide, c SIAM, (Society for Industrial and Applied Mathematics), c 3600 University City Science Center, c Philadelphia, PA, 19104-2688. c ISBN 0-89871-172-X c c Parameters: c c Input, double precision A(N,N), the LU factors from R8MAT_GEFA. c c Input, integer N, the order of the matrix. c N must be positive. c c Input, integer PIVOT(N), the pivot vector from R8MAT_GEFA. c c Input/output, double precision B(N). c On input, the right hand side vector. c On output, the solution vector. c c Input, integer JOB, specifies the operation. c 0, solve A * x = b. c nonzero, solve A' * x = b. c implicit none integer n double precision a(n,n) double precision b(n) integer i integer job integer k integer l integer pivot(n) double precision r8vec_dot_product double precision t c c Solve A * x = b. c if ( job .eq. 0 ) then c c Solve PL * Y = B. c do k = 1, n - 1 l = pivot(k) if ( l .ne. k ) then t = b(l) b(l) = b(k) b(k) = t end if do i = k + 1, n b(i) = b(i) + a(i,k) * b(k) end do end do c c Solve U * X = Y. c do k = n, 1, -1 b(k) = b(k) / a(k,k) do i = 1, k - 1 b(i) = b(i) - a(i,k) * b(k) end do end do c c Solve A' * X = B. c else c c Solve U' * Y = B. c do k = 1, n b(k) = ( b(k) - r8vec_dot_product ( k - 1, b, a(1,k) ) ) & / a(k,k) end do c c Solve ( PL )' * X = Y. c do k = n - 1, 1, -1 b(k) = b(k) + r8vec_dot_product ( n - k, b(k+1), a(k+1,1) ) l = pivot(k) if ( l .ne. k ) then t = b(l) b(l) = b(k) b(k) = t end if end do end if return end subroutine r8mat_house_axh ( n, a, v, ah ) c*********************************************************************72 c cc R8MAT_HOUSE_AXH computes A*H where H is a compact Householder matrix. c c Discussion: c c The Householder matrix H(V) is defined by c c H(V) = I - 2 * v * v' / ( v' * v ) c c This routine is not particularly efficient. c c Licensing: c c This code is distributed under the GNU LGPL license. c c Modified: c c 05 February 2008 c c Author: c c John Burkardt c c Parameters: c c Input, integer N, the order of A. c c Input, double precision A(N,N), the matrix. c c Input, double precision V(N), a vector defining a Householder matrix. c c Output, double precision AH(N,N), the product A*H. c implicit none integer n double precision a(n,n) double precision ah(n,n) double precision av(n) integer i integer j double precision v(n) double precision v_normsq v_normsq = 0.0D+00 do i = 1, n v_normsq = v_normsq + v(i) ** 2 end do do i = 1, n av(i) = 0.0D+00 do j = 1, n av(i) = av(i) + a(i,j) * v(j) end do end do do i = 1, n do j = 1, n ah(i,j) = a(i,j) end do end do do i = 1, n do j = 1, n ah(i,j) = ah(i,j) - 2.0D+00 * av(i) * v(j) end do end do do i = 1, n do j = 1, n ah(i,j) = ah(i,j) / v_normsq end do end do return end subroutine r8mat_house_form ( n, v, h ) c*********************************************************************72 c cc R8MAT_HOUSE_FORM constructs a Householder matrix from its compact form. c c Discussion: c c An R8MAT is an array of R8 values. c c H(v) = I - 2 * v * v' / ( v' * v ) c c Licensing: c c This code is distributed under the GNU LGPL license. c c Modified: c c 09 May 2010 c c Author: c c John Burkardt c c Parameters: c c Input, integer N, the order of the matrix. c c Input, double precision V(N), the vector defining the Householder matrix. c c Output, double precision H(N,N), the Householder matrix. c implicit none integer n double precision beta double precision h(n,n) integer i integer j double precision v(n) c c Compute the L2 norm of V. c beta = 0.0D+00 do i = 1, n beta = beta + v(i) ** 2 end do c c Form the matrix H. c call r8mat_identity ( n, h ) do i = 1, n do j = 1, n h(i,j) = h(i,j) - 2.0D+00 * v(i) * v(j) / beta end do end do return end subroutine r8mat_identity ( n, a ) c*********************************************************************72 c cc R8MAT_IDENTITY stores the identity matrix in an R8MAT. c c Discussion: c c An R8MAT is an array of R8's. c c Licensing: c c This code is distributed under the GNU LGPL license. c c Modified: c c 24 March 2000 c c Author: c c John Burkardt c c Parameters: c c Input, integer N, the order of A. c c Output, double precision A(N,N), the N by N identity matrix. c implicit none integer n double precision a(n,n) integer i integer j do j = 1, n do i = 1, n a(i,j) = 0.0D+00 end do end do do i = 1, n a(i,i) = 1.0D+00 end do return end subroutine r8mat_inverse ( n, a, b ) c*********************************************************************72 c cc R8MAT_INVERSE computes the inverse of an R8MAT. c c Discussion: c c An R8MAT is a matrix of double precision values. c c Licensing: c c This code is distributed under the GNU LGPL license. c c Modified: c c 08 June 2011 c c Author: c c John Burkardt c c Parameters: c c Input, integer N, the orderof the matrix A. c c Input, double precision A(N,N), the matrix. c c Output, double precision B(N,N), the inverse matrix. c implicit none integer n double precision a(n,n) double precision b(n,n) integer i integer info integer j integer pivot(n) do j = 1, n do i = 1, n b(i,j) = a(i,j) end do end do call r8mat_gefa ( b, n, pivot, info ) call r8mat_geinverse ( b, n, pivot ) return end subroutine r8mat_is_adjacency ( m, n, a, ival ) c*********************************************************************72 c cc R8MAT_IS_ADJACENCY checks whether an R8MAT is an adjacency matrix. c c Discussion: c c An R8MAT is a matrix of double precision values. c c Licensing: c c This code is distributed under the GNU LGPL license. c c Modified: c c 19 June 2011 c c Author: c c John Burkardt c c Parameters: c c Input, integer M, N, the row and column dimensions of c the matrix. M and N must be positive. c c Input, double precision A(M,N), the matrix. c c Output, integer IVAL: c -1, the matrix is not an adjacency matrix. c 1, the matrix is an adjacency matrix. c implicit none integer m integer n double precision a(m,n) double precision error_frobenius integer ival integer jval double precision tol parameter ( tol = 0.00001D+00 ) if ( m .ne. n ) then ival = - 1 return end if call r8mat_is_symmetric ( m, n, a, error_frobenius ) if ( tol .lt. error_frobenius ) then ival = -1 return end if call r8mat_is_zero_one ( m, n, a, jval ) if ( jval .ne. 1 ) then ival = -1 return end if return end subroutine r8mat_is_anticirculant ( m, n, a, ival ) c*********************************************************************72 c cc R8MAT_IS_ANTICIRCULANT checks whether an R8MAT is an anticirculant matrix. c c Discussion: c c An R8MAT is a matrix of double precision values. c c Licensing: c c This code is distributed under the GNU LGPL license. c c Modified: c c 19 June 2011 c c Author: c c John Burkardt c c Parameters: c c Input, integer M, N, the row and column dimensions of c the matrix. M and N must be positive. c c Input, double precision A(M,N), the matrix. c c Output, integer IVAL: c -1, the matrix is not anticirculant. c 1, the matrix is anticirculant. c implicit none integer m integer n double precision a(m,n) integer i integer ival integer j integer k ival = 1 do i = 2, m do j = 1, n k = 1 + mod ( j + i - 2, n ) if ( a(i,j) .ne. a(1,k) ) then ival = -1 return end if end do end do return end subroutine r8mat_is_antipersymm ( m, n, a, ival ) c*********************************************************************72 c cc R8MAT_IS_ANTIPERSYMM checks an R8MAT for antipersymmetry. c c Discussion: c c An R8MAT is a matrix of double precision values. c c A is antipersymmetric if A(I,J) = -A(N+1-J,N+1-I). c c Licensing: c c This code is distributed under the GNU LGPL license. c c Modified: c c 20 June 2011 c c Author: c c John Burkardt c c Parameters: c c Input, integer M, N, the row and column dimensions of c the matrix. M and N must be positive. c c Input, double precision A(M,N), the matrix. c c Output, integer IVAL: c -1, the matrix is not antipersymmetric. c 1, the matrix is antipersymmetric. c implicit none integer m integer n double precision a(m,n) integer i integer ival integer j ival = 1 do i = 1, min ( m, n ) do j = n, max ( 1, n - m + 1 ), -1 if ( a(i,j) /= -a(n+1-j,n+1-i) ) then ival = -1 return end if end do end do return end subroutine r8mat_is_antisymm ( m, n, a, error_frobenius ) c*********************************************************************72 c cc R8MAT_IS_ANTISYMM checks an R8MAT for antisymmetry. c c Discussion: c c An R8MAT is a matrix of double precision values. c c Licensing: c c This code is distributed under the GNU LGPL license. c c Modified: c c 20 June 2011 c c Author: c c John Burkardt c c Parameters: c c Input, integer M, N, the row and column dimensions of c the matrix. M and N must be positive. c c Input, double precision A(M,N), the matrix. c c Output, double precision ERROR_FROBENIUS, the Frobenius error in c antisymmetry, which would be 0 if the matrix is exactly antisymmetric. c implicit none integer m integer n double precision a(m,n) double precision error_frobenius integer i integer j double precision r8_huge error_frobenius = 0.0D+00 if ( m .ne. n ) then error_frobenius = r8_huge ( ) return end if do i = 1, n do j = 1, i - 1 error_frobenius = error_frobenius & + ( a(i,j) + a(j,i) ) ** 2 end do error_frobenius = error_frobenius + a(i,i) ** 2 end do error_frobenius = sqrt ( error_frobenius ) return end subroutine r8mat_is_band ( m, n, a, ival, jval ) c*********************************************************************72 c cc R8MAT_IS_BAND determines whether an R8MAT is banded. c c Discussion: c c An R8MAT is a matrix of double precision values. c c Licensing: c c This code is distributed under the GNU LGPL license. c c Modified: c c 20 June 2011 c c Author: c c John Burkardt c c Parameters: c c Input, integer M, N, the row and column dimensions of c the matrix. M and N must be positive. c c Input, double precision A(M,N), the matrix. c c Output, integer IVAL, the lower bandwidth, measured as the c number of nonzero diagonals, starting with the main diagonal c and proceeding down, with values between 0 and M. c c Output, integer JVAL, the upper bandwidth, measured as the c number of nonzero diagonals, starting with the main diagonal c and proceeding right, with values between 0 and N. c implicit none integer m integer n double precision a(m,n) integer i integer ival integer j integer jval ival = 0 jval = 0 do i = 1, m do j = 1, n if ( a(i,j) .ne. 0.0D+00 ) then if ( i .le. j ) then jval = max ( jval, j + 1 - i ) end if if ( j .le. i ) then ival = max ( ival, i + 1 - j ) end if end if end do end do return end subroutine r8mat_is_centrosymm ( m, n, a, ival ) c*********************************************************************72 c cc R8MAT_IS_CENTROSYMM checks an R8MAT for centrosymmetry. c c Discussion: c c An R8MAT is a matrix of double precision values. c c A is centrosymmetric: A(I,J) = A(N+1-I,N+1-J). c c Licensing: c c This code is distributed under the GNU LGPL license. c c Modified: c c 21 June 2011 c c Author: c c John Burkardt c c Parameters: c c Input, integer M, N, the row and column dimensions of c the matrix. M and N must be positive. c c Input, double precision A(M,N), the matrix. c c Output, integer IVAL: c -1, the matrix is not centrosymmetric. c 1, the matrix is centrosymmetric. c implicit none integer m integer n double precision a(m,n) integer i integer ival integer j ival = 1 do i = 1, min ( m, n ) do j = n, max ( 1, n - m + 1 ), -1 if ( a(i,j) .ne. a(n+1-i,n+1-j) ) then ival = -1 return end if end do end do return end subroutine r8mat_is_circulant ( m, n, a, ival ) c*********************************************************************72 c cc R8MAT_IS_CIRCULANT checks whether an R8MAT is a circulant matrix. c c Discussion: c c An R8MAT is a matrix of double precision values. c c Licensing: c c This code is distributed under the GNU LGPL license. c c Modified: c c 21 June 2011 c c Author: c c John Burkardt c c Parameters: c c Input, integer M, N, the row and column dimensions of c the matrix. M and N must be positive. c c Input, double precision A(M,N), the matrix. c c Output, integer IVAL: c -1, the matrix is not circulant. c 1, the matrix is circulant. c implicit none integer m integer n double precision a(m,n) integer i integer i4_modp integer ival integer j integer k ival = 1 do i = 2, m do j = 1, n k = 1 + i4_modp ( j - i, n ) if ( a(i,j) .ne. a(1,k) ) then ival = -1 return end if end do end do return end subroutine r8mat_is_column_orthogonal ( m, n, a, error_sum ) c*********************************************************************72 c cc R8MAT_IS_COLUMN_ORTHOGONAL checks whether an R8MAT is column orthogonal. c c Discussion: c c An R8MAT is a matrix of double precision values. c c Licensing: c c This code is distributed under the GNU LGPL license. c c Modified: c c 22 June 2011 c c Author: c c John Burkardt c c Parameters: c c Input, integer M, N, the order of the matrix. c M and N must be positive. c c Input, double precision A(M,N), the matrix. c c Output, double precision ERROR_SUM, the sum of the errors. c implicit none integer m integer n double precision a(m,n) double precision error_sum integer j integer j2 double precision r8vec_dot_product error_sum = 0.0D+00 do j = 1, n do j2 = j + 1, n error_sum = error_sum & + ( r8vec_dot_product ( m, a(1,j), a(1,j2) ) ) ** 2 end do end do error_sum = sqrt ( error_sum ) return end subroutine r8mat_is_cyclic_tridiagonal ( m, n, a, ival ) c*********************************************************************72 c cc R8MAT_IS_CYCLIC_TRIDIAGONAL determines if an R8MAT is cyclic tridiagonal. c c Discussion: c c An R8MAT is a matrix of double precision values. c c Licensing: c c This code is distributed under the GNU LGPL license. c c Modified: c c 22 June 2011 c c Author: c c John Burkardt c c Parameters: c c Input, integer M, N, the order of the matrix. c M and N must be positive. c c Input, double precision A(M,N), the matrix. c c Output, integer IVAL, the report: c -1, the matrix is not square. c -2, the matrix has illegal nonzero values. c 1, the matrix is cyclic tridiagonal. c implicit none integer m integer n double precision a(m,n) integer i integer ival integer j integer k if ( m .ne. n ) then ival = -1 return end if do i = 1, n j = i + 1 do k = 1, n - 3 j = j + 1 if ( n .lt. j ) then j = j - n end if if ( a(i,j) .ne. 0.0D+00 ) then ival = -2 return end if end do end do ival = 1 return end subroutine r8mat_is_diag2 ( m, n, a, ival ) c*********************************************************************72 c cc R8MAT_IS_DIAG2 counts the number of nonzero diagonals in an R8MAT. c c Discussion: c c An R8MAT is a matrix of double precision values. c c Licensing: c c This code is distributed under the GNU LGPL license. c c Modified: c c 22 June 2011 c c Author: c c John Burkardt c c Parameters: c c Input, integer M, N, the row and column dimensions of c the matrix. M and N must be positive. c c Input, double precision A(M,N), the matrix. c c Output, integer IVAL, the number of nonzero diagonals. c implicit none integer m integer n double precision a(m,n) integer i integer ihi integer ilo integer ival integer jmi integer nonzero ival = 0 do jmi = 1 - m, n - 1 nonzero = 0 ilo = max ( 1, 1 - jmi ) ihi = min ( m, n - jmi ) do i = ilo, ihi if ( a(i,i+jmi) .ne. 0 ) then nonzero = 1 end if end do ival = ival + nonzero end do return end subroutine r8mat_is_diagdom ( m, n, a, ival, jval ) c*********************************************************************72 c cc R8MAT_IS_DIAGDOM checks whether an R8MAT is diagonally dominant. c c Discussion: c c An R8MAT is a matrix of double precision values. c c Licensing: c c This code is distributed under the GNU LGPL license. c c Modified: c c 19 June 2011 c c Author: c c John Burkardt c c Parameters: c c Input, integer M, N, the row and column dimensions of c the matrix. M and N must be positive. c c Input, double precision A(M,N), the matrix. c c Output, integer IVAL: c -1, the matrix is not row diagonally dominant. c 1, the matrix is row diagonally dominant. c 2, the matrix is strictly row diagonally dominant. c c Output, integer JVAL: c -1, the matrix is not column diagonally dominant. c 1, the matrix is column diagonally dominant. c 2, the matrix is strictly column diagonally dominant. c implicit none integer m integer n double precision a(m,n) integer i integer ival integer j integer jval double precision s double precision sum2 ival = 2 do i = 1, min ( m, n ) s = abs ( a(i,i) ) sum2 = 0.0D+00 do j = 1, n if ( j .ne. i ) then sum2 = sum2 + abs ( a(i,j) ) end if end do if ( s .eq. sum2 ) then if ( ival .eq. 2 ) then ival = 1 end if else if ( s .lt. sum2 ) then ival = -1 end if end do jval = 2 do j = 1, min ( m, n ) s = abs ( a(j,j) ) sum2 = 0.0D+00 do i = 1, m if ( j .ne. i ) then sum2 = sum2 + abs ( a(i,j) ) end if end do if ( s .eq. sum2 ) then if ( jval .eq. 2 ) then jval = 1 end if else if ( s .lt. sum2 ) then jval = -1 end if end do return end subroutine r8mat_is_eigen_left ( n, k, a, x, lambda, & error_frobenius ) c*********************************************************************72 c cc R8MAT_IS_EIGEN_LEFT determines the error in a left eigensystem. c c Discussion: c c An R8MAT is a matrix of double precision values. c c This routine computes the Frobenius norm of c c X * A - LAMBDA * X c c where c c A is an N by N matrix, c X is an K by N matrix (each of K rows is an eigenvector) c LAMBDA is a K by K diagonal matrix of eigenvalues. c c Licensing: c c This code is distributed under the GNU LGPL license. c c Modified: c c 14 March 2015 c c Author: c c John Burkardt c c Parameters: c c Input, integer N, the order of the matrix. c c Input, integer K, the number of eigenvectors. c K is usually 1 or N. c c Input, double precision A(N,N), the matrix. c c Input, double precision X(K,N), the K eigenvectors. c c Input, double precision LAMBDA(K), the K eigenvalues. c c Output, double precision ERROR_FROBENIUS, the Frobenius norm c of X * A - LAMBDA * X. c implicit none integer k integer n double precision a(n,n) double precision c(k,n) double precision error_frobenius integer i integer j double precision lambda(k) double precision r8mat_norm_fro double precision x(k,n) call r8mat_mm ( k, n, n, x, a, c ) do j = 1, k do i = 1, n c(i,j) = c(i,j) - lambda(i) * x(i,j) end do end do error_frobenius = r8mat_norm_fro ( k, n, c ) return end subroutine r8mat_is_eigen_right ( n, k, a, x, lambda, & error_frobenius ) c*********************************************************************72 c cc R8MAT_IS_EIGEN_RIGHT determines the error in a right eigensystem. c c Discussion: c c An R8MAT is a matrix of double precision values. c c This routine computes the Frobenius norm of c c A * X - X * LAMBDA c c where c c A is an N by N matrix, c X is an N by K matrix (each of K columns is an eigenvector) c LAMBDA is a K by K diagonal matrix of eigenvalues. c c This routine assumes that A, X and LAMBDA are all real! c c Licensing: c c This code is distributed under the GNU LGPL license. c c Modified: c c 09 June 2011 c c Author: c c John Burkardt c c Parameters: c c Input, integer N, the order of the matrix. c c Input, integer K, the number of eigenvectors. c K is usually 1 or N. c c Input, double precision A(N,N), the matrix. c c Input, double precision X(N,K), the K eigenvectors. c c Input, double precision LAMBDA(K), the K eigenvalues. c c Output, double precision ERROR_FROBENIUS, the Frobenius norm c of the difference matrix A * X - X * LAMBDA, which would be exactly zero c if X and LAMBDA were exact eigenvectors and eigenvalues of A. c implicit none integer k integer n double precision a(n,n) double precision c(n,k) double precision error_frobenius integer i integer j double precision lambda(k) double precision r8mat_norm_fro double precision x(n,k) call r8mat_mm ( n, n, k, a, x, c ) do j = 1, k do i = 1, n c(i,j) = c(i,j) - lambda(j) * x(i,j) end do end do error_frobenius = r8mat_norm_fro ( n, k, c ) return end subroutine r8mat_is_hankel ( m, n, a, ival ) c*********************************************************************72 c cc R8MAT_IS_HANKEL checks whether an R8MAT is Hankel. c c Discussion: c c An R8MAT is a matrix of double precision values. c c A Hankel matrix is one which is constant along each anti-diagonal. c c Licensing: c c This code is distributed under the GNU LGPL license. c c Modified: c c 03 April 2014 c c Author: c c John Burkardt c c Parameters: c c Input, integer M, N, the row and column dimensions of c the matrix. M and N must be positive. c c Input, double precision A(M,N), the matrix. c c Output, integer IVAL: c -1, the matrix is not Hankel. c 1, the matrix is Hankel. c implicit none integer m integer n double precision a(m,n) integer i integer ihi integer ilo integer ipj integer ival double precision s ival = 1 do ipj = 2, n + m ilo = max ( 1, ipj - n ) ihi = min ( m, ipj - 1 ) s = a(ilo,ipj-ilo) do i = ilo + 1, ihi if ( a(i,ipj-i) .ne. s ) then ival = -1 return end if end do end do return end subroutine r8mat_is_identity ( n, a, error_frobenius ) c*********************************************************************72 c cc R8MAT_IS_IDENTITY determines if an R8MAT is the identity. c c Discussion: c c An R8MAT is a matrix of double precision values. c c The routine returns the Frobenius norm of A - I. c c Licensing: c c This code is distributed under the GNU LGPL license. c c Modified: c c 28 September 2013 c c Author: c c John Burkardt c c Parameters: c c Input, integer N, the order of the matrix. c c Input, double precision A(N,N), the matrix. c c Output, rdouble precision ERROR_FROBENIUS, the Frobenius norm c of the difference matrix A - I, which would be exactly zero c if A were the identity matrix. c implicit none integer n double precision a(n,n) double precision error_frobenius integer i integer j double precision value error_frobenius = 0.0D+00 do i = 1, n do j = 1, n if ( i .eq. j ) then error_frobenius = error_frobenius + ( a(i,j) - 1.0D+00 )**2 else error_frobenius = error_frobenius + a(i,j) ** 2 end if end do end do error_frobenius = sqrt ( error_frobenius ) return end subroutine r8mat_is_inverse ( n, a, b, error_frobenius ) c*********************************************************************72 c cc R8MAT_IS_INVERSE determines if one R8MAT is the inverse of another. c c Discussion: c c An R8MAT is a matrix of R8 values. c c This routine returns the sum of the Frobenius norms of c A * B - I and B * A - I. c c Licensing: c c This code is distributed under the GNU LGPL license. c c Modified: c c 30 August 2008 c c Author: c c John Burkardt c c Parameters: c c Input, integer N, the order of the matrix. c c Input, double precision A(N,N), B(N,N), the matrices. c c Output, double precision ERROR_FROBENIUS, the sum of the Frobenius norms c of the difference matrices A * B - I and B * A - I which would both c be exactly zero if B was the exact inverse of A and computer arithmetic c were exact. c implicit none integer n double precision a(n,n) double precision b(n,n) double precision error_frobenius double precision error_left double precision error_right call r8mat_is_inverse_left ( n, n, a, b, error_left ) call r8mat_is_inverse_right ( n, n, a, b, error_right ) error_frobenius = error_left + error_right return end subroutine r8mat_is_inverse_left ( m, n, a, b, error_frobenius ) c*********************************************************************72 c c! R8MAT_IS_INVERSE_LEFT determines if one R8MAT is the left inverse of another. c c Discussion: c c An R8MAT is a matrix of R8 values. c c This routine returns the Frobenius norm of the NxN matrix: c c B * A - I. c c Licensing: c c This code is distributed under the GNU LGPL license. c c Modified: c c 30 August 2008 c c Author: c c John Burkardt c c Parameters: c c Input, integer M, N, the order of the matrix A. c c Input, double precision A(M,N), the matrix to be checked. c c Input, double precision B(N,M), the matrix which is to be tested c as a left inverse of A. c c Output, double precision ERROR_FROBENIUS, the Frobenius norm c of the difference matrix B * A - I, which would be exactly zero c if B was the exact left inverse of A and computer arithmetic were exact. c implicit none integer m integer n double precision a(m,n) double precision b(n,m) double precision baij double precision error_frobenius integer i integer j integer k error_frobenius = 0.0D+00 do j = 1, n do i = 1, n baij = 0.0D+00 do k = 1, m baij = baij + b(i,k) * a(k,j) end do if ( i .eq. j ) then error_frobenius = error_frobenius + ( baij - 1.0D+00 )**2 else error_frobenius = error_frobenius + baij ** 2 end if end do end do error_frobenius = sqrt ( error_frobenius ) return end subroutine r8mat_is_inverse_right ( m, n, a, b, error_frobenius ) c*********************************************************************72 c c! R8MAT_IS_INVERSE_RIGHT determines if one R8MAT is the right inverse of another. c c Discussion: c c An R8MAT is a matrix of R8 values. c c This routine returns the Frobenius norm of the MxM matrix: c c A * B - I. c c Licensing: c c This code is distributed under the GNU LGPL license. c c Modified: c c 30 August 2008 c c Author: c c John Burkardt c c Parameters: c c Input, integer M, N, the order of the matrix A. c c Input, double precision A(M,N), the matrix to be checked. c c Input, double precision B(N,M), the matrix which is to be tested c as a left inverse of A. c c Output, double precision ERROR_FROBENIUS, the Frobenius norm c of the difference matrix A * B - I, which would be exactly zero c if B was the exact right inverse of A and computer arithmetic were exact. c implicit none integer m integer n double precision a(m,n) double precision abij double precision b(n,m) double precision error_frobenius integer i integer j integer k error_frobenius = 0.0D+00 do j = 1, m do i = 1, m abij = 0.0D+00 do k = 1, n abij = abij + a(i,k) * b(k,j) end do if ( i .eq. j ) then error_frobenius = error_frobenius & + ( abij - 1.0D+00 ) ** 2 else error_frobenius = error_frobenius + abij ** 2 end if end do end do error_frobenius = sqrt ( error_frobenius ) return end subroutine r8mat_is_llt ( m, n, a, l, error_frobenius ) c*********************************************************************72 c cc R8MAT_IS_LLT measures the error in a lower Cholesky factorization. c c Discussion: c c An R8MAT is a matrix of double precision values. c c This routine simply returns the Frobenius norm of the M x M matrix: c A - L * L'. c c Licensing: c c This code is distributed under the GNU LGPL license. c c Modified: c c 15 March 2015 c c Author: c c John Burkardt c c Parameters: c c Input, integer M, N, the order of the matrix. c c Input, double precision A(M,M), the matrix. c c Input, double precision L(M,N), the Cholesky factor. c c Output, double precision ERROR_FROBENIUS, the Frobenius norm c of A - L * L'. c implicit none integer m integer n double precision a(m,m) double precision dif(m,m) double precision error_frobenius integer i integer j double precision l(m,n) double precision r8mat_norm_fro call r8mat_mmt ( m, n, m, l, l, dif ) do j = 1, m do i = 1, m dif(i,j) = a(i,j) - dif(i,j) end do end do error_frobenius = r8mat_norm_fro ( m, m, dif ) return end subroutine r8mat_is_null_left ( m, n, a, x, error_l2 ) c*********************************************************************72 c cc R8MAT_IS_NULL_LEFT determines if x is a left null vector of an R8MAT. c c Discussion: c c An R8MAT is a matrix of double precision values. c c The nonzero M vector x is a left null vector of the MxN matrix A if c c x' * A = A' * x = 0 c c If A is a square matrix, then this implies that A is singular. c c If A is a square matrix, this implies that 0 is an eigenvalue of A, c and that x is an associated left eigenvector. c c This routine returns 0 if x is exactly a null vector of A. c c It returns a "huge" value if x is the zero vector. c c Otherwise, it returns the L2 norm of A' * x divided by the L2 norm of x: c c ERROR_L2 = NORM_L2 ( A' * x ) / NORM_L2 ( x ) c c Licensing: c c This code is distributed under the GNU LGPL license. c c Modified: c c 06 March 2015 c c Author: c c John Burkardt c c Parameters: c c Input, integer M, N, the row and column dimensions of c the matrix. M and N must be positive. c c Input, double precision A(M,N), the matrix. c c Input, double precision X(M), the vector. c c Output, double precision ERROR_L2, the result. c 0.0 indicates that X is exactly a null vector. c A "huge" value indicates that ||x|| = 0; c Otherwise, the value returned is a relative error ||A'*x||/||x||. c implicit none integer m integer n double precision a(m,n) double precision atx_norm double precision atx double precision error_l2 integer i integer j double precision r8_huge double precision x(m) double precision x_norm x_norm = 0.0D+00 do i = 1, m x_norm = x_norm + x(i) * x(i) end do x_norm = sqrt ( x_norm ) if ( x_norm .eq. 0.0D+00 ) then error_l2 = r8_huge ( ) return end if atx_norm = 0.0D+00 do j = 1, n atx = 0.0D+00 do i = 1, m atx = atx + x(i) * a(i,j) end do atx_norm = atx_norm + atx * atx end do atx_norm = sqrt ( atx_norm ) error_l2 = atx_norm / x_norm return end subroutine r8mat_is_null_right ( m, n, a, x, error_l2 ) c*********************************************************************72 c cc R8MAT_IS_NULL_RIGHT determines if x is a right null vector of an R8MAT. c c Discussion: c c An R8MAT is a matrix of double precision values. c c The nonzero N vector x is a null vector of the MxN matrix A if c c A * x = 0 c c If A is a square matrix, then this implies that A is singular. c c If A is a square matrix, this implies that 0 is an eigenvalue of A, c and that x is an associated eigenvector. c c This routine returns 0 if x is exactly a null vector of A. c c It returns a "huge" value if x is the zero vector. c c Otherwise, it returns the L2 norm of A * x divided by the L2 norm of x: c c ERROR_L2 = NORM_L2 ( A * x ) / NORM_L2 ( x ) c c Licensing: c c This code is distributed under the GNU LGPL license. c c Modified: c c 13 August 2008 c c Author: c c John Burkardt c c Parameters: c c Input, integer M, N, the row and column dimensions of c the matrix. M and N must be positive. c c Input, double precision A(M,N), the matrix. c c Input, double precision X(N), the vector. c c Output, double precision ERROR_L2, the result. c 0.0 indicates that X is exactly a null vector. c A "huge" value indicates that ||x|| = 0; c Otherwise, the value returned is a relative error ||A*x||/||x||. c implicit none integer m integer n double precision a(m,n) double precision ax_norm double precision ax double precision error_l2 integer i integer j double precision r8_huge double precision x(n) double precision x_norm x_norm = 0.0D+00 do i = 1, n x_norm = x_norm + x(i) * x(i) end do x_norm = sqrt ( x_norm ) if ( x_norm .eq. 0.0D+00 ) then error_l2 = r8_huge ( ) return end if ax_norm = 0.0D+00 do i = 1, m ax = 0.0D+00 do j = 1, n ax = ax + a(i,j) * x(j) end do ax_norm = ax_norm + ax * ax end do ax_norm = sqrt ( ax_norm ) error_l2 = ax_norm / x_norm return end subroutine r8mat_is_perm ( n, a, ival ) c*********************************************************************72 c cc R8MAT_IS_PERM checks whether an R8MAT is a permutation matrix. c c Discussion: c c An R8MAT is a matrix of double precision values. c c Licensing: c c This code is distributed under the GNU LGPL license. c c Modified: c c 26 June 2011 c c Author: c c John Burkardt c c Parameters: c c Input, integer N, the order of the matrix. c c Input, double precision A(N,N), the matrix. c c Output, integer IVAL: c -1, the matrix is not a zero-one matrix. c -2, there is a row that does not sum to 1. c -3, there is a column that does not sum to 1. c 1, the matrix is a permutation matrix, c implicit none integer n double precision a(n,n) integer i integer ival integer j integer jval double precision s call r8mat_is_zero_one ( n, n, a, jval ) if ( jval .ne. 1 ) then ival = -1 return end if do i = 1, n s = 0.0D+00 do j = 1, n s = s + a(i,j) end do if ( s .ne. 1.0D+00 ) then ival = -2 return end if end do do j = 1, n s = 0.0D+00 do i = 1, n s = s + a(i,j) end do if ( s .ne. 1.0D+00 ) then ival = -3 return end if end do ival = 1 return end subroutine r8mat_is_plu ( m, n, a, p, l, u, error_frobenius ) c*********************************************************************72 c cc R8MAT_IS_PLU measures the error in a PLU factorization. c c Discussion: c c An R8MAT is a matrix of double precision values. c c This routine simply returns the Frobenius norm of the M x N matrix: c A - P * L * U. c c Licensing: c c This code is distributed under the GNU LGPL license. c c Modified: c c 11 June 2011 c c Author: c c John Burkardt c c Parameters: c c Input, integer M, N, the order of the matrix. c c Input, double precision A(M,N), the matrix. c c Input, double precision P(M,M), L(M,M), U(M,N), the PLU factors. c c Output, double precision ERROR_FROBENIUS, the Frobenius norm c of the difference matrix A - P * L * U. c implicit none integer m integer n double precision a(m,n) double precision dif(m,n) double precision error_frobenius integer i integer j double precision l(m,m) double precision lu(m,n) double precision p(m,m) double precision plu(m,n) double precision r8mat_norm_fro double precision u(m,n) call r8mat_mm ( m, m, n, l, u, lu ) call r8mat_mm ( m, m, n, p, lu, plu ) do j = 1, n do i = 1, m dif(i,j) = a(i,j) - plu(i,j) end do end do error_frobenius = r8mat_norm_fro ( m, n, dif ) return end subroutine r8mat_is_solution ( m, n, k, a, x, b, & error_frobenius ) c*********************************************************************72 c cc R8MAT_IS_SOLUTION measures the error in a linear system solution. c c Discussion: c c An R8MAT is a matrix of double precision real values. c c The system matrix A is an M x N matrix. c It is not required that A be invertible. c c The solution vector X is actually allowed to be an N x K matrix. c c The right hand side "vector" B is actually allowed to be an M x K matrix. c c This routine simply returns the Frobenius norm of the M x K matrix: c A * X - B. c c Licensing: c c This code is distributed under the GNU LGPL license. c c Modified: c c 14 August 2008 c c Author: c c John Burkardt c c Parameters: c c Input, integer M, N, K, the order of the matrices. c c Input, double precision A(M,N), X(N,K), B(M,K), the matrices. c c Output, double precision ERROR_FROBENIUS, the Frobenius norm c of the difference matrix A * X - B, which would be exactly zero c if X was the "solution" of the linear system. c implicit none integer k integer m integer n double precision a(m,n) double precision b(m,k) double precision c(m,k) double precision error_frobenius integer i integer j integer l double precision r8mat_norm_fro double precision x(n,k) do i = 1, m do j = 1, k c(i,j) = - b(i,j) do l = 1, n c(i,j) = c(i,j) + a(i,l) * x(l,j) end do end do end do error_frobenius = r8mat_norm_fro ( m, k, c ) return end subroutine r8mat_is_symmetric ( m, n, a, error_frobenius ) c*********************************************************************72 c cc R8MAT_IS_SYMMETRIC checks an R8MAT for symmetry. c c Discussion: c c An R8MAT is a matrix of double precision values. c c Licensing: c c This code is distributed under the GNU LGPL license. c c Modified: c c 19 June 2011 c c Author: c c John Burkardt c c Parameters: c c Input, integer M, N, the order of the matrix. c c Input, double precision A(M,N), the matrix. c c Output, double precision ERROR_FROBENIUS, measures the c Frobenius norm of ( A - A' ), which would be zero if the matrix c were exactly symmetric. c implicit none integer m integer n double precision a(m,n) double precision error_frobenius integer i integer j double precision r8_huge if ( m .ne. n ) then error_frobenius = r8_huge ( ) return end if error_frobenius = 0.0D+00 do j = 1, n do i = 1, m error_frobenius = error_frobenius + ( a(i,j) - a(j,i) )**2 end do end do error_frobenius = sqrt ( error_frobenius ) return end subroutine r8mat_is_transition ( m, n, a, error_frobenius ) c*********************************************************************72 c cc R8MAT_IS_TRANSITION checks whether an R8MAT is a transition matrix. c c Discussion: c c A transition matrix: c * is a square matrix; c * with real, nonnegative entries; c * whose columns each sum to 1. c c An R8MAT is a matrix of double precision values. c c Licensing: c c This code is distributed under the GNU LGPL license. c c Modified: c c 14 July 2013 c c Author: c c John Burkardt c c Parameters: c c Input, integer M, N, the order of A. c c Input, double precision A(M,N), the matrix. c c Output, double precision ERROR_FROBENIUS. c This value is R8_HUGE(), if M /= N. c This value is R8_HUGE(), if any entry is negative. c Otherwise, it is the square root of the sum of the squares of the c deviations of the column sums from 1. c implicit none integer m integer n double precision a(m,n) double precision error_frobenius integer i integer j double precision r8_huge double precision t if ( m .ne. n ) then error_frobenius = r8_huge ( ) return end if do j = 1, n do i = 1, m if ( a(i,j) .lt. 0.0D+00 ) then error_frobenius = r8_huge ( ) return end if end do end do ! ! Take column sums. ! error_frobenius = 0.0D+00 do j = 1, n t = 0.0D+00 do i = 1, m t = t + a(i,j) end do t = t - 1.0D+00 error_frobenius = error_frobenius + t * t end do error_frobenius = sqrt ( error_frobenius ) return end subroutine r8mat_is_zero_one ( m, n, a, ival ) c*********************************************************************72 c cc R8MAT_IS_ZERO_ONE checks whether an R8MAT is a zero/one matrix. c c Discussion: c c An R8MAT is a matrix of double precision values. c c Licensing: c c This code is distributed under the GNU LGPL license. c c Modified: c c 21 June 2011 c c Author: c c John Burkardt c c Parameters: c c Input, integer M, N, the row and column dimensions of c the matrix. M and N must be positive. c c Input, double precision A(M,N), the matrix. c c Output, integer IVAL: c -1, the matrix is not a zero/one matrix. c 1, the matrix is a zero/one matrix. c implicit none integer m integer n double precision a(m,n) integer i integer ival integer j do i = 1, m do j = 1, n if ( a(i,j) .ne. 0.0D+00 .and. a(i,j) .ne. 1.0D+00 ) then ival = -1 return end if end do end do ival = 1 return end subroutine r8mat_mm ( n1, n2, n3, a, b, c ) c*********************************************************************72 c cc R8MAT_MM multiplies two R8MAT's. c c Discussion: c c An R8MAT is an array of R8 values. c c In FORTRAN90, this operation is more efficiently done by the c command: c c C(1:N1,1:N3) = MATMUL ( A(1:N1,1;N2), B(1:N2,1:N3) ) c c Licensing: c c This code is distributed under the GNU LGPL license. c c Modified: c c 12 December 2004 c c Author: c c John Burkardt c c Parameters: c c Input, integer N1, N2, N3, the order of the matrices. c c Input, double precision A(N1,N2), B(N2,N3), the matrices to multiply. c c Output, double precision C(N1,N3), the product matrix C = A * B. c implicit none integer n1 integer n2 integer n3 double precision a(n1,n2) double precision b(n2,n3) double precision c(n1,n3) integer i integer j integer k do i = 1, n1 do j = 1, n3 c(i,j) = 0.0D+00 do k = 1, n2 c(i,j) = c(i,j) + a(i,k) * b(k,j) end do end do end do return end subroutine r8mat_mmt ( n1, n2, n3, a, b, c ) c*********************************************************************72 c cc R8MAT_MMT multiplies computes C = A * B' for two R8MAT's. c c Discussion: c c An R8MAT is an array of R8 values. c c In FORTRAN90, this operation is more efficiently done by the c command: c c C(1:N1,1:N3) = matmul ( A(1:N1,1;N2), transpose ( B(1:N3,1:N2) ) ) c c Licensing: c c This code is distributed under the GNU LGPL license. c c Modified: c c 13 November 2012 c c Author: c c John Burkardt c c Parameters: c c Input, integer N1, N2, N3, the order of the matrices. c c Input, double precision A(N1,N2), B(N3,N2), the matrices to multiply. c c Output, double precision C(N1,N3), the product matrix C = A * B'. c implicit none integer n1 integer n2 integer n3 double precision a(n1,n2) double precision b(n3,n2) double precision c(n1,n3) double precision c1(n1,n3) integer i integer j integer k do i = 1, n1 do j = 1, n3 c1(i,j) = 0.0D+00 do k = 1, n2 c1(i,j) = c1(i,j) + a(i,k) * b(j,k) end do end do end do do j = 1, n3 do i = 1, n1 c(i,j) = c1(i,j) end do end do return end subroutine r8mat_mtm ( n1, n2, n3, a, b, c ) c*********************************************************************72 c cc R8MAT_MTM multiplies computes C = A' * B for two R8MAT's. c c Discussion: c c An R8MAT is an array of R8 values. c c In FORTRAN90, this operation is more efficiently done by the c command: c c C(1:N1,1:N3) = matmul ( transpose ( A(1:N2,1:N1) ), B(1:N2,1:N3) ) c c Licensing: c c This code is distributed under the GNU LGPL license. c c Modified: c c 07 September 2012 c c Author: c c John Burkardt c c Parameters: c c Input, integer N1, N2, N3, the order of the matrices. c c Input, double precision A(N2,N1), B(N2,N3), the matrices to multiply. c c Output, double precision C(N1,N3), the product matrix C = A' * B. c implicit none integer n1 integer n2 integer n3 double precision a(n2,n1) double precision b(n2,n3) double precision c(n1,n3) double precision c1(n1,n3) integer i integer j integer k do i = 1, n1 do j = 1, n3 c1(i,j) = 0.0D+00 do k = 1, n2 c1(i,j) = c1(i,j) + a(k,i) * b(k,j) end do end do end do do j = 1, n3 do i = 1, n1 c(i,j) = c1(i,j) end do end do return end subroutine r8mat_mv ( m, n, a, x, y ) c*********************************************************************72 c cc R8MAT_MV multiplies a matrix times a vector. c c Discussion: c c An R8MAT is an array of R8's. c c In FORTRAN90, this operation can be more efficiently carried c out by the command c c Y(1:M) = MATMUL ( A(1:M,1:N), X(1:N) ) c c Licensing: c c This code is distributed under the GNU LGPL license. c c Modified: c c 12 December 2004 c c Author: c c John Burkardt c c Parameters: c c Input, integer M, N, the number of rows and columns of the matrix. c c Input, double precision A(M,N), the M by N matrix. c c Input, double precision X(N), the vector to be multiplied by A. c c Output, double precision Y(M), the product A*X. c implicit none integer m integer n double precision a(m,n) integer i integer j double precision x(n) double precision y(m) do i = 1, m y(i) = 0.0D+00 do j = 1, n y(i) = y(i) + a(i,j) * x(j) end do end do return end function r8mat_norm_eis ( m, n, a ) c*********************************************************************72 c cc R8MAT_NORM_EIS returns the EISPACK norm of an R8MAT. c c Discussion: c c An R8MAT is an array of R8's. c c The EISPACK norm is defined as: c c R8MAT_NORM_EIS = c sum ( 1 <= I <= M ) sum ( 1 <= J <= N ) abs ( A(I,J) ) c c Licensing: c c This code is distributed under the GNU LGPL license. c c Modified: c c 23 August 2008 c c Author: c c John Burkardt c c Parameters: c c Input, integer M, the number of rows in A. c c Input, integer N, the number of columns in A. c c Input, double precision A(M,N), the matrix whose EISPACK norm is desired. c c Output, double precision R8MAT_NORM_EIS, the EISPACK norm of A. c implicit none integer m integer n double precision a(m,n) integer i integer j double precision r8mat_norm_eis r8mat_norm_eis = 0.0D+00 do j = 1, n do i = 1, m r8mat_norm_eis = r8mat_norm_eis + abs ( a(i,j) ) end do end do return end function r8mat_norm_fro ( m, n, a ) c*********************************************************************72 c cc R8MAT_NORM_FRO returns the Frobenius norm of an R8MAT. c c Discussion: c c An R8MAT is an array of R8 values. c c The Frobenius norm is defined as c c R8MAT_NORM_FRO = sqrt ( c sum ( 1 <= I <= M ) sum ( 1 <= j <= N ) A(I,J)^2 ) c c The matrix Frobenius norm is not derived from a vector norm, but c is compatible with the vector L2 norm, so that: c c r8vec_norm_l2 ( A * x ) <= r8mat_norm_fro ( A ) * r8vec_norm_l2 ( x ). c c Licensing: c c This code is distributed under the GNU LGPL license. c c Modified: c c 26 July 2008 c c Author: c c John Burkardt c c Parameters: c c Input, integer M, the number of rows in A. c c Input, integer N, the number of columns in A. c c Input, double precision A(M,N), the matrix whose Frobenius c norm is desired. c c Output, double precision R8MAT_NORM_FRO, the Frobenius norm of A. c implicit none integer m integer n double precision a(m,n) integer i integer j double precision r8mat_norm_fro double precision value value = 0.0D+00 do j = 1, n do i = 1, m value = value + a(i,j) * a(i,j) end do end do value = sqrt ( value ) r8mat_norm_fro = value return end function r8mat_norm_l1 ( m, n, a ) c*********************************************************************72 c cc R8MAT_NORM_L1 returns the matrix L1 norm of an R8MAT. c c Discussion: c c An R8MAT is an array of R8's. c c The matrix L1 norm is defined as: c c R8MAT_NORM_L1 = max ( 1 <= J <= N ) c sum ( 1 <= I <= M ) abs ( A(I,J) ). c c The matrix L1 norm is derived from the vector L1 norm, and c satisifies: c c r8vec_norm_l1 ( A * x ) <= r8mat_norm_l1 ( A ) * r8vec_norm_l1 ( x ). c c Licensing: c c This code is distributed under the GNU LGPL license. c c Modified: c c 31 August 2008 c c Author: c c John Burkardt c c Parameters: c c Input, integer M, the number of rows in A. c c Input, integer N, the number of columns in A. c c Input, double precision A(M,N), the matrix whose L1 norm is desired. c c Output, double precision R8MAT_NORM_L1, the L1 norm of A. c implicit none integer m integer n double precision a(m,n) integer i integer j double precision r8mat_norm_l1 double precision sum2 r8mat_norm_l1 = 0.0D+00 do j = 1, n sum2 = 0.0D+00 do i = 1, m sum2 = sum2 + abs ( a(i,j) ) end do r8mat_norm_l1 = max ( r8mat_norm_l1, sum2 ) end do return end function r8mat_norm_l2 ( m, n, a ) c*********************************************************************72 c cc R8MAT_NORM_L2 returns the matrix L2 norm of an M by N R8MAT. c c Discussion: c c An R8MAT is a matrix of double precision values. c c The matrix L2 norm is defined as: c c || A || = sqrt ( max ( 1 <= I <= M ) LAMBDA(I) ) c c where LAMBDA contains the eigenvalues of A * A'. c c The matrix L2 norm is derived from the vector L2 norm, and satisifies: c c r8vec_norm_l2 ( A*x ) <= r8mat_norm_l2 ( A ) * r8vec_norm_l2 ( x ). c c Licensing: c c This code is distributed under the GNU LGPL license. c c Modified: c c 20 June 2011 c c Author: c c John Burkardt c c Parameters: c c Input, integer M, N, the order of the matrix. c c Input, double precision A(M,N), the matrix. c c Output, double precision R8MAT_NORM_L2, the L2 norm of A. c implicit none integer m integer n double precision a(m,n) double precision at(n,m) double precision b(m,m) integer i double precision lambda(m) double precision r8mat_norm_l2 double precision x(m,m) c c Compute the M by M matrix B = A * A'. c call r8mat_transpose ( m, n, a, at ) call r8mat_mm ( m, n, m, a, at, b ) c c Diagonalize B. c call jacobi_iterate ( m, b, lambda, x ) c c Find the maximum eigenvalue, and take its square root. c r8mat_norm_l2 = lambda(1) do i = 2, m r8mat_norm_l2 = max ( r8mat_norm_l2, lambda(i) ) end do r8mat_norm_l2 = sqrt ( r8mat_norm_l2 ) return end function r8mat_norm_li ( m, n, a ) c*********************************************************************72 c cc R8MAT_NORM_LI returns the matrix L-oo norm of an R8MAT. c c Discussion: c c An R8MAT is an array of R8 values. c c The matrix L-oo norm is defined as: c c R8MAT_NORM_LI = max ( 1 <= I <= M ) sum ( 1 <= J <= N ) abs ( A(I,J) ). c c The matrix L-oo norm is derived from the vector L-oo norm, c and satisifies: c c r8vec_norm_li ( A * x ) <= r8mat_norm_li ( A ) * r8vec_norm_li ( x ). c c Licensing: c c This code is distributed under the GNU LGPL license. c c Modified: c c 15 May 2010 c c Author: c c John Burkardt c c Parameters: c c Input, integer M, the number of rows in A. c c Input, integer N, the number of columns in A. c c Input, double precision A(M,N), the matrix whose L-oo c norm is desired. c c Output, double precision R8MAT_NORM_LI, the L-oo norm of A. c implicit none integer m integer n double precision a(m,n) integer i integer j double precision r8mat_norm_li double precision t r8mat_norm_li = 0.0D+00 do i = 1, m t = 0.0D+00 do j = 1, n t = t + abs ( a(i,j) ) end do r8mat_norm_li = max ( r8mat_norm_li, t ) end do return end subroutine r8mat_print ( m, n, a, title ) c*********************************************************************72 c cc R8MAT_PRINT prints an R8MAT. c c Discussion: c c An R8MAT is an array of R8's. c c Licensing: c c This code is distributed under the GNU LGPL license. c c Modified: c c 20 May 2004 c c Author: c c John Burkardt c c Parameters: c c Input, integer M, the number of rows in A. c c Input, integer N, the number of columns in A. c c Input, double precision A(M,N), the matrix. c c Input, character ( len = * ) TITLE, a title. c implicit none integer m integer n double precision a(m,n) character ( len = * ) title call r8mat_print_some ( m, n, a, 1, 1, m, n, title ) return end subroutine r8mat_print_some ( m, n, a, ilo, jlo, ihi, jhi, & title ) c*********************************************************************72 c cc R8MAT_PRINT_SOME prints some of an R8MAT. c c Discussion: c c An R8MAT is an array of R8's. c c Licensing: c c This code is distributed under the GNU LGPL license. c c Modified: c c 25 January 2007 c c Author: c c John Burkardt c c Parameters: c c Input, integer M, N, the number of rows and columns. c c Input, double precision A(M,N), an M by N matrix to be printed. c c Input, integer ILO, JLO, the first row and column to print. c c Input, integer IHI, JHI, the last row and column to print. c c Input, character ( len = * ) TITLE, a title. c implicit none integer incx parameter ( incx = 5 ) integer m integer n double precision a(m,n) character * ( 14 ) ctemp(incx) integer i integer i2hi integer i2lo integer ihi integer ilo integer inc integer j integer j2 integer j2hi integer j2lo integer jhi integer jlo character * ( * ) title write ( *, '(a)' ) ' ' write ( *, '(a)' ) trim ( title ) if ( m .le. 0 .or. n .le. 0 ) then write ( *, '(a)' ) ' ' write ( *, '(a)' ) ' (None)' return end if do j2lo = max ( jlo, 1 ), min ( jhi, n ), incx j2hi = j2lo + incx - 1 j2hi = min ( j2hi, n ) j2hi = min ( j2hi, jhi ) inc = j2hi + 1 - j2lo write ( *, '(a)' ) ' ' do j = j2lo, j2hi j2 = j + 1 - j2lo write ( ctemp(j2), '(i7,7x)') j end do write ( *, '('' Col '',5a14)' ) ( ctemp(j), j = 1, inc ) write ( *, '(a)' ) ' Row' write ( *, '(a)' ) ' ' i2lo = max ( ilo, 1 ) i2hi = min ( ihi, m ) do i = i2lo, i2hi do j2 = 1, inc j = j2lo - 1 + j2 write ( ctemp(j2), '(g14.6)' ) a(i,j) end do write ( *, '(i5,a,5a14)' ) i, ':', ( ctemp(j), j = 1, inc ) end do end do return end function r8mat_trace ( n, a ) c*********************************************************************72 c cc R8MAT_TRACE computes the trace of an R8MAT. c c Discussion: c c An R8MAT is an array of R8 values. c c The trace of a square matrix is the sum of the diagonal elements. c c Licensing: c c This code is distributed under the GNU LGPL license. c c Modified: c c 15 May 2010 c c Author: c c John Burkardt c c Parameters: c c Input, integer N, the order of the matrix A. c c Input, double precision A(N,N), the matrix whose trace is desired. c c Output, double precision R8MAT_TRACE, the trace of the matrix. c implicit none integer n double precision a(n,n) integer i double precision r8mat_trace r8mat_trace = 0.0D+00 do i = 1, n r8mat_trace = r8mat_trace + a(i,i) end do return end subroutine r8mat_transpose ( m, n, a, at ) c*********************************************************************72 c cc R8MAT_TRANSPOSE makes a transposed copy of a matrix. c c Discussion: c c An R8MAT is an array of R8's. c c Licensing: c c This code is distributed under the GNU LGPL license. c c Modified: c c 13 June 2011 c c Author: c c John Burkardt c c Parameters: c c Input, integer M, N, the number of rows and columns of the matrix A. c c Input, double precision A(N,N), the matrix to be transposed. c c Output, double precision AT(N,M), the transposed matrix. c implicit none integer m integer n double precision a(m,n) double precision at(n,m) integer i integer j do j = 1, m do i = 1, n at(i,j) = a(j,i) end do end do return end subroutine r8mat_transpose_in_place ( n, a ) c*********************************************************************72 c cc R8MAT_TRANSPOSE_IN_PLACE transposes a square matrix in place. c c Discussion: c c An R8MAT is an array of R8's. c c Licensing: c c This code is distributed under the GNU LGPL license. c c Modified: c c 27 June 2008 c c Author: c c John Burkardt c c Parameters: c c Input, integer N, the number of rows and columns of the matrix A. c c Input/output, double precision A(N,N), the matrix to be transposed. c implicit none integer n double precision a(n,n) integer i integer j double precision t do j = 1, n do i = 1, j - 1 t = a(i,j) a(i,j) = a(j,i) a(j,i) = t end do end do return end subroutine r8mat_uniform_01 ( m, n, seed, r ) c*********************************************************************72 c cc R8MAT_UNIFORM_01 returns a unit pseudorandom R8MAT. c c Discussion: c c An R8MAT is an array of R8's. c c Licensing: c c This code is distributed under the GNU LGPL license. c c Modified: c c 11 August 2004 c c Author: c c John Burkardt c c Reference: c c Paul Bratley, Bennett Fox, Linus Schrage, c A Guide to Simulation, c Springer Verlag, pages 201-202, 1983. c c Bennett Fox, c Algorithm 647: c Implementation and Relative Efficiency of Quasirandom c Sequence Generators, c ACM Transactions on Mathematical Software, c Volume 12, Number 4, pages 362-376, 1986. c c Peter Lewis, Allen Goodman, James Miller, c A Pseudo-Random Number Generator for the System/360, c IBM Systems Journal, c Volume 8, pages 136-143, 1969. c c Parameters: c c Input, integer M, N, the number of rows and columns in the array. c c Input/output, integer SEED, the "seed" value, which should NOT be 0. c On output, SEED has been updated. c c Output, double precision R(M,N), the array of pseudorandom values. c implicit none integer m integer n integer i integer j integer k integer seed double precision r(m,n) if ( seed .eq. 0 ) then write ( *, '(a)' ) ' ' write ( *, '(a)' ) 'R8MAT_UNIFORM_01 - Fatal error!' write ( *, '(a)' ) ' Input value of SEED = 0.' stop 1 end if do j = 1, n do i = 1, m k = seed / 127773 seed = 16807 * ( seed - k * 127773 ) - k * 2836 if ( seed .lt. 0 ) then seed = seed + 2147483647 end if r(i,j) = dble ( seed ) * 4.656612875D-10 end do end do return end subroutine r8mat_uniform_ab ( m, n, a, b, seed, r ) c*********************************************************************72 c cc R8MAT_UNIFORM_AB returns a scaled pseudorandom R8MAT. c c Discussion: c c A <= R(I,J) <= B. c c Licensing: c c This code is distributed under the GNU LGPL license. c c Modified: c c 05 February 2005 c c Author: c c John Burkardt c c Reference: c c Paul Bratley, Bennett Fox, Linus Schrage, c A Guide to Simulation, c Second Edition, c Springer, 1987, c ISBN: 0387964673, c LC: QA76.9.C65.B73. c c Bennett Fox, c Algorithm 647: c Implementation and Relative Efficiency of Quasirandom c Sequence Generators, c ACM Transactions on Mathematical Software, c Volume 12, Number 4, December 1986, pages 362-376. c c Pierre L'Ecuyer, c Random Number Generation, c in Handbook of Simulation, c edited by Jerry Banks, c Wiley, 1998, c ISBN: 0471134031, c LC: T57.62.H37. c c Peter Lewis, Allen Goodman, James Miller, c A Pseudo-Random Number Generator for the System/360, c IBM Systems Journal, c Volume 8, Number 2, 1969, pages 136-143. c c Parameters: c c Input, integer M, N, the number of rows and columns in the array. c c Input, double precision A, B, the lower and upper limits. c c Input/output, integer SEED, the "seed" value, which should NOT be 0. c On output, SEED has been updated. c c Output, double precision R(M,N), the array of pseudorandom values. c implicit none integer m integer n double precision a double precision b integer i integer i4_huge parameter ( i4_huge = 2147483647 ) integer j integer k integer seed double precision r(m,n) if ( seed .eq. 0 ) then write ( *, '(a)' ) ' ' write ( *, '(a)' ) 'R8MAT_UNIFORM_AB - Fatal error!' write ( *, '(a)' ) ' Input value of SEED = 0.' stop 1 end if do j = 1, n do i = 1, m k = seed / 127773 seed = 16807 * ( seed - k * 127773 ) - k * 2836 if ( seed .lt. 0 ) then seed = seed + i4_huge end if r(i,j) = a + ( b - a ) * dble ( seed ) * 4.656612875D-10 end do end do return end subroutine r8poly_degree ( na, a, degree ) c*********************************************************************72 c cc R8POLY_DEGREE returns the degree of a polynomial in power sum form. c c Discussion: c c The power sum form of a polynomial is: c c p(x) = a(0) + a(1) * x + ... + a(n-1) * x^(n-1) + a(n) * x^(n) c c The degree of a polynomial is the index of the highest power c of X with a nonzero coefficient. c c The degree of a constant polynomial is 0. The degree of the c zero polynomial is debatable, but this routine returns the c degree as 0. c c Licensing: c c This code is distributed under the GNU LGPL license. c c Modified: c c 25 January 2007 c c Author: c c John Burkardt c c Parameters: c c Input, integer NA, the dimension of A. c c Input, double precision A(0:NA), the coefficients of the polynomials. c c Output, integer DEGREE, the degree of A. c implicit none integer na double precision a(0:na) integer degree degree = na 10 continue if ( 0 .lt. degree ) then if ( a(degree) .ne. 0.0D+00 ) then go to 20 end if degree = degree - 1 go to 10 end if 20 continue return end subroutine r8poly_print ( n, a, title ) c*********************************************************************72 c cc R8POLY_PRINT prints out a polynomial. c c Discussion: c c The power sum form is: c c p(x) = a(0) + a(1) * x + ... + a(n-1) * x^(n-1) + a(n) * x^(n) c c Licensing: c c This code is distributed under the GNU LGPL license. c c Modified: c c 26 January 2007 c c Author: c c John Burkardt c c Parameters: c c Input, integer N, the dimension of A. c c Input, double precision A(0:N), the polynomial coefficients. c A(0) is the constant term and c A(N) is the coefficient of X^N. c c Input, character * ( * ) TITLE, a title. c implicit none integer n double precision a(0:n) integer i double precision mag integer n2 character plus_minus character * ( * ) title integer title_length title_length = len_trim ( title ) write ( *, '(a)' ) ' ' write ( *, '(a)' ) title(1:title_length) write ( *, '(a)' ) ' ' call r8poly_degree ( n, a, n2 ) if ( a(n2) .lt. 0.0D+00 ) then plus_minus = '-' else plus_minus = ' ' end if mag = abs ( a(n2) ) if ( 2 .le. n2 ) then write ( *, '(a,a1,g14.6,a,i3)' ) & ' p(x) = ', plus_minus, mag, ' * xm ^ ', n2 else if ( n2 .eq. 1 ) then write ( *, '(a,a1,g14.6,a)' ) & ' p(x) = ', plus_minus, mag, ' * x' else if ( n2 .eq. 0 ) then write ( *, '(a,a1,g14.6)' ) ' p(x) = ', plus_minus, mag end if do i = n2 - 1, 0, -1 if ( a(i) .lt. 0.0D+00 ) then plus_minus = '-' else plus_minus = '+' end if mag = abs ( a(i) ) if ( mag .ne. 0.0D+00 ) then if ( 2 .le. i ) then write ( *, ' (9x,a1,g14.6,a,i3)' ) & plus_minus, mag, ' * x ^ ', i else if ( i .eq. 1 ) then write ( *, ' (9x,a1,g14.6,a)' ) plus_minus, mag, ' * x' else if ( i .eq. 0 ) then write ( *, ' (9x,a1,g14.6)' ) plus_minus, mag end if end if end do return end subroutine r8row_swap ( m, n, a, i1, i2 ) c*********************************************************************72 c cc R8ROW_SWAP swaps two rows of an R8ROW. c c Discussion: c c An R8ROW is an M by N array of R8 values, regarded c as an array of M rows of length N. c c Licensing: c c This code is distributed under the GNU LGPL license. c c Modified: c c 05 December 2004 c c Author: c c John Burkardt c c Parameters: c c Input, integer M, N, the number of rows and columns. c c Input/output, double precision A(M,N), the M by N array. c c Input, integer I1, I2, the two rows to swap. c implicit none integer m integer n double precision a(m,n) integer i1 integer i2 double precision row(n) if ( i1 .lt. 1 .or. m .lt. i1 ) then write ( *, '(a)' ) ' ' write ( *, '(a)' ) 'R8ROW_SWAP - Fatal error!' write ( *, '(a)' ) ' I1 is out of range.' write ( *, '(a,i8)' ) ' I1 = ', i1 stop 1 end if if ( i2 .lt. 1 .or. m .lt. i2 ) then write ( *, '(a)' ) ' ' write ( *, '(a)' ) 'R8ROW_SWAP - Fatal error!' write ( *, '(a)' ) ' I2 is out of range.' write ( *, '(a,i8)' ) ' I2 = ', i2 stop 1 end if if ( i1 .eq. i2 ) then return end if row(1:n) = a(i1,1:n) a(i1,1:n) = a(i2,1:n) a(i2,1:n) = row(1:n) return end subroutine r8row_to_r8vec ( m, n, a, x ) c*********************************************************************72 c cc R8ROW_TO_R8VEC converts an R8ROW into an R8VEC. c c Discussion: c c An R8ROW is an M by N array of R8 values, regarded c as an array of M rows of length N. c c Example: c c M = 3, N = 4 c c A = c 11 12 13 14 c 21 22 23 24 c 31 32 33 34 c c X = ( 11, 12, 13, 14, 21, 22, 23, 24, 31, 32, 33, 34 ) c c Licensing: c c This code is distributed under the GNU LGPL license. c c Modified: c c 13 July 2000 c c Author: c c John Burkardt c c Parameters: c c Input, integer M, N, the number of rows and columns. c c Input, double precision A(M,N), the M by N array. c c Output, double precision X(M*N), a vector containing the M rows of A. c implicit none integer m integer n double precision a(m,n) integer i integer j double precision x(m*n) j = 1 do i = 1, m x(j:j+n-1) = a(i,1:n) j = j + n end do return end function r8vec_amax ( n, a ) c*********************************************************************72 c cc R8VEC_AMAX returns the maximum absolute value in an R8VEC. c c Discussion: c c An R8VEC is a vector of R8's. c c Licensing: c c This code is distributed under the GNU LGPL license. c c Modified: c c 02 June 2009 c c Author: c c John Burkardt c c Parameters: c c Input, integer N, the number of entries in the array. c c Input, double precision A(N), the array. c c Output, double precision R8VEC_AMAX, the value of the entry c of largest magnitude. c implicit none integer n double precision a(n) integer i double precision r8vec_amax double precision value value = 0.0D+00 do i = 1, n value = max ( value, abs ( a(i) ) ) end do r8vec_amax = value return end function r8vec_amin ( n, a ) c*********************************************************************72 c cc R8VEC_AMIN returns the minimum absolute value in an R8VEC. c c Discussion: c c An R8VEC is a vector of R8's. c c Licensing: c c This code is distributed under the GNU LGPL license. c c Modified: c c 02 June 2009 c c Author: c c John Burkardt c c Parameters: c c Input, integer N, the number of entries in the array. c c Input, double precisionA(N), the array. c c Output, double precision R8VEC_AMIN, the value of the entry c of smallest magnitude. c implicit none integer n double precision a(n) integer i double precision r8_huge parameter ( r8_huge = 1.79769313486231571D+308 ) double precision r8vec_amin double precision value value = r8_huge do i = 1, n value = min ( value, abs ( a(i) ) ) end do r8vec_amin = value return end function r8vec_asum ( n, v1 ) c*********************************************************************72 c cc R8VEC_ASUM sums the absolute values of the entries of an R8VEC. c c Discussion: c c An R8VEC is a vector of R8's. c c Licensing: c c This code is distributed under the GNU LGPL license. c c Modified: c c 24 January 2015 c c Author: c c John Burkardt c c Parameters: c c Input, integer N, the dimension of the vectors. c c Input, double precision V1(N), the vector. c c Output, double precision R8VEC_ASUM, the sum of the absolut c values of the entries. c implicit none integer n integer i double precision r8vec_asum double precision v1(n) double precision value value = 0.0D+00 do i = 1, n value = value + abs ( v1(i) ) end do r8vec_asum = value return end subroutine r8vec_copy ( n, a1, a2 ) c*********************************************************************72 c cc R8VEC_COPY copies an R8VEC. c c Discussion: c c An R8VEC is a vector of R8 values. c c Licensing: c c This code is distributed under the GNU LGPL license. c c Modified: c c 13 August 2008 c c Author: c c John Burkardt c c Parameters: c c Input, integer N, the length of the vectors. c c Input, double precision A1(N), the vector to be copied. c c Output, double precision A2(N), a copy of A1. c implicit none integer n double precision a1(n) double precision a2(n) integer i do i = 1, n a2(i) = a1(i) end do return end function r8vec_dot_product ( n, v1, v2 ) c*********************************************************************72 c cc R8VEC_DOT_PRODUCT finds the dot product of a pair of R8VEC's. c c Discussion: c c An R8VEC is a vector of R8 values. c c In FORTRAN90, the system routine DOT_PRODUCT should be called c directly. c c Licensing: c c This code is distributed under the GNU LGPL license. c c Modified: c c 27 May 2008 c c Author: c c John Burkardt c c Parameters: c c Input, integer N, the dimension of the vectors. c c Input, double precision V1(N), V2(N), the vectors. c c Output, double precision R8VEC_DOT_PRODUCT, the dot product. c implicit none integer n integer i double precision r8vec_dot_product double precision v1(n) double precision v2(n) double precision value value = 0.0D+00 do i = 1, n value = value + v1(i) * v2(i) end do r8vec_dot_product = value return end subroutine r8vec_house_column ( n, a, k, v ) c*********************************************************************72 c cc R8VEC_HOUSE_COLUMN defines a Householder premultiplier that "packs" a column. c c Discussion: c c The routine returns a vector V that defines a Householder c premultiplier matrix H(V) that zeros out the subdiagonal entries of c column K of the matrix A. c c H(V) = I - 2 * v * v' c c Licensing: c c This code is distributed under the GNU LGPL license. c c Modified: c c 05 February 2008 c c Author: c c John Burkardt c c Parameters: c c Input, integer N, the order of the matrix A. c c Input, double precision A(N), column K of the matrix A. c c Input, integer K, the column of the matrix to be modified. c c Output, double precision V(N), a vector of unit L2 norm which defines an c orthogonal Householder premultiplier matrix H with the property c that the K-th column of H*A is zero below the diagonal. c implicit none integer n double precision a(n) integer i integer k double precision s double precision v(n) double precision vnorm do i = 1, n v(i) = 0.0D+00 end do if ( k .lt. 1 .or. n .le. k ) then return end if s = 0.0D+00 do i = k, n s = s + a(i) ** 2 end do s = sqrt ( s ) if ( s .eq. 0.0D+00 ) then return end if v(k) = a(k) + sign ( s, a(k) ) do i = k + 1, n v(i) = a(i) end do vnorm = 0.0D+00 do i = k, n vnorm = vnorm + v(i) * v(i) end do vnorm = sqrt ( vnorm ) do i = k, n v(i) = v(i) / vnorm end do return end subroutine r8vec_indicator ( n, a ) c*********************************************************************72 c cc R8VEC_INDICATOR sets an R8VEC to the indicator vector. c c Discussion: c c An R8VEC is an array of double precision real values. c c Licensing: c c This code is distributed under the GNU LGPL license. c c Modified: c c 22 January 2007 c c Author: c c John Burkardt c c Parameters: c c Input, integer N, the number of elements of A. c c Output, double precision A(N), the array to be initialized. c implicit none integer n double precision a(n) integer i do i = 1, n a(i) = dble ( i ) end do return end subroutine r8vec_linspace ( n, a, b, x ) c*********************************************************************72 c cc R8VEC_LINSPACE creates a vector of linearly spaced values. c c Discussion: c c An R8VEC is a vector of R8's. c c 4 points evenly spaced between 0 and 12 will yield 0, 4, 8, 12. c c In other words, the interval is divided into N-1 even subintervals, c and the endpoints of intervals are used as the points. c c Licensing: c c This code is distributed under the GNU LGPL license. c c Modified: c c 14 March 2011 c c Author: c c John Burkardt c c Parameters: c c Input, integer N, the number of entries in the vector. c c Input, double precision A, B, the first and last entries. c c Output, double precision X(N), a vector of linearly spaced data. c implicit none integer n double precision a double precision b integer i double precision x(n) if ( n .eq. 1 ) then x(1) = ( a + b ) / 2.0D+00 else do i = 1, n x(i) = ( dble ( n - i ) * a & + dble ( i - 1 ) * b ) & / dble ( n - 1 ) end do end if return end function r8vec_norm_l2 ( n, a ) c*********************************************************************72 c cc R8VEC_NORM_L2 returns the L2 norm of an R8VEC. c c Discussion: c c An R8VEC is a vector of R8 values. c c The vector L2 norm is defined as: c c R8VEC_NORM_L2 = sqrt ( sum ( 1 <= I <= N ) A(I)^2 ). c c Licensing: c c This code is distributed under the GNU LGPL license. c c Modified: c c 27 May 2008 c c Author: c c John Burkardt c c Parameters: c c Input, integer N, the number of entries in A. c c Input, double precision A(N), the vector whose L2 norm is desired. c c Output, double precision R8VEC_NORM_L2, the L2 norm of A. c implicit none integer n double precision a(n) integer i double precision r8vec_norm_l2 double precision value value = 0.0D+00 do i = 1, n value = value + a(i) * a(i) end do value = sqrt ( value ) r8vec_norm_l2 = value return end subroutine r8vec_print ( n, a, title ) c*********************************************************************72 c cc R8VEC_PRINT prints an R8VEC. c c Discussion: c c An R8VEC is an array of double precision real values. c c Licensing: c c This code is distributed under the GNU LGPL license. c c Modified: c c 12 January 2007 c c Author: c c John Burkardt c c Parameters: c c Input, integer N, the number of components of the vector. c c Input, double precision A(N), the vector to be printed. c c Input, character * ( * ) TITLE, a title. c implicit none integer n double precision a(n) integer i character ( len = * ) title integer title_length write ( *, '(a)' ) ' ' write ( *, '(a)' ) trim ( title ) write ( *, '(a)' ) ' ' do i = 1, n write ( *, '(2x,i8,2x,g16.8)' ) i, a(i) end do return end function r8vec_product ( n, v1 ) c*********************************************************************72 c cc R8VEC_PRODUCT multiplies the entries of an R8VEC. c c Discussion: c c An R8VEC is a vector of R8 values. c c In FORTRAN90, the system routine PRODUCT should be called c directly. c c Licensing: c c This code is distributed under the GNU LGPL license. c c Modified: c c 22 July 2008 c c Author: c c John Burkardt c c Parameters: c c Input, integer N, the dimension of the vectors. c c Input, double precision V1(N), the vector. c c Output, double precision R8VEC_PRODUCT, the product of the entries. c implicit none integer n integer i double precision r8vec_product double precision v1(n) double precision value value = 1.0D+00 do i = 1, n value = value * v1(i) end do r8vec_product = value return end subroutine r8vec_sort_bubble_a ( n, a ) c*********************************************************************72 c cc R8VEC_SORT_BUBBLE_A ascending sorts an R8VEC using bubble sort. c c Discussion: c c An R8VEC is a vector of R8's. c c Bubble sort is simple to program, but inefficient. It should not c be used for large arrays. c c Licensing: c c This code is distributed under the GNU LGPL license. c c Modified: c c 31 May 2009 c c Author: c c John Burkardt c c Parameters: c c Input, integer N, the number of entries in the array. c c Input/output, double precision A(N). c On input, an unsorted array. c On output, the array has been sorted. c implicit none integer n double precision a(n) integer i integer j double precision t do i = 1, n - 1 do j = i + 1, n if ( a(j) .lt. a(i) ) then t = a(i) a(i) = a(j) a(j) = t end if end do end do return end function r8vec_sum ( n, v1 ) c*********************************************************************72 c cc R8VEC_SUM sums the entries of an R8VEC. c c Discussion: c c An R8VEC is a vector of R8's. c c In FORTRAN90, the system routine SUM should be called c directly. c c Licensing: c c This code is distributed under the GNU LGPL license. c c Modified: c c 22 July 2008 c c Author: c c John Burkardt c c Parameters: c c Input, integer N, the dimension of the vectors. c c Input, double precision V1(N), the vector. c c Output, double precision R8VEC_SUM, the sum of the entries. c implicit none integer n integer i double precision r8vec_sum double precision v1(n) double precision value value = 0.0D+00 do i = 1, n value = value + v1(i) end do r8vec_sum = value return end subroutine r8vec_uniform_01 ( n, seed, r ) c*********************************************************************72 c cc R8VEC_UNIFORM_01 returns a unit pseudorandom R8VEC. c c Licensing: c c This code is distributed under the GNU LGPL license. c c Modified: c c 19 August 2004 c c Author: c c John Burkardt c c Reference: c c Paul Bratley, Bennett Fox, Linus Schrage, c A Guide to Simulation, c Second Edition, c Springer, 1987, c ISBN: 0387964673, c LC: QA76.9.C65.B73. c c Bennett Fox, c Algorithm 647: c Implementation and Relative Efficiency of Quasirandom c Sequence Generators, c ACM Transactions on Mathematical Software, c Volume 12, Number 4, December 1986, pages 362-376. c c Pierre L'Ecuyer, c Random Number Generation, c in Handbook of Simulation, c edited by Jerry Banks, c Wiley, 1998, c ISBN: 0471134031, c LC: T57.62.H37. c c Peter Lewis, Allen Goodman, James Miller, c A Pseudo-Random Number Generator for the System/360, c IBM Systems Journal, c Volume 8, Number 2, 1969, pages 136-143. c c Parameters: c c Input, integer N, the number of entries in the vector. c c Input/output, integer SEED, the "seed" value, which should NOT be 0. c On output, SEED has been updated. c c Output, double precision R(N), the vector of pseudorandom values. c implicit none integer n integer i integer i4_huge parameter ( i4_huge = 2147483647 ) integer k integer seed double precision r(n) if ( seed .eq. 0 ) then write ( *, '(a)' ) ' ' write ( *, '(a)' ) 'R8VEC_UNIFORM_01 - Fatal error!' write ( *, '(a)' ) ' Input value of SEED = 0.' stop 1 end if do i = 1, n k = seed / 127773 seed = 16807 * ( seed - k * 127773 ) - k * 2836 if ( seed .lt. 0 ) then seed = seed + i4_huge end if r(i) = dble ( seed ) * 4.656612875D-10 end do return end subroutine r8vec_uniform_ab ( n, a, b, seed, r ) c*********************************************************************72 c cc R8VEC_UNIFORM_AB returns a scaled pseudorandom R8VEC. c c Discussion: c c Each dimension ranges from A to B. c c Licensing: c c This code is distributed under the GNU LGPL license. c c Modified: c c 29 January 2005 c c Author: c c John Burkardt c c Reference: c c Paul Bratley, Bennett Fox, Linus Schrage, c A Guide to Simulation, c Second Edition, c Springer, 1987, c ISBN: 0387964673, c LC: QA76.9.C65.B73. c c Bennett Fox, c Algorithm 647: c Implementation and Relative Efficiency of Quasirandom c Sequence Generators, c ACM Transactions on Mathematical Software, c Volume 12, Number 4, December 1986, pages 362-376. c c Pierre L'Ecuyer, c Random Number Generation, c in Handbook of Simulation, c edited by Jerry Banks, c Wiley, 1998, c ISBN: 0471134031, c LC: T57.62.H37. c c Peter Lewis, Allen Goodman, James Miller, c A Pseudo-Random Number Generator for the System/360, c IBM Systems Journal, c Volume 8, Number 2, 1969, pages 136-143. c c Parameters: c c Input, integer N, the number of entries in the vector. c c Input, double precision A, B, the lower and upper limits. c c Input/output, integer SEED, the "seed" value, which should NOT be 0. c On output, SEED has been updated. c c Output, double precision R(N), the vector of pseudorandom values. c implicit none integer n double precision a double precision b integer i integer i4_huge parameter ( i4_huge = 2147483647 ) integer k integer seed double precision r(n) if ( seed .eq. 0 ) then write ( *, '(a)' ) ' ' write ( *, '(a)' ) 'R8VEC_UNIFORM_AB - Fatal error!' write ( *, '(a)' ) ' Input value of SEED = 0.' stop 1 end if do i = 1, n k = seed / 127773 seed = 16807 * ( seed - k * 127773 ) - k * 2836 if ( seed .lt. 0 ) then seed = seed + i4_huge end if r(i) = a + ( b - a ) * dble ( seed ) * 4.656612875D-10 end do return end subroutine r8vec2_print ( n, a1, a2, title ) c*********************************************************************72 c cc R8VEC2_PRINT prints a pair of real vectors. c c Licensing: c c This code is distributed under the GNU LGPL license. c c Modified: c c 20 June 2011 c c Author: c c John Burkardt c c Parameters: c c Input, integer N, the number of components of the vector. c c Input, double precision A1(N), A2(N), the vectors to be printed. c c Input, character * ( * ) TITLE, a title. c implicit none integer n double precision a1(n) double precision a2(n) integer i character * ( * ) title write ( *, '(a)' ) ' ' write ( *, '(a)' ) trim ( title ) write ( *, '(a)' ) ' ' do i = 1, n write ( *, '(i8,g14.6,g14.6)' ) i, a1(i), a2(i) end do return end function rayleigh ( n, a, x ) c*********************************************************************72 c cc RAYLEIGH returns the Rayleigh quotient of the matrix A and the vector X. c c Formula: c c RAYLEIGH = X' * A * X / ( X' * X ) c c Properties: c c If X is an eigenvector of A, then RAYLEIGH will equal the c corresponding eigenvalue. c c The set of all Rayleigh quotients for a matrix is known c as its "field of values". c c Licensing: c c This code is distributed under the GNU LGPL license. c c Modified: c c 20 June 2011 c c Author: c c John Burkardt c c Parameters: c c Input, integer N, the order of the matrix. c c Input, double precision A(N,N), the matrix. c c Input, double precision X(N), the vector used in the Rayleigh quotient. c c Output, double precision RAYLEIGH, the Rayleigh quotient of A and X. c implicit none integer n double precision a(n,n) double precision ax(n) double precision rayleigh double precision r8vec_dot_product double precision x(n) call r8mat_mv ( n, n, a, x, ax ) rayleigh = r8vec_dot_product ( n, x, ax ) & / r8vec_dot_product ( n, x, x ) return end function rayleigh2 ( n, a, x, y ) c*********************************************************************72 c cc RAYLEIGH2 returns the generalized Rayleigh quotient. c c Formula: c c RAYLEIGH2 = X' * A * Y / ( X' * Y ) c c Licensing: c c This code is distributed under the GNU LGPL license. c c Modified: c c 20 June 2011 c c Author: c c John Burkardt c c Parameters: c c Input, integer N, the order of the matrix. c c Input, double precision A(N,N), the matrix. c c Input, double precision X(N), Y(N), the vectors used in the c Rayleigh quotient. c c Output, double precision RAYLEIGH2, the Rayleigh quotient of A and X. c implicit none integer n double precision a(n,n) double precision ay(n) double precision r8vec_dot_product double precision rayleigh2 double precision x(n) double precision y(n) call r8mat_mv ( n, n, a, y, ay ) rayleigh2 = r8vec_dot_product ( n, x, ay ) & / r8vec_dot_product ( n, x, y ) return end subroutine rectangle_adj ( row_num, col_num, n, a ) c*********************************************************************72 c cc RECTANGLE_ADJ returns the RECTANGLE_ADJ matrix. c c Discussion: c c This is the adjacency matrix for a set of points arranged in c a ROW_NUM by COL_NUM grid. c c Diagram: c c 1---5---9 c | | | c 2---6--10 c | | | c 3---7--11 c | | | c 4---8--12 c c Example: c c ROW_NUM = 4 c COL_NUM = 3 c c 0 1 0 0 1 0 0 0 0 0 0 0 c 1 0 1 0 0 1 0 0 0 0 0 0 c 0 1 0 1 0 0 1 0 0 0 0 0 c 0 0 1 0 1 0 0 1 0 0 0 0 c c 1 0 0 0 0 1 0 0 1 0 0 0 c 0 1 0 0 1 0 1 0 0 1 0 0 c 0 0 1 0 0 1 0 1 0 0 1 0 c 0 0 0 1 0 0 1 0 0 0 0 1 c c 0 0 0 0 1 0 0 0 0 1 0 0 c 0 0 0 0 0 1 0 0 1 0 1 0 c 0 0 0 0 0 0 1 0 0 1 0 1 c 0 0 0 0 0 0 0 1 0 0 1 0 c c Properties: c c A is integral, therefore det ( A ) is integral, and c det ( A ) * inverse ( A ) is integral. c c A is a zero/one matrix. c c A is block tridiagonal. c c A is an adjacency matrix. c c A is related to the "LIGHTS_OUT" matrix. c c A is symmetric: A' = A. c c Because A is symmetric, it is normal. c c Because A is normal, it is diagonalizable. c c If 1 < ROW_NUM and 1 < COL_NUM, the matrix is singular. c Take any four nodes which form a square, set X(NW) = X(SW) = 1 c and X(NE) = X(SE) = -1 and all other X's to 0, and you have c a null vector. c c Licensing: c c This code is distributed under the GNU LGPL license. c c Modified: c c 20 June 2011 c c Author: c c John Burkardt c c Parameters: c c Input, integer ROW_NUM, COL_NUM, the number of rows and c columns in the rectangle. c c Input, integer N, the order of the matrix. c c Output, double precision A(N,N), the matrix. c implicit none integer n double precision a(n,n) double precision b(row_num,row_num) integer col_num integer i integer i_block integer ilo integer j integer j_block integer jlo integer row_num do j_block = 1, col_num jlo = ( j_block - 1 ) * row_num do i_block = 1, col_num ilo = ( i_block - 1 ) * row_num if ( j_block .eq. i_block ) then call line_adj ( row_num, b ) else if ( abs ( j_block - i_block ) .eq. 1 ) then call identity ( row_num, row_num, b ) else call zero ( row_num, row_num, b ) end if do j = 1, row_num do i = 1, row_num a(ilo+i,jlo+j) = b(i,j) end do end do end do end do return end subroutine rectangle_adj_determinant ( row_num, col_num, determ ) c*********************************************************************72 c cc RECTANGLE_ADJ_DETERMINANT: the determinant of the RECTANGLE_ADJ matrix. c c Licensing: c c This code is distributed under the GNU LGPL license. c c Modified: c c 20 June 2011 c c Author: c c John Burkardt c c Parameters: c c Input, integer ROW_NUM, COL_NUM, the number of rows and c columns in the rectangle. c c Output, double precision DETERM, the determinant. c implicit none integer col_num integer row_num double precision determ c c If ROW_NUM .eq. 1 or COL_NUM .eq. 1 we have a case of the LINE_ADJ matrix. c if ( row_num .eq. 1 ) then if ( mod ( row_num, 4 ) .eq. 1 ) then determ = 0.0D+00 else if ( mod ( row_num, 4 ) .eq. 2 ) then determ = - 1.0D+00 else if ( mod ( row_num, 4 ) .eq. 3 ) then determ = 0.0D+00 else if ( mod ( row_num, 4 ) .eq. 0 ) then determ = + 1.0D+00 end if else if ( col_num .eq. 1 ) then if ( mod ( col_num, 4 ) .eq. 1 ) then determ = 0.0D+00 else if ( mod ( col_num, 4 ) .eq. 2 ) then determ = - 1.0D+00 else if ( mod ( col_num, 4 ) .eq. 3 ) then determ = 0.0D+00 else if ( mod ( col_num, 4 ) .eq. 0 ) then determ = + 1.0D+00 end if c c Otherwise, we can form at least one square, hence a null vector, c hence the matrix is singular. c else determ = 0.0D+00 end if return end subroutine redheffer ( n, a ) c*********************************************************************72 c cc REDHEFFER returns the REDHEFFER matrix. c c Formula: c c if ( J = 1 or mod ( J, I ) .eq. 0 ) c A(I,J) = 1 c else c A(I,J) = 0 c c Example: c c N = 5 c c 1 1 1 1 1 c 1 1 0 1 0 c 1 0 1 0 0 c 1 0 0 1 0 c 1 0 0 0 1 c c Properties: c c A is generally not symmetric: A' /= A. c c A is integral, therefore det ( A ) is integral, and c det ( A ) * inverse ( A ) is integral. c c The diagonal entries of A are all 1. c c A is a zero/one matrix. c c N - int ( log2 ( N ) ) - 1 eigenvalues are equal to 1. c c There is a real eigenvalue of magnitude approximately sqrt ( N ), c which is the spectral radius of the matrix. c c There is a negative eigenvalue of value approximately -sqrt ( N ). c c The remaining eigenvalues are "small", and there is a conjecture c that they lie inside the unit circle in the complex plane. c c The determinant is equal to the Mertens function M(N). c c The family of matrices is nested as a function of N. c c Licensing: c c This code is distributed under the GNU LGPL license. c c Modified: c c 20 June 2011 c c Author: c c John Burkardt c c Reference: c c Wayne Barrett, Tyler Jarvis, c Spectral Properties of a Matrix of Redheffer, c Linear Algebra and Applications, c Volume 162, 1992, pages 673-683. c c Parameters: c c Input, integer N, the order of the matrix. c c Output, double precision A(N,N), the matrix. c implicit none integer n double precision a(n,n) integer i integer j do i = 1, n do j = 1, n if ( j .eq. 1 .or. mod ( j, i ) .eq. 0 ) then a(i,j) = 1.0D+00 else a(i,j) = 0.0D+00 end if end do end do return end subroutine redheffer_determinant ( n, determ ) c*********************************************************************72 c cc REDHEFFER_DETERMINANT returns the determinant of the REDHEFFER matrix. c c Licensing: c c This code is distributed under the GNU LGPL license. c c Modified: c c 17 October 2007 c c Author: c c John Burkardt c c Parameters: c c Input, integer N, the order of the matrix. c c Output, double precision DETERM, the determinant. c implicit none integer n double precision determ integer mertens determ = dble ( mertens ( n ) ) return end subroutine ref_random ( m, n, prob, key, a ) c*********************************************************************72 c cc REF_RANDOM returns a REF_RANDOM matrix. c c Discussion: c c The matrix returned is a random matrix in row echelon form. c c The definition of row echelon form requires: c c 1) the first nonzero entry in any row is 1. c c 2) the first nonzero entry in row I occurs in a later column c than the first nonzero entry of every previous row. c c 3) rows that are entirely zero occur after all rows with c nonzero entries. c c Example: c c M = 6, N = 5, PROB = 0.8 c c 1.0 0.3 0.2 0.0 0.5 c 0.0 0.0 1.0 0.7 0.9 c 0.0 0.0 0.0 1.0 0.3 c 0.0 0.0 0.0 0.0 1.0 c 0.0 0.0 0.0 0.0 0.0 c 0.0 0.0 0.0 0.0 0.0 c c Properties: c c A is generally not symmetric: A' /= A. c c Licensing: c c This code is distributed under the GNU LGPL license. c c Modified: c c 20 June 2011 c c Author: c c John Burkardt c c Parameters: c c Input, integer M, N, the order of the matrix. c c Input, double precision PROB, the probability that the 1 in the next c row will be placed as early as possibly. c Setting PROB = 1 forces the 1 to occur immediately, setting c PROB = 0 forces the entire matrix to be zero. A more reasonable c value might be PROB = 0.8 or 0.9. c c Input, integer KEY, a positive integer that selects the data. c c Output, double precision A(M,N), the matrix. c implicit none integer m integer n double precision a(m,n) integer i integer j integer jnew integer jprev integer key double precision prob double precision r8_uniform_01 integer seed double precision temp seed = key jprev = 0 do i = 1, m jnew = 0 do j = 1, n if ( j .le. jprev ) then a(i,j) = 0.0D+00 else if ( jnew .eq. 0 ) then temp = r8_uniform_01 ( seed ) if ( temp .le. prob ) then jnew = j a(i,j) = 1.0D+00 else a(i,j) = 0.0D+00 end if else a(i,j) = r8_uniform_01 ( seed ) end if end do if ( jnew .eq. 0 ) then jnew = n + 1 end if jprev = jnew end do return end subroutine ref_random_determinant ( n, prob, key, determ ) c*********************************************************************72 c cc REF_RANDOM_DETERMINANT: determinant of a REF_RANDOM matrix. c c Licensing: c c This code is distributed under the GNU LGPL license. c c Modified: c c 07 July 2011 c c Author: c c John Burkardt c c Parameters: c c Input, integer N, the order of the matrix. c c Input, double precision PROB, the probability that the 1 in the next c row will be placed as early as possibly. c Setting PROB = 1 forces the 1 to occur immediately, setting c PROB = 0 forces the entire matrix to be zero. A more reasonable c value might be PROB = 0.8 or 0.9. c c Input, integer KEY, a positive integer that selects the data. c c Output, double precision DETERM, the determinant. c implicit none double precision determ integer i integer j integer jnew integer jprev integer key integer n double precision prob double precision r8_uniform_01 integer seed double precision temp seed = key determ = 1.0D+00 jprev = 0 do i = 1, n jnew = 0 do j = 1, n if ( j .le. jprev ) then else if ( jnew .eq. 0 ) then temp = r8_uniform_01 ( seed ) if ( temp .le. prob ) then jnew = j else end if else temp = r8_uniform_01 ( seed ) end if end do if ( jnew .ne. i ) then determ = 0.0D+00 end if if ( jnew .eq. 0 ) then jnew = n + 1 end if jprev = jnew end do return end subroutine riemann ( m, n, a ) c*********************************************************************72 c cc RIEMANN returns the RIEMANN matrix. c c Formula: c c if ( I + 1 divides J + 1 evenly ) c A(I,J) = I c else c A(I,J) = -1 c c Example: c c M = 5, N = 5 c c 1 -1 1 -1 1 c -1 2 -1 -1 2 c -1 -1 3 -1 -1 c -1 -1 -1 4 -1 c -1 -1 -1 -1 5 c c Discussion: c c The Riemann hypothesis is true if and only if the determinant of A c is of order (Nc * N^(-.5 + epsilon)) for every positive epsilon. c c Properties: c c A is generally not symmetric: A' /= A. c c A is integral, therefore det ( A ) is integral, and c det ( A ) * inverse ( A ) is integral. c c The strict lower triangular entries are all -1. c c If A is square, then each eigenvalue LAMBDA(I) satisfies c abs ( LAMBDA(I) ) <= (N+1) - 1 / (N+1), c and eigenvalue LAMBDA(I) satisfies c 1 <= LAMBDA(I) <= I + 1 c except for at most (N+1) - sqrt ( N + 1 ) values, and c all integers in the interval ( (N+1)/3, (N+1)/2 ] are eigenvalues. c c The family of matrices is nested as a function of N. c c Licensing: c c This code is distributed under the GNU LGPL license. c c Modified: c c 20 June 2011 c c Author: c c John Burkardt c c Reference: c c Friedrich Roesler, c Riemann's hypothesis as an eigenvalue problem, c Linear Algebra and Applications, c Volume 81, 1986, pages 153-198. c c Parameters: c c Input, integer M, N, the order of the matrix. c c Output, double precision A(M,N), the matrix. c implicit none integer m integer n double precision a(m,n) integer i integer j do i = 1, m do j = 1, n if ( mod ( j + 1, i + 1 ) .eq. 0 ) then a(i,j) = dble ( i ) else a(i,j) = - 1.0D+00 end if end do end do return end subroutine ring_adj ( n, a ) c*********************************************************************72 c cc RING_ADJ returns the RING_ADJ matrix. c c Discussion: c c This is the adjacency matrix for a ring, or set of points on a circle. c c Example: c c N = 5 c c 0 1 0 0 1 c 1 0 1 0 0 c 0 1 0 1 0 c 0 0 1 0 1 c 1 0 0 1 0 c c Properties: c c A is symmetric: A' = A. c c Because A is symmetric, it is normal. c c Because A is normal, it is diagonalizable. c c The determinant for N = 1 is 1, for N = 2 is -1, and for 2 < N, c mod ( N, 4 ) = 1 ==> det ( A ) = 2 c mod ( N, 4 ) = 2 ==> det ( A ) = -4 c mod ( N, 4 ) = 3 ==> det ( A ) = 2 c mod ( N, 4 ) = 0 ==> det ( A ) = 0 c c A is a zero/one matrix. c c A is an adjacency matrix. c c A has a zero diagonal. c c A is cyclic tridiagonal. c c A is a circulant matrix: each row is shifted once to get the next row. c c A has a constant row sum of 2. c c Because it has a constant row sum of 2, c A has an eigenvalue of 2, and c a right eigenvector of ( 1, 1, 1, ..., 1 ). c c A has a constant column sum of 2. c c Because it has a constant column sum of 2, c A has an eigenvalue of 2, and c a left eigenvector of ( 1, 1, 1, ..., 1 ). c c A is persymmetric: A(I,J) = A(N+1-J,N+1-I). c c A is centrosymmetric: A(I,J) = A(N+1-I,N+1-J). c c When N is a multiple of 4, A has the null vector c (1,1,-1,-1, 1,1,-1,-1, ..., 1,1,-1,-1) c c Licensing: c c This code is distributed under the GNU LGPL license. c c Modified: c c 13 June 2011 c c Author: c c John Burkardt c c Parameters: c c Input, integer N, the order of the matrix. c c Output, double precision A(N,N), the matrix. c implicit none integer n double precision a(n,n) integer i integer j do i = 1, n do j = 1, n if ( j .eq. i + 1 .or. & j .eq. i - 1 .or. & j .eq. i + 1 - n .or. & j .eq. i - 1 + n ) then a(i,j) = 1.0D+00 else a(i,j) = 0.0D+00 end if end do end do return end subroutine ring_adj_determinant ( n, determ ) c*********************************************************************72 c cc RING_ADJ_DETERMINANT returns the determinant of the RING_ADJ matrix. c c Licensing: c c This code is distributed under the GNU LGPL license. c c Modified: c c 13 June 2011 c c Author: c c John Burkardt c c Parameters: c c Input, integer N, the order of the matrix. c c Output, double precision DETERM, the determinant. c implicit none double precision determ integer n if ( n .eq. 1 ) then determ = 1.0D+00 else if ( n .eq. 2 ) then determ = -1.0D+00 else if ( mod ( n, 4 ) .eq. 0 ) then determ = 0.0D+00 else if ( mod ( n, 4 ) .eq. 1 ) then determ = 2.0D+00 else if ( mod ( n, 4 ) .eq. 2 ) then determ = -4.0D+00 else if ( mod ( n, 4 ) .eq. 3 ) then determ = 2.0D+00 end if return end subroutine ring_adj_null_left ( m, n, x ) c*********************************************************************72 c cc RING_ADJ_NULL_LEFT returns a left null vector of the RING_ADJ matrix. c c Licensing: c c This code is distributed under the GNU LGPL license. c c Modified: c c 12 March 2015 c c Author: c c John Burkardt c c Parameters: c c Input, integer M, N, the order of the matrix. c c Output, double precision X(M), the null vector. c implicit none integer m integer n integer i double precision x(m) if ( mod ( m, 4 ) .ne. 0 ) then write ( *, '(a)' ) ' ' write ( *, '(a)' ) 'RING_ADJ_NULL_LEFT - Fatal error!' write ( *, '(a)' ) ' M must be a multiple of 4.' stop 1 end if do i = 1, m, 4 x(i) = + 1.0D+00 end do do i = 2, m, 4 x(i) = + 1.0D+00 end do do i = 3, m, 4 x(i) = - 1.0D+00 end do do i = 4, m, 4 x(i) = - 1.0D+00 end do return end subroutine ring_adj_null_right ( m, n, x ) c*********************************************************************72 c cc RING_ADJ_NULL_RIGHT returns a right null vector of the RING_ADJ matrix. c c Licensing: c c This code is distributed under the GNU LGPL license. c c Modified: c c 13 June 2011 c c Author: c c John Burkardt c c Parameters: c c Input, integer M, N, the order of the matrix. c c Output, double precision X(N), the null vector. c implicit none integer m integer n integer i double precision x(n) if ( mod ( n, 4 ) .ne. 0 ) then write ( *, '(a)' ) ' ' write ( *, '(a)' ) 'RING_ADJ_NULL_RIGHT - Fatal error!' write ( *, '(a)' ) ' N must be a multiple of 4.' stop 1 end if do i = 1, n, 4 x(i) = + 1.0D+00 end do do i = 2, n, 4 x(i) = + 1.0D+00 end do do i = 3, n, 4 x(i) = - 1.0D+00 end do do i = 4, n, 4 x(i) = - 1.0D+00 end do return end subroutine ris ( n, a ) c*********************************************************************72 c cc RIS returns the RIS matrix. c c Discussion: c c This matrix is also called the dingdong matrix. It was invented c by FN Ris. c c Formula: c c A(I,J) = 1 / ( 3 + 2 * N - 2 * I - 2 * J ) c c Example: c c N = 5 c c 1/9 1/7 1/5 1/3 1 c 1/7 1/5 1/3 1 -1 c 1/5 1/3 1 -1 -1/3 c 1/3 1 -1 -1/3 -1/5 c 1 -1 -1/3 -1/5 -1/7 c c Properties: c c A is a Cauchy matrix. c c A is a Hankel matrix: constant along anti-diagonals. c c A is symmetric: A' = A. c c Because A is symmetric, it is normal. c c Because A is normal, it is diagonalizable. c c The eigenvalues of A cluster around PI/2 and -PI/2. c c Licensing: c c This code is distributed under the GNU LGPL license. c c Modified: c c 20 June 2011 c c Author: c c John Burkardt c c Reference: c c John Nash, c Compact Numerical Methods for Computers: Linear Algebra and c Function Minimisation, c Second Edition, c Taylor & Francis, 1990, c ISBN: 085274319X, c LC: QA184.N37. c c Parameters: c c Input, integer N, the order of the matrix. c c Output, double precision A(N,N), the matrix. c implicit none integer n double precision a(n,n) integer i integer j do i = 1, n do j = 1, n a(i,j) = 1.0D+00 / dble ( 3 + 2 * n - 2 * i - 2 * j ) end do end do return end subroutine ris_determinant ( n, determ ) c*********************************************************************72 c cc RIS_DETERMINANT returns the determinant of the RIS matrix. c c Licensing: c c This code is distributed under the GNU LGPL license. c c Modified: c c 24 May 2002 c c Author: c c John Burkardt c c Parameters: c c Input, integer N, the order of the matrix. c c Output, double precision DETERM, the determinant. c implicit none integer n double precision bottom double precision determ integer i integer j double precision top top = 1.0D+00 do i = 1, n do j = i + 1, n top = top * dble ( 4 * ( i - j ) * ( i - j ) ) end do end do bottom = 1.0D+00 do i = 1, n do j = 1, n bottom = bottom * dble ( 3 + 2 * n - 2 * i - 2 * j ) end do end do determ = top / bottom return end subroutine ris_inverse ( n, a ) c*********************************************************************72 c cc RIS_INVERSE returns the inverse of the RIS matrix. c c Licensing: c c This code is distributed under the GNU LGPL license. c c Modified: c c 24 May 2002 c c Author: c c John Burkardt c c Parameters: c c Input, integer N, the order of the matrix. c c Output, double precision A(N,N), the matrix. c implicit none integer n double precision a(n,n) double precision bot1 double precision bot2 integer i integer j integer k double precision top do i = 1, n do j = 1, n top = 1.0D+00 bot1 = 1.0D+00 bot2 = 1.0D+00 do k = 1, n top = top * ( 3 + 2 * n - 2 * j - 2 * k ) & * ( 3 + 2 * n - 2 * k - 2 * i ) if ( k .ne. j ) then bot1 = bot1 * dble ( 2 * ( k - j ) ) end if if ( k .ne. i ) then bot2 = bot2 * dble ( 2 * ( k - i ) ) end if end do a(i,j) = top & / ( dble ( 3 + 2 * n - 2 * j - 2 * i ) * bot1 * bot2 ) end do end do return end subroutine rodman ( m, n, alpha, a ) c*********************************************************************72 c cc RODMAN returns the RODMAN matrix. c c Formula: c c If ( I = J ) then c A(I,J) = 1 c else c A(I,J) = ALPHA c c Example: c c M = 5, N = 5, c ALPHA = 2 c c 1 2 2 2 2 c 2 1 2 2 2 c 2 2 1 2 2 c 2 2 2 1 2 c 2 2 2 2 1 c c Properties: c c A is a special case of the combinatorial matrix. c c A is Toeplitz: constant along diagonals. c c A is a circulant matrix: each row is shifted once to get the next row. c c A has constant row sum. c c Because it has a constant row sum of 1+(N-1)*ALPHA, c A has an eigenvalue of 1+(N-1)*ALPHA, and c a right eigenvector of ( 1, 1, 1, ..., 1 ). c c A has constant column sum. c c Because it has a constant column sum of 1+(N-1)*ALPHA, c A has an eigenvalue of 1+(N-1)*ALPHA, and c a left eigenvector of ( 1, 1, 1, ..., 1 ). c c A is symmetric: A' = A. c c Because A is symmetric, it is normal. c c Because A is normal, it is diagonalizable. c c A is persymmetric: A(I,J) = A(N+1-J,N+1-I). c c A is centrosymmetric: A(I,J) = A(N+1-I,N+1-J). c c A is positive definite for ALPHA < 1. c c The eigenvalues and eigenvectors of A are: c c For I = 1 to N-1: c c LAMBDA(I) = 1 - ALPHA c V(I) = ( - sum ( 2 <= J <= N ) X(J), X(2), X(3), ..., X(N) ) c c For I = N: c c LAMBDA(I) = 1 + ALPHA * ( N - 1 ) c V(I) = ( 1, 1, 1, ..., 1 ) c c det ( A ) = ( 1 - ALPHA )^(N-1) * ( 1 + ALPHA * ( N - 1 ) ). c c A is nonsingular if ALPHA is not 1, and ALPHA is not -1/(N-1). c c The inverse of A is known. c c The family of matrices is nested as a function of N. c c Licensing: c c This code is distributed under the GNU LGPL license. c c Modified: c c 20 June 2011 c c Author: c c John Burkardt c c Reference: c c Joan Westlake, c A Handbook of Numerical Matrix Inversion and Solution of c Linear Equations, c John Wiley, 1968, c ISBN13: 978-0471936756, c LC: QA263.W47. c c Parameters: c c Input, integer M, N, the order of the matrix. c c Input, double precision ALPHA, the parameter. c c Output, double precision A(M,N), the matrix. c implicit none integer m integer n double precision a(m,n) double precision alpha integer i integer j do j = 1, n do i = 1, m a(i,j) = alpha end do end do do i = 1, min ( m, n ) a(i,i) = 1.0D+00 end do return end subroutine rodman_condition ( n, alpha, value ) c*********************************************************************72 c cc RODMAN_CONDITION returns the L1 condition of the RODMAN matrix. c c Licensing: c c This code is distributed under the GNU LGPL license. c c Modified: c c 04 April 2015 c c Author: c c John Burkardt c c Parameters: c c Input, integer N, the order of the matrix. c c Input, double precision ALPHA, the parameter. c c Output, double precision VALUE, the L1 condition. c implicit none double precision a_norm double precision alpha double precision b_norm double precision bot integer n double precision top double precision value a_norm = 1.0D+00 + dble ( n - 1 ) * abs ( alpha ) top = abs ( 1.0D+00 + alpha * dble ( n - 2 ) ) & + dble ( n - 1 ) * abs ( alpha ) bot = abs ( 1.0D+00 + alpha * dble ( n - 2 ) & - alpha * alpha * dble ( n - 1 ) ) b_norm = top / bot value = a_norm * b_norm return end subroutine rodman_determinant ( n, alpha, value ) c*********************************************************************72 c cc RODMAN_DETERMINANT returns the determinant of the RODMAN matrix. c c Licensing: c c This code is distributed under the GNU LGPL license. c c Modified: c c 21 May 2002 c c Author: c c John Burkardt c c Parameters: c c Input, integer N, the order of the matrix. c c Input, double precision ALPHA, the parameter. c c Output, double precision VALUE, the determinant. c implicit none double precision alpha integer n double precision value value = ( 1.0D+00 - alpha ) ** ( n - 1 ) * ( 1.0D+00 + alpha & * dble ( n - 1 ) ) return end subroutine rodman_eigen_right ( n, alpha, x ) c*********************************************************************72 c cc RODMAN_EIGEN_RIGHT returns right eigenvectors of the RODMAN matrix. c c Licensing: c c This code is distributed under the GNU LGPL license. c c Modified: c c 20 June 2011 c c Author: c c John Burkardt c c Parameters: c c Input, integer N, the order of the matrix. c c Input, double precision ALPHA, the parameter. c c Output, double precision X(N,N), the right eigenvectors. c implicit none integer n double precision alpha integer i integer j double precision x(n,n) do j = 1, n do i = 1, n x(i,j) = 0.0D+00 end do end do do j = 1, n - 1 x( 1,j) = +1.0D+00 x(j+1,j) = -1.0D+00 end do j = n do i = 1, n x(i,j) = 1.0D+00 end do return end subroutine rodman_eigenvalues ( n, alpha, lambda ) c*********************************************************************72 c cc RODMAN_EIGENVALUES returns the eigenvalues of the RODMAN matrix. c c Licensing: c c This code is distributed under the GNU LGPL license. c c Licensing: c c This code is distributed under the GNU LGPL license. c c Modified: c c 20 June 2011 c c Author: c c John Burkardt c c Parameters: c c Input, integer N, the order of the matrix. c c Input, double precision ALPHA, the parameter. c c Output, double precision LAMBDA(N), the eigenvalues. c implicit none integer n double precision alpha integer i double precision lambda(n) do i = 1, n - 1 lambda(i) = 1.0D+00 - alpha end do lambda(n) = 1.0D+00 + alpha * dble ( n - 1 ) return end subroutine rodman_inverse ( n, alpha, a ) c*********************************************************************72 c cc RODMAN_INVERSE returns the inverse of the RODMAN matrix. c c Formula: c c If ( I = J ) then c A(I,J) = ( 1 + ALPHA * ( N - 2 ) ) / c ( 1 + ALPHA * ( N - 2 ) - ALPHA^2 * ( N - 1 ) ) c else c A(I,J) = - ALPHA / c ( 1 + ALPHA * ( N - 2 ) - ALPHA^2 * ( N - 1 ) ) c c Example: c c N = 5, ALPHA = 2.0 c c -0.7778 0.2222 0.2222 0.2222 0.2222 c 0.2222 -0.7778 0.2222 0.2222 0.2222 c 0.2222 0.2222 -0.7778 0.2222 0.2222 c 0.2222 0.2222 0.2222 -0.7778 0.2222 c 0.2222 0.2222 0.2222 0.2222 -0.7778 c c Licensing: c c This code is distributed under the GNU LGPL license. c c Modified: c c 20 June 2011 c c Author: c c John Burkardt c c Reference: c c Joan Westlake, c A Handbook of Numerical Matrix Inversion and Solution of c Linear Equations, c John Wiley, 1968, c ISBN13: 978-0471936756, c LC: QA263.W47. c c Parameters: c c Input, integer N, the order of the matrix. c c Input, double precision ALPHA, the parameter. c c Output, double precision A(N,N), the matrix. c implicit none integer n double precision a(n,n) double precision alpha double precision bot integer i integer j bot = 1.0D+00 + alpha * dble ( n - 2 ) & - alpha * alpha * dble ( n - 1 ) do i = 1, n do j = 1, n if ( i .eq. j ) then a(i,j) = ( 1.0D+00 + alpha * dble ( n - 2 ) ) / bot else a(i,j) = - alpha / bot end if end do end do return end subroutine rosser1 ( a ) c*********************************************************************72 c cc ROSSER1 returns the ROSSER1 matrix. c c Formula: c c 611 196 -192 407 -8 -52 -49 29 c 196 899 113 -192 -71 -43 -8 -44 c -192 113 899 196 61 49 8 52 c 407 -192 196 611 8 44 59 -23 c -8 -71 61 8 411 -599 208 208 c -52 -43 49 44 -599 411 208 208 c -49 -8 8 59 208 208 99 -911 c 29 -44 52 -23 208 208 -911 99 c c Properties: c c A is singular. c c det ( A ) = 0. c c A is symmetric: A' = A. c c Because A is symmetric, it is normal. c c Because A is normal, it is diagonalizable. c c A is integral, therefore det ( A ) is integral, and c det ( A ) * inverse ( A ) is integral. c c The eigenvalues of A are: c c a = sqrt(10405), b = sqrt(26), c c LAMBDA = (-10*a, 0, 510-100*b, 1000, 1000, 510+100*b, 1020, 10*a) c c ( 10*a = 1020.04901843, 510-100*b = 0.09804864072 ) c c The eigenvectors are c c ( 2, 1, 1, 2, 102+a, 102+a, -204-2a, -204-2a ) c ( 1, 2, -2, -1, 14, 14, 7, 7 ) c ( 2, -1, 1, -2, 5-b, -5+b, -10+2b, 10-2b ) c ( 7, 14, -14, -7, -2, -2, -1, -1 ) c ( 1, -2, -2, 1, -2, 2, -1, 1 ) c ( 2, -1, 1, -2, 5+b, -5-b, -10-2b, 10+2b ) c ( 1, -2, -2, 1, 2, -2, 1, -1 ) c ( 2, 1, 1, 2, 102-a, 102-a, -204+2a, -204+2a ) c c trace ( A ) = 4040. c c Licensing: c c This code is distributed under the GNU LGPL license. c c Modified: c c 13 June 2011 c c Author: c c John Burkardt c c Reference: c c Robert Gregory, David Karney, c A Collection of Matrices for Testing Computational Algorithms, c Wiley, 1969, c ISBN: 0882756494, c LC: QA263.68 c c Joan Westlake, c A Handbook of Numerical Matrix Inversion and Solution of c Linear Equations, c John Wiley, 1968, c ISBN13: 978-0471936756, c LC: QA263.W47. c c Parameters: c c Output, double precision A(8,8), the matrix. c implicit none double precision a(8,8) double precision a_save(8,8) save a_save c c Note that the matrix entries are listed by column. c data a_save / & 611.0D+00, 196.0D+00, -192.0D+00, 407.0D+00, & -8.0D+00, -52.0D+00, -49.0D+00, 29.0D+00, & 196.0D+00, 899.0D+00, 113.0D+00, -192.0D+00, & -71.0D+00, -43.0D+00, -8.0D+00, -44.0D+00, & -192.0D+00, 113.0D+00, 899.0D+00, 196.0D+00, & 61.0D+00, 49.0D+00, 8.0D+00, 52.0D+00, & 407.0D+00, -192.0D+00, 196.0D+00, 611.0D+00, & 8.0D+00, 44.0D+00, 59.0D+00, -23.0D+00, & -8.0D+00, -71.0D+00, 61.0D+00, 8.0D+00, & 411.0D+00, -599.0D+00, 208.0D+00, 208.0D+00, & -52.0D+00, -43.0D+00, 49.0D+00, 44.0D+00, & -599.0D+00, 411.0D+00, 208.0D+00, 208.0D+00, & -49.0D+00, -8.0D+00, 8.0D+00, 59.0D+00, & 208.0D+00, 208.0D+00, 99.0D+00, -911.0D+00, & 29.0D+00, -44.0D+00, 52.0D+00, -23.0D+00, & 208.0D+00, 208.0D+00, -911.0D+00, 99.0D+00 / call r8mat_copy ( 8, 8, a_save, a ) return end subroutine rosser1_determinant ( determ ) c*********************************************************************72 c cc ROSSER1_DETERMINANT returns the determinant of the ROSSER1 matrix. c c Licensing: c c This code is distributed under the GNU LGPL license. c c Modified: c c 13 June 2011 c c Author: c c John Burkardt c c Parameters: c c Output, double precision DETERM, the determinant. c implicit none double precision determ determ = 0.0D+00 return end subroutine rosser1_eigen_left ( x ) c*********************************************************************72 c cc ROSSER1_EIGEN_LEFT returns left eigenvectors of the ROSSER1 matrix. c c Licensing: c c This code is distributed under the GNU LGPL license. c c Modified: c c 13 March 2015 c c Author: c c John Burkardt c c Parameters: c c Output, double precision X(8,8), the right eigenvector matrix. c implicit none double precision a double precision b double precision x(8,8) double precision x_save(8,8) save x_save c c Note that the matrix entries are listed by column. c data x_save / & 2.0000000000000000D+00, & 1.0000000000000000D+00, & 1.0000000000000000D+00, & 2.0000000000000000D+00, & 204.00490184299969D+00, & 204.00490184299969D+00, & -408.00980368599937D+00, & -408.00980368599937D+00, & 1.0000000000000000D+00, & 2.0000000000000000D+00, & -2.0000000000000000D+00, & -1.0000000000000000D+00, & 14.000000000000000D+00, & 14.000000000000000D+00, & 7.0000000000000000D+00, & 7.0000000000000000D+00, & 2.0000000000000000D+00, & -1.0000000000000000D+00, & 1.0000000000000000D+00, & -2.0000000000000000D+00, & -9.90195135927844916D-02, & 9.90195135927844916D-02, & 0.19803902718556898D+00, & -0.19803902718556898D+00, & 7.0000000000000000D+00, & 14.000000000000000D+00, & -14.000000000000000D+00, & -7.0000000000000000D+00, & -2.0000000000000000D+00, & -2.0000000000000000D+00, & -1.0000000000000000D+00, & -1.0000000000000000D+00, & 1.0000000000000000D+00, & -2.0000000000000000D+00, & -2.0000000000000000D+00, & 1.0000000000000000D+00, & -2.0000000000000000D+00, & 2.0000000000000000D+00, & -1.0000000000000000D+00, & 1.0000000000000000D+00, & 2.0000000000000000D+00, & -1.0000000000000000D+00, & 1.0000000000000000D+00, & -2.0000000000000000D+00, & 10.099019513592784D+00, & -10.099019513592784D+00, & -20.198039027185569D+00, & 20.198039027185569D+00, & 1.0000000000000000D+00, & -2.0000000000000000D+00, & -2.0000000000000000D+00, & 1.0000000000000000D+00, & 2.0000000000000000D+00, & -2.0000000000000000D+00, & 1.0000000000000000D+00, & -1.0000000000000000D+00, & 2.0000000000000000D+00, & 1.0000000000000000D+00, & 1.0000000000000000D+00, & 2.0000000000000000D+00, & -4.90184299968632331D-03, & -4.90184299968632331D-03, & 9.80368599937264662D-03, & 9.80368599937264662D-03 / call r8mat_copy ( 8, 8, x_save, x ) call r8mat_transpose_in_place ( 8, x ) return end subroutine rosser1_eigen_right ( x ) c*********************************************************************72 c cc ROSSER1_EIGEN_RIGHT returns right eigenvectors of the ROSSER1 matrix. c c Licensing: c c This code is distributed under the GNU LGPL license. c c Modified: c c 13 June 2011 c c Author: c c John Burkardt c c Parameters: c c Output, double precision X(8,8), the right eigenvector matrix. c implicit none double precision a double precision b double precision x(8,8) double precision x_save(8,8) save x_save c c Note that the matrix entries are listed by column. c data x_save / & 2.0000000000000000D+00, & 1.0000000000000000D+00, & 1.0000000000000000D+00, & 2.0000000000000000D+00, & 204.00490184299969D+00, & 204.00490184299969D+00, & -408.00980368599937D+00, & -408.00980368599937D+00, & 1.0000000000000000D+00, & 2.0000000000000000D+00, & -2.0000000000000000D+00, & -1.0000000000000000D+00, & 14.000000000000000D+00, & 14.000000000000000D+00, & 7.0000000000000000D+00, & 7.0000000000000000D+00, & 2.0000000000000000D+00, & -1.0000000000000000D+00, & 1.0000000000000000D+00, & -2.0000000000000000D+00, & -9.90195135927844916D-02, & 9.90195135927844916D-02, & 0.19803902718556898D+00, & -0.19803902718556898D+00, & 7.0000000000000000D+00, & 14.000000000000000D+00, & -14.000000000000000D+00, & -7.0000000000000000D+00, & -2.0000000000000000D+00, & -2.0000000000000000D+00, & -1.0000000000000000D+00, & -1.0000000000000000D+00, & 1.0000000000000000D+00, & -2.0000000000000000D+00, & -2.0000000000000000D+00, & 1.0000000000000000D+00, & -2.0000000000000000D+00, & 2.0000000000000000D+00, & -1.0000000000000000D+00, & 1.0000000000000000D+00, & 2.0000000000000000D+00, & -1.0000000000000000D+00, & 1.0000000000000000D+00, & -2.0000000000000000D+00, & 10.099019513592784D+00, & -10.099019513592784D+00, & -20.198039027185569D+00, & 20.198039027185569D+00, & 1.0000000000000000D+00, & -2.0000000000000000D+00, & -2.0000000000000000D+00, & 1.0000000000000000D+00, & 2.0000000000000000D+00, & -2.0000000000000000D+00, & 1.0000000000000000D+00, & -1.0000000000000000D+00, & 2.0000000000000000D+00, & 1.0000000000000000D+00, & 1.0000000000000000D+00, & 2.0000000000000000D+00, & -4.90184299968632331D-03, & -4.90184299968632331D-03, & 9.80368599937264662D-03, & 9.80368599937264662D-03 / call r8mat_copy ( 8, 8, x_save, x ) return end subroutine rosser1_eigenvalues ( lambda ) c*********************************************************************72 c cc ROSSER1_EIGENVALUES returns the eigenvalues of the ROSSER1 matrix. c c Licensing: c c This code is distributed under the GNU LGPL license. c c Modified: c c 13 June 2011 c c Author: c c John Burkardt c c Parameters: c c Output, double precision LAMBDA(8), the eigenvalues. c implicit none double precision a double precision b double precision lambda(8) double precision lambda_save(8) save lambda_save data lambda_save / & -1020.0490184299969D+00, & 0.0000000000000000D+00, & 0.0980486407215721556D+00, & 1000.0000000000000D+00, & 1000.0000000000000D+00, & 1019.9019513592784D+00, & 1020.0000000000000D+00, & 1020.0490184299969D+00 / call r8vec_copy ( 8, lambda_save, lambda ) return end subroutine rosser1_null_left ( x ) c*********************************************************************72 c cc ROSSER1_NULL_LEFT returns a left null vector of the ROSSER1 matrix. c c Licensing: c c This code is distributed under the GNU LGPL license. c c Modified: c c 13 March 2015 c c Author: c c John Burkardt c c Parameters: c c Output, double precision X(8), the null vector. c implicit none double precision x(8) double precision x_save(8) save x_save data x_save / & 1.0D+00, & 2.0D+00, & -2.0D+00, & -1.0D+00, & 14.0D+00, & 14.0D+00, & 7.0D+00, & 7.0D+00 / call r8vec_copy ( 8, x_save, x ) return end subroutine rosser1_null_right ( x ) c*********************************************************************72 c cc ROSSER1_NULL_RIGHT returns a right null vector of the ROSSER1 matrix. c c Licensing: c c This code is distributed under the GNU LGPL license. c c Modified: c c 13 June 2011 c c Author: c c John Burkardt c c Parameters: c c Output, double precision X(8), the null vector. c implicit none double precision x(8) double precision x_save(8) save x_save data x_save / & 1.0D+00, & 2.0D+00, & -2.0D+00, & -1.0D+00, & 14.0D+00, & 14.0D+00, & 7.0D+00, & 7.0D+00 / call r8vec_copy ( 8, x_save, x ) return end subroutine routh ( n, x, a ) c*********************************************************************72 c cc ROUTH returns the ROUTH matrix. c c Formula: c c A is tridiagonal. c A(1,1) = X(1). c A(I-1,I) = sqrt ( X(I) ), for I = 2 to N. c A(I,I-1) = - sqrt ( X(I) ), for I = 2 to N. c c Example: c c N = 5, X = ( 1, 4, 9, 16, 25 ) c c 1 -2 0 0 0 c 2 0 -3 0 0 c 0 3 0 -4 0 c 0 0 4 0 -5 c 0 0 0 5 0 c c Properties: c c A is generally not symmetric: A' /= A. c c A is tridiagonal. c c Because A is tridiagonal, it has property A (bipartite). c c A is banded, with bandwidth 3. c c A is integral, therefore det ( A ) is integral, and c det ( A ) * inverse ( A ) is integral. c c det ( A ) = product ( X(N) * X(N-2) * X(N-4) * ... * X(N+1-2*(N/2)) ) c c The family of matrices is nested as a function of N. c c Licensing: c c This code is distributed under the GNU LGPL license. c c Modified: c c 20 June 2011 c c Author: c c John Burkardt c c Parameters: c c Input, integer N, the order of the matrix. c c Input, double precision X(N), the data that defines the matrix. c c Output, double precision A(N,N), the matrix. c implicit none integer n double precision a(n,n) integer i integer j double precision x(n) do i = 1, n do j = 1, n if ( i .eq. 1 .and. j .eq. 1 ) then a(i,j) = abs ( x(1) ) else if ( i .eq. j + 1 ) then a(i,j) = sqrt ( abs ( x(i) ) ) else if ( i .eq. j - 1 ) then a(i,j) = - sqrt ( abs ( x(i+1) ) ) else a(i,j) = 0.0D+00 end if end do end do return end subroutine routh_determinant ( n, x, determ ) c*********************************************************************72 c cc ROUTH_DETERMINANT returns the determinant of the ROUTH matrix. c c Licensing: c c This code is distributed under the GNU LGPL license. c c Modified: c c 20 June 2011 c c Author: c c John Burkardt c c Parameters: c c Input, integer N, the order of the matrix. c c Input, double precision X(N), the data that defines the matrix. c c Output, double precision DETERM, the determinant. c implicit none integer n double precision determ integer i double precision x(n) determ = 1.0D+00 do i = n, 1, - 2 determ = determ * x(i) end do return end subroutine rowcolsum_matrix ( row_num, col_num, m, n, a ) c*********************************************************************72 c cc ROWCOLSUM_MATRIX returns the ROWCOLSUM matrix. c c Discussion: c c The row and column sum matrix is the linear operator which returns c the sums of the rows and columns of a rectangular data array. c c For instance, if the data array has 2 rows and 3 columns, c with the values: c c 1 2 3 c 4 5 6 c c then the row sums are (6,15) and the column sums are (5,7,9), and c the matrix, data, and row/column sums can be put in the form: c c 1 1 1 0 0 0 1 6 c 0 0 0 1 1 1 2 15 c 1 0 0 1 0 0 * 3 = 5 c 0 1 0 0 1 0 4 7 c 0 0 1 0 0 1 5 9 c 6 c c Here, we have linearly arranged the data array to constitute an c element X of an N = ROW_NUM * COL_NUM space, and the row and column sum c vectors now form a right hand side vector B which is an element of c M = ROW_NUM + COL_NUM space. c c The M by N matrix A has an interesting structure and properties. In c particular, its row rank, rank, range, null space, eigenvalues and c eigenvectors are worth knowing. In some cases, these abstract properties c have an interesting explanation or interpretation when looked at c in terms of the data array and its row and column sums. c c (Determining something about a matrix from its row and column sums c comes up in computer tomography. A sort of generalized problem of c determining the contents of the cells in a rectangular array based on c row and column summary information is presented as a game called c "Paint by Numbers" or "Descartes's Enigma". The interpretation of c tables of data representing the abundance of different species in c different habitats is of some interest in biology, and requires the c ability to generate random matrices with 0 or 1 data entries and c given row and column sum vectors.) c c Row Rank: c c It is clear that most values of ROW_NUM and COL_NUM, the matrix c maps a very large space into a small one, and hence must be c chock full of singularity. We may still wonder if the matrix c has as much nonsingularity as possible. Except for the 1 by 1 case, c it doesn't. c c The fact that the sum of the first ROW_NUM rows of the c matrix equals the sum of the last COL_NUM rows of the matrix means c that the matrix has row rank no more than M-1. Assuming that 1 < M, c then this means we have less than full row rank, and hence there is c a corresponding null vector. c c (But this loss of full row rank HAD to happen: the fact that c the sum of the row sums equals the sum of the column sums means c that the "B" objects that A creates are constrained. Hence A does c not have full range in the image space, and hence there c must be some additional loss of rank beyond the requirements imposed c simply by the number of rows in the matrixc) c c To determine this null vector, note that: c c * if either ROW_NUM or COL_NUM is even, then a corresponding null c vector is the checkerboard vector which is +1 on "red" data cells c and -1 on "black" ones. c c * If ROW_NUM and COL_NUM are both odd and greater than 1, then c put -1 in each corner, +4 in the center and zeros elsewhere. c c * If ROW_NUM and COL_NUM are both odd, and exactly one of them is 1, c then the data array is a single row or column containing an odd number c of cells greater than 1. Put a -1 in the first and last, and put c +2 in the center cell. The other cells can be set to zero. c c * If ROW_NUM and COL_NUM are both odd, and both are in fact 1, then c we already pointed out that the matrix has full row rank and there c is no corresponding null vector. c c We can deduce that the row rank of A is exactly M-1 (when 1 < M ) c by noting that if we placed the column summing rows first, c and then listed the row summing rows, except that we replaced the c first row summing row by a zero row, and moved that to the end, c then A is in REDUCED ROW ECHELON FORM and hence must have row rank c at least M-1, since there is a leading one in each row. c c Rank: c c This in turn means that (for 1 < M ) the rank of A is also M-1. c c Range: c c We have noted that, by construction, a vector B can be an image c of some data vector X only if the sum of the row sum entries equals c the sum of the column sum entries. In fact, we can regard this c as defining the range of A, which is the linear subspace of c M-space in which the sum of the first ROW_NUM entries equals the c sum of the final COL_NUM entries. c c Licensing: c c This code is distributed under the GNU LGPL license. c c Modified: c c 20 June 2011 c c Author: c c John Burkardt c c Parameters: c c Input, integer ROW_NUM, COL_NUM, the number of rows and c columns in the data array associated with the row and column sum matrix. c c Output, integer M, the number of rows of A, which is c ROW_NUM + COL_NUM. c c Output, integer N, the number of columns of A, which is c ROW_NUM * COL_NUM. c c Output, double precision A(ROW_NUM+COL_NUM,ROW_NUM * COL_NUM), the c row and column sum matrix. c implicit none integer col_num integer row_num double precision a(row_num+col_num,row_num*col_num) integer col integer i integer j integer jhi integer jlo integer m integer n integer row m = row_num + col_num n = row_num * col_num do j = 1, n do i = 1, m a(i,j) = 0.0D+00 end do end do c c Set the matrix rows that compute a row sum. c do row = 1, row_num jlo = ( row - 1 ) * col_num + 1 jhi = row * col_num do j = jlo, jhi a(row,j) = 1.0D+00 end do end do c c Set the matrix rows that compute a column sum. c do col = 1, col_num jlo = col jhi = ( row_num - 1 ) * col_num + col do j = jlo, jhi, col_num a(col+row_num,j) = 1.0D+00 end do end do return end subroutine rutis1 ( a ) c*********************************************************************72 c cc RUTIS1 returns the RUTIS1 matrix. c c Example: c c 6 4 4 1 c 4 6 1 4 c 4 1 6 4 c 1 4 4 6 c c Properties: c c A is symmetric: A' = A. c c A is integral, therefore det ( A ) is integral, and c det ( A ) * inverse ( A ) is integral. c c A has constant row sums. c c Because it has a constant row sum of 15, c A has an eigenvalue of 15, and c a right eigenvector of ( 1, 1, 1, 1 ). c c A has constant column sums. c c Because it has a constant column sum of 15, c A has an eigenvalue of 15, and c a left eigenvector of ( 1, 1, 1, ..., 1 ). c c A has a repeated eigenvalue. c c Licensing: c c This code is distributed under the GNU LGPL license. c c Modified: c c 20 June 2011 c c Author: c c John Burkardt c c Reference: c c Joan Westlake, c A Handbook of Numerical Matrix Inversion and Solution of c Linear Equations, c John Wiley, 1968, c ISBN13: 978-0471936756, c LC: QA263.W47. c c Parameters: c c Output, double precision A(4,4), the matrix. c implicit none double precision a(4,4) double precision a_save(4,4) save a_save c c Note that the matrix entries are listed by column. c data a_save / & 6.0D+00, 4.0D+00, 4.0D+00, 1.0D+00, & 4.0D+00, 6.0D+00, 1.0D+00, 4.0D+00, & 4.0D+00, 1.0D+00, 6.0D+00, 4.0D+00, & 1.0D+00, 4.0D+00, 4.0D+00, 6.0D+00 / call r8mat_copy ( 4, 4, a_save, a ) return end subroutine rutis1_condition ( cond ) c*********************************************************************72 c cc RUTIS1_CONDITION returns the L1 condition of the RUTIS1 matrix. c c Licensing: c c This code is distributed under the GNU LGPL license. c c Modified: c c 22 January 2015 c c Author: c c John Burkardt c c Parameters: c c Output, double precision COND, the L1 condition. c implicit none double precision a_norm double precision b_norm double precision cond a_norm = 15.0D+00 b_norm = 1.0D+00 cond = a_norm * b_norm return end subroutine rutis1_determinant ( determ ) c*********************************************************************72 c cc RUTIS1_DETERMINANT returns the determinant of the RUTIS1 matrix. c c Licensing: c c This code is distributed under the GNU LGPL license. c c Modified: c c 20 June 2011 c c Author: c c John Burkardt c c Parameters: c c Output, double precision DETERM, the determinant. c implicit none double precision determ determ = - 375.0D+00 return end subroutine rutis1_eigenvalues ( lambda ) c*********************************************************************72 c cc RUTIS1_EIGENVALUES returns the eigenvalues of the RUTIS1 matrix. c c Licensing: c c This code is distributed under the GNU LGPL license. c c Modified: c c 20 June 2011 c c Author: c c John Burkardt c c Parameters: c c Output, double precision LAMBDA(4), the eigenvalues. c implicit none double precision lambda(4) double precision lambda_save(4) save lambda_save data lambda_save / & 15.0D+00, & 5.0D+00, & 5.0D+00, & -1.0D+00 / call r8vec_copy ( 4, lambda_save, lambda ) return end subroutine rutis1_inverse ( a ) c*********************************************************************72 c cc RUTIS1_INVERSE returns the inverse of the RUTIS1 matrix. c c Licensing: c c This code is distributed under the GNU LGPL license. c c Modified: c c 20 June 2011 c c Author: c c John Burkardt c c Reference: c c Joan Westlake, c A Handbook of Numerical Matrix Inversion and Solution of c Linear Equations, c John Wiley, 1968, c ISBN13: 978-0471936756, c LC: QA263.W47. c c Parameters: c c Output, double precision A(4,4), the matrix. c implicit none double precision a(4,4) double precision a_save(4,4) integer i integer j save a_save c c Note that the matrix entries are listed by column. c data a_save / & -2.0D+00, 4.0D+00, 4.0D+00, -5.0D+00, & 4.0D+00, -2.0D+00, -5.0D+00, 4.0D+00, & 4.0D+00, -5.0D+00, -2.0D+00, 4.0D+00, & -5.0D+00, 4.0D+00, 4.0D+00, -2.0D+00 / call r8mat_copy ( 4, 4, a_save, a ) do j = 1, 4 do i = 1, 4 a(i,j) = a(i,j) / 15.0D+00 end do end do return end subroutine rutis1_eigen_right ( a ) c*********************************************************************72 c cc RUTIS1_EIGEN_RIGHT returns right eigenvectors of the RUTIS1 matrix. c c Licensing: c c This code is distributed under the GNU LGPL license. c c Modified: c c 20 June 2011 c c Author: c c John Burkardt c c Parameters: c c Output, double precision A(4,4), the right eigenvector matrix. c implicit none double precision a(4,4) double precision a_save(4,4) save a_save c c Note that the matrix entries are listed by column. c data a_save / & 1.0D+00, 1.0D+00, 1.0D+00, 1.0D+00, & 1.0D+00, 0.0D+00, 0.0D+00, -1.0D+00, & 0.0D+00, 1.0D+00, -1.0D+00, 0.0D+00, & 1.0D+00, -1.0D+00, -1.0D+00, 1.0D+00 / call r8mat_copy ( 4, 4, a_save, a ) return end subroutine rutis2 ( a ) c*********************************************************************72 c cc RUTIS2 returns the RUTIS2 matrix. c c Example: c c 5 4 1 1 c 4 5 1 1 c 1 1 4 2 c 1 1 2 4 c c Properties: c c A is symmetric: A' = A. c c A is integral, therefore det ( A ) is integral, and c det ( A ) * inverse ( A ) is integral. c c A has distinct eigenvalues. c c Licensing: c c This code is distributed under the GNU LGPL license. c c Modified: c c 20 June 2011 c c Author: c c John Burkardt c c Reference: c c Joan Westlake, c A Handbook of Numerical Matrix Inversion and Solution of c Linear Equations, c John Wiley, 1968, c ISBN13: 978-0471936756, c LC: QA263.W47. c c Parameters: c c Output, double precision A(4,4), the matrix. c implicit none double precision a(4,4) double precision a_save(4,4) save a_save c c Note that the matrix entries are listed by column. c data a_save / & 5.0D+00, 4.0D+00, 1.0D+00, 1.0D+00, & 4.0D+00, 5.0D+00, 1.0D+00, 1.0D+00, & 1.0D+00, 1.0D+00, 4.0D+00, 2.0D+00, & 1.0D+00, 1.0D+00, 2.0D+00, 4.0D+00 / call r8mat_copy ( 4, 4, a_save, a ) return end subroutine rutis2_condition ( cond ) c*********************************************************************72 c cc RUTIS2_CONDITION returns the L1 condition of the RUTIS2 matrix. c c Licensing: c c This code is distributed under the GNU LGPL license. c c Modified: c c 26 January 2015 c c Author: c c John Burkardt c c Parameters: c c Output, double precision COND, the L1 condition. c implicit none double precision a_norm double precision b_norm double precision cond a_norm = 11.0D+00 b_norm = 1.04D+00 cond = a_norm * b_norm return end subroutine rutis2_determinant ( determ ) c*********************************************************************72 c cc RUTIS2_DETERMINANT returns the determinant of the RUTIS2 matrix. c c Licensing: c c This code is distributed under the GNU LGPL license. c c Modified: c c 20 June 2011 c c Author: c c John Burkardt c c Parameters: c c Output, double precision DETERM, the determinant. c implicit none double precision determ determ = 100.0D+00 return end subroutine rutis2_eigenvalues ( lambda ) c*********************************************************************72 c cc RUTIS2_EIGENVALUES returns the eigenvalues of the RUTIS2 matrix. c c Licensing: c c This code is distributed under the GNU LGPL license. c c Modified: c c 20 June 2011 c c Author: c c John Burkardt c c Parameters: c c Output, double precision LAMBDA(4), the eigenvalues. c implicit none double precision lambda(4) double precision lambda_save(4) save lambda_save data lambda_save / & 10.0D+00, & 5.0D+00, & 2.0D+00, & 1.0D+00 / call r8vec_copy ( 4, lambda_save, lambda ) return end subroutine rutis2_inverse ( a ) c*********************************************************************72 c cc RUTIS2_INVERSE returns the inverse of the RUTIS2 matrix. c c Licensing: c c This code is distributed under the GNU LGPL license. c c Modified: c c 20 June 2011 c c Author: c c John Burkardt c c Reference: c c Joan Westlake, c A Handbook of Numerical Matrix Inversion and Solution of c Linear Equations, c John Wiley, 1968, c ISBN13: 978-0471936756, c LC: QA263.W47. c c Parameters: c c Output, double precision A(4,4), the matrix. c implicit none double precision a(4,4) double precision a_save(4,4) save a_save c c Note that the matrix entries are listed by column. c data a_save / & 0.56D+00, -0.44D+00, -0.02D+00, -0.02D+00, & -0.44D+00, 0.56D+00, -0.02D+00, -0.02D+00, & -0.02D+00, -0.02D+00, 0.34D+00, -0.16D+00, & -0.02D+00, -0.02D+00, -0.16D+00, 0.34D+00 / call r8mat_copy ( 4, 4, a_save, a ) return end subroutine rutis2_eigen_right ( a ) c*********************************************************************72 c cc RUTIS2_EIGEN_RIGHT returns right eigenvectors of the RUTIS2 matrix. c c Licensing: c c This code is distributed under the GNU LGPL license. c c Modified: c c 20 June 2011 c c Author: c c John Burkardt c c Parameters: c c Output, double precision A(4,4), the right eigenvector matrix. c implicit none double precision a(4,4) double precision a_save(4,4) save a_save c c Note that the matrix entries are listed by column. c data a_save / & 2.0D+00, 2.0D+00, 1.0D+00, 1.0D+00, & -1.0D+00, -1.0D+00, 2.0D+00, 2.0D+00, & 0.0D+00, 0.0D+00, -1.0D+00, 1.0D+00, & -1.0D+00, 1.0D+00, 0.0D+00, 0.0D+00 / call r8mat_copy ( 4, 4, a_save, a ) return end subroutine rutis3 ( a ) c*********************************************************************72 c cc RUTIS3 returns the RUTIS3 matrix. c c Example: c c 4 -5 0 3 c 0 4 -3 -5 c 5 -3 4 0 c 3 0 5 4 c c Properties: c c A is not symmetric: A' /= A. c c A is integral, therefore det ( A ) is integral, and c det ( A ) * inverse ( A ) is integral. c c A has distinct eigenvalues. c c A has a pair of complex eigenvalues. c c Licensing: c c This code is distributed under the GNU LGPL license. c c Modified: c c 21 June 2011 c c Author: c c John Burkardt c c Reference: c c Joan Westlake, c A Handbook of Numerical Matrix Inversion and Solution of c Linear Equations, c John Wiley, 1968, c ISBN13: 978-0471936756, c LC: QA263.W47. c c Parameters: c c Output, double precision A(4,4), the matrix. c implicit none double precision a(4,4) double precision a_save(4,4) save a_save c c Note that the matrix entries are listed by column. c data a_save / & 4.0D+00, 0.0D+00, 5.0D+00, 3.0D+00, & -5.0D+00, 4.0D+00, -3.0D+00, 0.0D+00, & 0.0D+00, -3.0D+00, 4.0D+00, 5.0D+00, & 3.0D+00, -5.0D+00, 0.0D+00, 4.0D+00 / call r8mat_copy ( 4, 4, a_save, a ) return end subroutine rutis3_condition ( cond ) c*********************************************************************72 c cc RUTIS3_CONDITION returns the L1 condition of the RUTIS3 matrix. c c Licensing: c c This code is distributed under the GNU LGPL license. c c Modified: c c 26 January 2015 c c Author: c c John Burkardt c c Parameters: c c Output, double precision COND, the L1 condition. c implicit none double precision a_norm double precision b_norm double precision cond a_norm = 12.0D+00 b_norm = 0.5D+00 cond = a_norm * b_norm return end subroutine rutis3_determinant ( determ ) c*********************************************************************72 c cc RUTIS3_DETERMINANT returns the determinant of the RUTIS3 matrix. c c Licensing: c c This code is distributed under the GNU LGPL license. c c Modified: c c 21 June 2011 c c Author: c c John Burkardt c c Parameters: c c Output, double precision DETERM, the determinant. c implicit none double precision determ determ = 624.0D+00 return end subroutine rutis3_eigenvalues ( lambda ) c*********************************************************************72 c cc RUTIS3_EIGENVALUES returns the eigenvalues of the RUTIS3 matrix. c c Licensing: c c This code is distributed under the GNU LGPL license. c c Modified: c c 21 June 2011 c c Author: c c John Burkardt c c Parameters: c c Output, double complex LAMBDA(4), the eigenvalues. c implicit none double complex lambda(4) lambda(1) = dcmplx ( 12.0D+00, 0.0D+00 ) lambda(2) = dcmplx ( 1.0D+00, 5.0D+00 ) lambda(3) = dcmplx ( 1.0D+00, -5.0D+00 ) lambda(4) = dcmplx ( 2.0D+00, 0.0D+00 ) return end subroutine rutis3_inverse ( a ) c*********************************************************************72 c cc RUTIS3_INVERSE returns the inverse of the RUTIS3 matrix. c c Licensing: c c This code is distributed under the GNU LGPL license. c c Modified: c c 21 June 2011 c c Author: c c John Burkardt c c Reference: c c Joan Westlake, c A Handbook of Numerical Matrix Inversion and Solution of c Linear Equations, c John Wiley, 1968, c ISBN13: 978-0471936756, c LC: QA263.W47. c c Parameters: c c Output, double precision A(4,4), the matrix. c implicit none double precision a(4,4) double precision a_save(4,4) integer i integer j save a_save c c Note that the matrix entries are listed by column. c data a_save / & 103.0D+00, 125.0D+00, -5.0D+00, 79.0D+00, & 5.0D+00, 103.0D+00, -79.0D+00, 125.0D+00, & -125.0D+00, -79.0D+00, 103.0D+00, -5.0D+00, & 79.0D+00, 5.0D+00, -125.0D+00, 103.0D+00 / do j = 1, 4 do i = 1, 4 a(i,j) = a_save(j,i) / 624.0D+00 end do end do return end subroutine rutis3_eigen_left ( a ) c*********************************************************************72 c cc RUTIS3_EIGEN_LEFT returns the left eigenvectors of the RUTIS3 matrix. c c Licensing: c c This code is distributed under the GNU LGPL license. c c Modified: c c 21 June 2011 c c Author: c c John Burkardt c c Parameters: c c Output, double complex A(4,4), the left eigenvector matrix. c implicit none double complex a(4,4) a(1,1) = dcmplx ( 1.0D+00, 0.0D+00 ) a(2,1) = dcmplx ( 1.0D+00, 0.0D+00 ) a(3,1) = dcmplx ( 1.0D+00, 0.0D+00 ) a(4,1) = dcmplx ( 1.0D+00, 0.0D+00 ) a(1,2) = dcmplx ( -1.0D+00, 0.0D+00 ) a(2,2) = dcmplx ( 1.0D+00, 0.0D+00 ) a(3,2) = dcmplx ( 0.0D+00, 1.0D+00 ) a(4,2) = dcmplx ( 0.0D+00, -1.0D+00 ) a(1,3) = dcmplx ( 1.0D+00, 0.0D+00 ) a(2,3) = dcmplx ( -1.0D+00, 0.0D+00 ) a(3,3) = dcmplx ( 0.0D+00, 1.0D+00 ) a(4,3) = dcmplx ( 0.0D+00, -1.0D+00 ) a(1,4) = dcmplx ( 1.0D+00, 0.0D+00 ) a(2,4) = dcmplx ( 1.0D+00, 0.0D+00 ) a(3,4) = dcmplx ( -1.0D+00, 0.0D+00 ) a(4,4) = dcmplx ( -1.0D+00, 0.0D+00 ) return end subroutine rutis3_eigen_right ( a ) c*********************************************************************72 c cc RUTIS3_EIGEN_RIGHT returns right eigenvectors of the RUTIS3 matrix. c c Licensing: c c This code is distributed under the GNU LGPL license. c c Modified: c c 21 June 2011 c c Author: c c John Burkardt c c Parameters: c c Output, double complex A(4,4), the right eigenvector matrix. c implicit none double complex a(4,4) a(1,1) = dcmplx ( 1.0D+00, 0.0D+00 ) a(2,1) = dcmplx ( -1.0D+00, 0.0D+00 ) a(3,1) = dcmplx ( 1.0D+00, 0.0D+00 ) a(4,1) = dcmplx ( 1.0D+00, 0.0D+00 ) a(1,2) = dcmplx ( 1.0D+00, 0.0D+00 ) a(2,2) = dcmplx ( 0.0D+00, -1.0D+00 ) a(3,2) = dcmplx ( 0.0D+00, -1.0D+00 ) a(4,2) = dcmplx ( -1.0D+00, 0.0D+00 ) a(1,3) = dcmplx ( 1.0D+00, 0.0D+00 ) a(2,3) = dcmplx ( 0.0D+00, 1.0D+00 ) a(3,3) = dcmplx ( 0.0D+00, 1.0D+00 ) a(4,3) = dcmplx ( -1.0D+00, 0.0D+00 ) a(1,4) = dcmplx ( 1.0D+00, 0.0D+00 ) a(2,4) = dcmplx ( 1.0D+00, 0.0D+00 ) a(3,4) = dcmplx ( -1.0D+00, 0.0D+00 ) a(4,4) = dcmplx ( 1.0D+00, 0.0D+00 ) return end subroutine rutis4 ( n, a ) c*********************************************************************72 c cc RUTIS4 returns the RUTIS4 matrix. c c Example: c c N = 6 c c 14 14 6 1 0 0 c 14 20 15 6 1 0 c 6 15 20 15 6 1 c 1 6 15 20 15 6 c 0 1 6 15 20 14 c 0 0 1 6 14 14 c c Properties: c c A is symmetric: A' = A. c c A is integral, therefore det ( A ) is integral, and c det ( A ) * inverse ( A ) is integral. c c A is banded with a bandwidth of 7. c c A is persymmetric: A(I,J) = A(N+1-J,N+1-I). c c A is the cube of the scalar tridiagonal matrix whose diagonals c are ( 1, 2, 1 ). c c LAMBDA(I) = 64 * ( cos ( i * pi / ( 2 * ( n + 1 ) ) ) )**6 c c Licensing: c c This code is distributed under the GNU LGPL license. c c Modified: c c 21 June 2011 c c Author: c c John Burkardt c c Reference: c c Joan Westlake, c A Handbook of Numerical Matrix Inversion and Solution of c Linear Equations, c John Wiley, 1968, c ISBN13: 978-0471936756, c LC: QA263.W47. c c Parameters: c c Input, integer N, the order of the matrix. c c Output, double precision A(N,N), the matrix. c implicit none integer n double precision a(n,n) integer i integer j do j = 1, n do i = 1, n a(i,j) = 0.0D+00 end do end do do i = 1, n if ( 1 .le. i - 3 ) then a(i,i-3) = 1.0D+00 end if if ( 1 .le. i - 2 ) then a(i,i-2) = 6.0D+00 end if if ( 1 .le. i - 1 ) then a(i,i-1) = 15.0D+00 end if a(i,i) = 20.0D+00 if ( i + 1 .le. n ) then a(i,i+1) = 15.0D+00 end if if ( i + 2 .le. n ) then a(i,i+2) = 6.0D+00 end if if ( i + 3 .le. n ) then a(i,i+3) = 1.0D+00 end if end do a(1,1) = 14.0D+00 a(1,2) = 14.0D+00 a(2,1) = 14.0D+00 a(n,n) = 14.0D+00 a(n-1,n) = 14.0D+00 a(n,n-1) = 14.0D+00 return end subroutine rutis4_determinant ( n, determ ) c*********************************************************************72 c cc RUTIS4_DETERMINANT returns the determinant of the RUTIS4 matrix. c c Licensing: c c This code is distributed under the GNU LGPL license. c c Modified: c c 21 June 2011 c c Author: c c John Burkardt c c Parameters: c c Input, integer N, the order of the matrix. c c Output, double precision DETERM, the determinant. c implicit none integer n double precision angle double precision determ integer i double precision r8_pi parameter ( r8_pi = 3.141592653589793D+00 ) determ = 1.0D+00 do i = 1, n angle = dble ( i ) * r8_pi / dble ( 2 * ( n + 1 ) ) determ = determ * 64.0D+00 * ( cos ( angle ) ) ** 6 end do return end subroutine rutis4_eigenvalues ( n, lambda ) c*********************************************************************72 c cc RUTIS4_EIGENVALUES returns the eigenvalues of the RUTIS4 matrix. c c Licensing: c c This code is distributed under the GNU LGPL license. c c Modified: c c 21 June 2011 c c Author: c c John Burkardt c c Parameters: c c Input, integer N, the order of the matrix. c c Output, double precision LAMBDA(N), the eigenvalues. c implicit none integer n double precision angle integer i double precision lambda(n) double precision r8_pi parameter ( r8_pi = 3.141592653589793D+00 ) do i = 1, n angle = dble ( i ) * r8_pi / dble ( 2 * ( n + 1 ) ) lambda(i) = 64.0D+00 * ( cos ( angle ) ) ** 6 end do return end subroutine rutis4_inverse ( n, a ) c*********************************************************************72 c cc RUTIS4_INVERSE returns the inverse of the RUTIS4 matrix. c c Licensing: c c This code is distributed under the GNU LGPL license. c c Modified: c c 21 June 2011 c c Author: c c John Burkardt c c Parameters: c c Input, integer N, the order of the matrix. c c Output, double precision A(N,N), the matrix. c implicit none integer n double precision a(n,n) double precision b(n,n) double precision c(n,n) call oto_inverse ( n, b ) call r8mat_mm ( n, n, n, b, b, c ) call r8mat_mm ( n, n, n, b, c, a ) return end subroutine rutis5 ( a ) c*********************************************************************72 c cc RUTIS5 returns the RUTIS5 matrix. c c Example: c c 10 1 4 0 c 1 10 5 -1 c 4 5 10 7 c 0 -1 7 9 c c Properties: c c A is symmetric: A' = A. c c A is integral, therefore det ( A ) is integral, and c det ( A ) * inverse ( A ) is integral. c c Licensing: c c This code is distributed under the GNU LGPL license. c c Modified: c c 21 June 2011 c c Author: c c John Burkardt c c Reference: c c John Todd, c Basic Numerical Mathematics, c Volume 2: Numerical Algebra, c Birkhauser, 1980, c ISBN: 0817608117, c LC: QA297.T58. c c Parameters: c c Output, double precision A(4,4), the matrix. c implicit none double precision a(4,4) double precision a_save(4,4) save a_save c c Note that the matrix entries are listed by column. c data a_save / & 10.0D+00, 1.0D+00, 4.0D+00, 0.0D+00, & 1.0D+00, 10.0D+00, 5.0D+00, -1.0D+00, & 4.0D+00, 5.0D+00, 10.0D+00, 7.0D+00, & 0.0D+00, -1.0D+00, 7.0D+00, 9.0D+00 / call r8mat_copy ( 4, 4, a_save, a ) return end subroutine rutis5_condition ( cond ) c*********************************************************************72 c cc RUTIS5_CONDITION returns the L1 condition of the RUTIS5 matrix. c c Licensing: c c This code is distributed under the GNU LGPL license. c c Modified: c c 10 April 2012 c c Author: c c John Burkardt c c Parameters: c c Output, double precision COND, the L1 condition. c implicit none double precision cond cond = 62608.0D+00 return end subroutine rutis5_determinant ( determ ) c*********************************************************************72 c cc RUTIS5_DETERMINANT returns the determinant of the RUTIS5 matrix. c c Licensing: c c This code is distributed under the GNU LGPL license. c c Modified: c c 21 June 2011 c c Author: c c John Burkardt c c Parameters: c c Output, double precision DETERM, the determinant. c implicit none double precision determ determ = 1.0D+00 return end subroutine rutis5_eigenvalues ( lambda ) c*********************************************************************72 c cc RUTIS5_EIGENVALUES returns the eigenvalues of the RUTIS5 matrix. c c Licensing: c c This code is distributed under the GNU LGPL license. c c Modified: c c 21 June 2011 c c Author: c c John Burkardt c c Parameters: c c Output, double precision LAMBDA(4), the eigenvalues. c implicit none double precision lambda(4) double precision lambda_save(4) save lambda_save data lambda_save / & 19.122479087555860D+00, & 10.882816916492464D+00, & 8.994169735037230D+00, & 0.000534260914449D+00 / call r8vec_copy ( 4, lambda_save, lambda ) return end subroutine rutis5_inverse ( a ) c*********************************************************************72 c cc RUTIS5_INVERSE returns the inverse of the RUTIS5 matrix. c c Example: c c 105 167 -304 255 c 167 266 -484 406 c -304 -484 881 -739 c 255 406 -739 620 c c Licensing: c c This code is distributed under the GNU LGPL license. c c Modified: c c 21 June 2011 c c Author: c c John Burkardt c c Reference: c c John Todd, c Basic Numerical Mathematics, c Volume 2: Numerical Algebra, c Birkhauser, 1980, c ISBN: 0817608117, c LC: QA297.T58. c c Parameters: c c Output, double precision A(4,4), the matrix. c implicit none double precision a(4,4) double precision a_save(4,4) save a_save c c Note that the matrix entries are listed by column. c data a_save / & 105.0D+00, 167.0D+00, -304.0D+00, 255.0D+00, & 167.0D+00, 266.0D+00, -484.0D+00, 406.0D+00, & -304.0D+00, -484.0D+00, 881.0D+00, -739.0D+00, & 255.0D+00, 406.0D+00, -739.0D+00, 620.0D+00 / call r8mat_copy ( 4, 4, a_save, a ) return end subroutine rutis5_eigen_right ( a ) c*********************************************************************72 c cc RUTIS5_EIGEN_RIGHT returns right eigenvectors of the RUTIS5 matrix. c c Licensing: c c This code is distributed under the GNU LGPL license. c c Modified: c c 21 June 2011 c c Author: c c John Burkardt c c Parameters: c c Output, double precision A(4,4), the right eigenvector matrix. c implicit none double precision a(4,4) double precision a_save(4,4) save a_save c c Note that the matrix entries are listed by column. c data a_save / & 0.356841883715928D+00, & 0.382460905084129D+00, & 0.718205429169617D+00, & 0.458877421126365D+00, & -0.341449101169948D+00, & -0.651660990948502D+00, & 0.087555987078632D+00, & 0.671628180850787D+00, & 0.836677864423576D+00, & -0.535714651223808D+00, & -0.076460316709461D+00, & -0.084461728708607D+00, & -0.236741488801405D+00, & -0.376923628103094D+00, & 0.686053008598214D+00, & -0.575511351279045D+00 / call r8mat_copy ( 4, 4, a_save, a ) return end subroutine schur_block ( n, x, y, a ) c*********************************************************************72 c cc SCHUR_BLOCK returns the SCHUR_BLOCK matrix. c c Formula: c c if ( i .eq. j ) c a(i,j) = x( (i+1)/2 ) c else if ( mod ( i, 2 ) .eq. 1 .and. j .eq. i + 1 ) c a(i,j) = y( (i+1)/2 ) c else if ( mod ( i, 2 ) .eq. 0 .and. j .eq. i - 1 ) c a(i,j) = -y( (i+1)/2 ) c else c a(i,j) = 0.0D+00 c c Example: c c N = 5, X = ( 1, 2, 3 ), Y = ( 4, 5 ) c c 1 4 0 0 0 c -4 1 0 0 0 c 0 0 2 5 0 c 0 0 -5 2 0 c 0 0 0 0 3 c c Properties: c c A is generally not symmetric: A' /= A. c c A is block diagonal, with the blocks being 2 by 2 or 1 by 1 in size. c c A is in real Schur form. c c The eigenvalues of A are X(I) +/- sqrt ( - 1 ) * Y(I) c c A is tridiagonal. c c A is banded, with bandwidth 3. c c Licensing: c c This code is distributed under the GNU LGPL license. c c Modified: c c 20 June 2011 c c Author: c c John Burkardt c c Reference: c c Francoise Chatelin, c Section 4.2.7, c Eigenvalues of Matrices, c John Wiley, 1993. c c Francoise Chatelin, Valerie Fraysse, c Qualitative computing: Elements of a theory for finite precision c computation, Lecture notes, c CERFACS, Toulouse, France and THOMSON-CSF, Orsay, France, June 1993. c c Parameters: c c Input, integer N, the order of the matrix. c c Input, double precision X( (N+1)/2 ), specifies the diagonal elements c of A. c c Input, double precision Y( N/2 ), specifies the off-diagonal elements c of the Schur blocks. c c Output, double precision A(N,N), the matrix. c implicit none integer n double precision a(n,n) integer i integer j double precision x((n+1)/2) double precision y(n/2) do j = 1, n do i = 1, n if ( i .eq. j ) then a(i,j) = x( (i+1)/2 ) else if ( mod ( i, 2 ) .eq. 1 .and. j .eq. i + 1 ) then a(i,j) = y( (i+1)/2 ) else if ( mod ( i, 2 ) .eq. 0 .and. j .eq. i - 1 ) then a(i,j) = - y( (i+1)/2 ) else a(i,j) = 0.0D+00 end if end do end do return end subroutine schur_block_determinant ( n, x, y, determ ) c*********************************************************************72 c cc SCHUR_BLOCK_DETERMINANT returns the determinant of the SCHUR_BLOCK matrix. c c Licensing: c c This code is distributed under the GNU LGPL license. c c Modified: c c 20 June 2011 c c Author: c c John Burkardt c c Parameters: c c Input, integer N, the order of the matrix. c c Input, double precision X( (N+1)/2 ), specifies the diagonal c elements of A. c c Input, double precision Y( N/2 ), specifies the off-diagonal c elements of the Schur blocks. c c Output, double precision DETERM, the determinant of A. c implicit none integer n double precision determ integer i double precision x((n+1)/2) double precision y(n/2) determ = 1.0D+00 do i = 1, n / 2 determ = determ * ( x(i) * x(i) + y(i) * y(i) ) end do if ( mod ( n, 2 ) .eq. 1 ) then determ = determ * x((n+1)/2) end if return end subroutine schur_block_eigenvalues ( n, x, y, lambda ) c*********************************************************************72 c cc SCHUR_BLOCK_EIGENVALUES returns the eigenvalues of the SCHUR_BLOCK matrix. c c Licensing: c c This code is distributed under the GNU LGPL license. c c Modified: c c 20 June 2011 c c Author: c c John Burkardt c c Parameters: c c Input, integer N, the order of the matrix. c c Input, double precision X( (N+1)/2 ), specifies the diagonal c elements of A. c c Input, double precision Y( N/2 ), specifies the off-diagonal c elements of the Schur blocks. c c Output, double complex LAMBDA(N), the eigenvalues of A. c implicit none integer n integer i integer k double complex lambda(n) double precision x((n+1)/2) double precision y(n/2) k = 0 do i = 1, n / 2 k = k + 1 lambda(k) = dcmplx ( x(i), y(i) ) k = k + 1 lambda(k) = dcmplx ( x(i), -y(i) ) end do if ( k .lt. n ) then k = k + 1 lambda(k) = x((n+1)/2) end if return end subroutine schur_block_inverse ( n, x, y, a ) c*********************************************************************72 c cc SCHUR_BLOCK_INVERSE returns the inverse of the SCHUR_BLOCK matrix. c c Licensing: c c This code is distributed under the GNU LGPL license. c c Modified: c c 20 June 2011 c c Author: c c John Burkardt c c Parameters: c c Input, integer N, the order of the matrix. c c Input, double precision X( (N+1)/2 ), specifies the diagonal elements c of A. c c Input, double precision Y( N/2 ), specifies the off-diagonal elements c of the Schur blocks. c c Output, double precision A(N,N), the matrix. c implicit none integer n double precision a(n,n) integer i integer j integer k double precision x((n+1)/2) double precision y(n/2) do j = 1, n do i = 1, n k = ( i + 1 ) / 2 if ( i .eq. j ) then if ( i .eq. n .and. mod ( n, 2 ) .eq. 1 ) then a(i,j) = 1.0D+00 / x(k) else a(i,j) = x(k) / ( x(k) * x(k) + y(k) * y(k) ) end if else if ( mod ( i, 2 ) .eq. 1 .and. j .eq. i + 1 ) then a(i,j) = - y(k) / ( x(k) * x(k) + y(k) * y(k) ) else if ( mod ( i, 2 ) .eq. 0 .and. j .eq. i - 1 ) then a(i,j) = y(k) / ( x(k) * x(k) + y(k) * y(k) ) else a(i,j) = 0.0D+00 end if end do end do return end subroutine skew_circulant ( m, n, x, a ) c*********************************************************************72 c cc SKEW_CIRCULANT returns a SKEW_CIRCULANT matrix. c c Formula: c c K = 1 + mod ( J - I, N ) c c if ( I <= J ) then c A(I,J) = +X(K) c else c A(I,J) = -X(K) c c Example: c c M = 4, N = 4, X = ( 1, 2, 3, 4 ) c c 1 2 3 4 c -4 1 2 3 c -3 -4 1 2 c -2 -3 -4 1 c c M = 4, N = 5, X = ( 1, 2, 3, 4, 5 ) c c 1 2 3 4 5 c -5 1 2 3 4 c -4 -5 1 2 3 c -3 -4 -5 1 2 c c M = 5, N = 4, X = ( 1, 2, 3, 4 ) c c 1 2 3 4 c -5 1 2 3 c -4 -5 1 2 c -3 -4 -5 1 c -1 -2 -3 -4 c c Licensing: c c This code is distributed under the GNU LGPL license. c c Modified: c c 20 June 2011 c c Author: c c John Burkardt c c Parameters: c c Input, integer M, N, the order of the matrix. c c Input, double precision X(N), the values in the first row of A. c c Output, double precision A(M,N), the matrix. c implicit none integer m integer n double precision a(m,n) integer i integer i4_modp integer j integer k double precision x(n) do j = 1, n do i = 1, m k = 1 + i4_modp ( j - i, n ) if ( i .le. j ) then a(i,j) = + x(k) else a(i,j) = - x(k) end if end do end do return end subroutine skew_circulant_determinant ( n, x, determ ) c*********************************************************************72 c cc SKEW_CIRCULANT_DETERMINANT: the determinant of the SKEW_CIRCULANT matrix. c c Licensing: c c This code is distributed under the GNU LGPL license. c c Modified: c c 20 June 2011 c c Author: c c John Burkardt c c Parameters: c c Input, integer N, the order of the matrix. c c Input, double precision X(N), the values in the first row of A. c c Output, double precision DETERM, the determinant. c implicit none integer n double precision angle double precision determ integer j integer j_hi integer k double complex lambda double precision r8_pi parameter ( r8_pi = 3.141592653589793D+00 ) double precision x(n) determ = 1.0D+00 j_hi = ( n + 1 ) / 2 do j = 1, j_hi lambda = 0.0D+00 do k = 1, n angle = dble ( ( 2 * j - 1 ) * ( k - 1 ) ) & * r8_pi / dble ( n ) lambda = lambda & + x(k) * dcmplx ( cos ( angle ), sin ( angle ) ) end do if ( 2 * j .le. n ) then determ = determ * ( abs ( lambda ) ) ** 2 else determ = determ * real ( lambda ) end if end do return end subroutine skew_circulant_eigenvalues ( n, x, lambda ) c*********************************************************************72 c cc SKEW_CIRCULANT_EIGENVALUES returns eigenvalues of the SKEW_CIRCULANT matrix. c c Licensing: c c This code is distributed under the GNU LGPL license. c c Modified: c c 20 October 2007 c c Author: c c John Burkardt c c Parameters: c c Input, integer N, the order of the matrix. c c Input, double precision X(N), the values in the first row of A. c c Output, double complex LAMBDA(N), the eigenvalues. c implicit none integer n double precision angle integer i integer j integer k double complex lambda(n) double precision r8_pi parameter ( r8_pi = 3.141592653589793D+00 ) double precision x(n) do i = 1, n lambda(i) = 0.0D+00 end do do j = 1, n do k = 1, n angle = dble ( ( 2 * j - 1 ) * ( k - 1 ) ) * r8_pi & / dble ( n ) lambda(j) = lambda(j) & + x(k) * dcmplx ( cos ( angle ), sin ( angle ) ) end do end do return end subroutine smoke1 ( n, a ) c*********************************************************************72 c cc SMOKE1 returns the SMOKE1 matrix. c c Formula: c c W = exp ( 2 * PI * sqrt ( -1 ) / N ) c c If ( J = I + 1 ) then c A(I,J) = 1 c If ( I = N and J = 1 ) then c A(I,J) = 1 c If ( I = J ) then c A(I,J) = W^I c Else c A(I,J) = 0 c c Example: c c N = 5 c c w 1 0 0 0 c 0 w^2 1 0 0 c 0 0 w^3 1 0 c 0 0 0 w^4 1 c 1 0 0 0 w^5 c c Properties: c c A is generally not symmetric: A' /= A. c c The matrix has an interesting spectrum. The eigenvalues are c the N-th roots of unity times 2^(1/N). c c Licensing: c c This code is distributed under the GNU LGPL license. c c Modified: c c 20 June 2011 c c Author: c c John Burkardt c c Reference: c c Lothar Reichel, Lloyd Trefethen, c Eigenvalues and pseudo-eigenvalues of Toeplitz matrices, c Linear Algebra and Applications, c Volume 162-164, 1992, pages 153-185. c c Parameters: c c Input, integer N, the order of the matrix. c c Output, double complex A(N,N), the matrix. c implicit none integer n double complex a(n,n) double complex c8_i integer i integer j double precision r8_pi parameter ( r8_pi = 3.141592653589793D+00 ) double complex w w = exp ( 2.0D+00 * r8_pi * c8_i ( ) / dble ( n ) ) do j = 1, n do i = 1, n if ( i + 1 .eq. j ) then a(i,j) = 1.0D+00 else if ( i .eq. n .and. j .eq. 1 ) then a(i,j) = 1.0D+00 else if ( i .eq. j ) then a(i,j) = w**i else a(i,j) = 0.0D+00 end if end do end do return end subroutine smoke1_determinant ( n, determ ) c*********************************************************************72 c cc SMOKE1_DETERMINANT returns the determinant of the SMOKE1 matrix. c c Licensing: c c This code is distributed under the GNU LGPL license. c c Modified: c c 20 June 2011 c c Author: c c John Burkardt c c Parameters: c c Input, integer N, the order of the matrix. c c Output, double precision DETERM, the determinant. c implicit none double precision determ integer n if ( mod ( n, 2 ) .eq. 1 ) then determ = 2.0D+00 else determ = - 2.0D+00 end if return end subroutine smoke1_eigenvalues ( n, lambda ) c*********************************************************************72 c cc SMOKE1_EIGENVALUES returns the eigenvalues of the SMOKE1 matrix. c c Licensing: c c This code is distributed under the GNU LGPL license. c c Modified: c c 20 June 2011 c c Author: c c John Burkardt c c Parameters: c c Input, integer N, the order of the matrix. c c Output, double complex LAMBDA(N), the eigenvalues. c implicit none integer n double precision angle double complex c8_i integer i double complex lambda(n) double precision r8_pi parameter ( r8_pi = 3.141592653589793D+00 ) do i = 1, n angle = 2.0D+00 * r8_pi * dble ( i ) / dble ( n ) lambda(i) = exp ( angle * c8_i ( ) ) end do do i = 1, n lambda(i) = lambda(i) * 2.0D+00 ** ( 1.0D+00 / dble ( n ) ) end do return end subroutine smoke2 ( n, a ) c*********************************************************************72 c cc SMOKE2 returns the SMOKE2 matrix. c c Formula: c c W = exp ( 2 * PI * sqrt ( -1 ) / N ) c c If ( J = I + 1 ) then c A(I,J) = 1 c If ( I = J ) then c A(I,J) = W^I c Else c A(I,J) = 0 c c Example: c c N = 5 c c w 1 0 0 0 c 0 w^2 1 0 0 c 0 0 w^3 1 0 c 0 0 0 w^4 1 c 0 0 0 0 w^5 c c Properties: c c A is generally not symmetric: A' /= A. c c The eigenvalues are the N-th roots of unity. c c Licensing: c c This code is distributed under the GNU LGPL license. c c Modified: c c 20 June 2011 c c Author: c c John Burkardt c c Reference: c c Lothar Reichel, Lloyd Trefethen, c Eigenvalues and pseudo-eigenvalues of Toeplitz matrices, c Linear Algebra and Applications, c Volume 162-164, 1992, pages 153-185. c c Parameters: c c Input, integer N, the order of the matrix. c c Output, double complex A(N,N), the matrix. c implicit none integer n double complex a(n,n) double complex c8_i integer i integer j double precision r8_pi parameter ( r8_pi = 3.141592653589793D+00 ) double complex w w = exp ( 2.0D+00 * r8_pi * c8_i ( ) / dble ( n ) ) do j = 1, n do i = 1, n if ( i + 1 .eq. j ) then a(i,j) = 1.0D+00 else if ( i .eq. j ) then a(i,j) = w ** i else a(i,j) = 0.0D+00 end if end do end do return end subroutine smoke2_determinant ( n, determ ) c*********************************************************************72 c cc SMOKE2_DETERMINANT returns the determinant of the SMOKE2 matrix. c c Licensing: c c This code is distributed under the GNU LGPL license. c c Modified: c c 20 June 2011 c c Author: c c John Burkardt c c Parameters: c c Input, integer N, the order of the matrix. c c Output, double precision DETERM, the determinant. c implicit none double precision determ integer n if ( mod ( n, 2 ) .eq. 1 ) then determ = 1.0D+00 else determ = - 1.0D+00 end if return end subroutine smoke2_eigenvalues ( n, lambda ) c*********************************************************************72 c cc SMOKE2_EIGENVALUES returns the eigenvalues of the SMOKE2 matrix. c c Licensing: c c This code is distributed under the GNU LGPL license. c c Modified: c c 20 June 2011 c c Author: c c John Burkardt c c Parameters: c c Input, integer N, the order of the matrix. c c Output, double complex LAMBDA(N), the eigenvalues. c implicit none integer n double precision angle double complex c8_i integer i double complex lambda(n) double precision r8_pi parameter ( r8_pi = 3.141592653589793D+00 ) do i = 1, n angle = 2.0D+00 * r8_pi * dble ( i ) / dble ( n ) lambda(i) = exp ( angle * c8_i ( ) ) end do return end subroutine snakes ( a ) c*********************************************************************integer72 c cc SNAKES returns the Snakes and Ladders transition matrix. c c Discussion: c c The game of Snakes and Ladders, or Chutes and Ladders, is played on a c 10x10 board of squares, numbered in boustrophedonic order, with the c lower left corner numbered 1, and the upper left corner 100. c c Certain pairs of squares are joined by a ladder, and others by a snake. c c A player starts off the board, occupying fictitious square 0. c A single die is rolled to determine the player's moves. Each roll of c the die advances the player along the board. However, if the player c lands on a square that is the bottom of a ladder, the player moves c immediately to the top of the ladder, which is always a higher-numbered c square. Similarly, landing on the "mouth" of a snake means that the c player immediately drops back to the square that is the tail of the c snake, a lower-numbered square. c c A player's game is over when the square 100 is reached. While the board c game version stipulates that the 100 square must be reached by an exact c roll, it is common for players to ignore this stipulation, so that a c player's game is over when the next location is 100, or greater. c c The snakes and ladders matrix contains the transition probabilities, c that is, A(I,J) is the probability that a player currently located c at square J will end up at square I after a single roll of the dice. c c If we could ignore the snakes and ladders and the final squares, then c the matrix would be all zero, except that entries A(I+1:I+6,J) would c be 1/6. c c Licensing: c c This code is distributed under the GNU LGPL license. c c Modified: c c 15 July 2013 c c Author: c c John Burkardt c c Parameters: c c Output, double precision A(101,101), the matrix. c implicit none integer, parameter :: ladder_num = 9 integer, parameter :: n = 101 integer, parameter :: snake_num = 10 double precision a(n,n) integer i integer ihi integer j integer jhi integer k integer l integer ladder(2,ladder_num) integer m integer s integer snake(2,snake_num) integer t save ladder save snake data ladder / & 1, 38, & 4, 14, & 9, 31, & 21, 42, & 28, 84, & 36, 44, & 51, 67, & 71, 91, & 80, 100 / data snake / & 98, 78, & 95, 75, & 93, 73, & 87, 24, & 64, 60, & 62, 19, & 56, 53, & 49, 11, & 48, 26, & 16, 6 / do j = 1, n do i = 1, n a(i,j) = 0.0D+00 end do end do c c Start by ignoring snakes and ladders. c do j = 1, n ihi = min ( j + 6, n ) do i = j + 1, ihi a(i,j) = 1.0D+00 end do end do c c Deal with the fact that squares 96 through 101 have extra chances c of ending up at 101. In particular, 101 will amount to a fixed point. c do j = 96, n a(n,j) = a(n,j) + dble ( j - 95 ) end do c c For each snake, from S to T. c All entries in row S are transferred to row T. c Logically, column S is irrelevant, because we can never end on square S. c For linear algebra's sake, set column S to zero, but A(T,S) to 1. c do k = 1, snake_num s = snake(1,k) + 1 t = snake(2,k) + 1 do j = 1, n a(t,j) = a(t,j) + a(s,j) a(s,j) = 0.0D+00 end do do i = 1, n a(i,s) = 0.0D+00 end do a(t,s) = 6.0D+00 end do c c For each ladder, from L to M: c All entries in row L are transferred to row M. c Logically, column L is irrelevant, because we can never end on square L. c For linear algebra's sake, set column L to zero, but A(M,L) to 1. c do k = 1, ladder_num l = ladder(1,k) + 1 m = ladder(2,k) + 1 do j = 1, n a(m,j) = a(m,j) + a(l,j) a(l,j) = 0.0D+00 end do do i = 1, n a(i,l) = 0.0D+00 end do a(m,l) = 6.0D+00 end do c c Normalize. c do j = 1, n do i = 1, n a(i,j) = a(i,j) / 6.0D+00 end do end do return end subroutine sort_heap_external ( n, indx, i, j, isgn ) c*********************************************************************72 c cc SORT_HEAP_EXTERNAL externally sorts a list of items into ascending order. c c Discussion: c c The actual list of data is not passed to the routine. Hence this c routine may be used to sort integers, reals, numbers, names, c dates, shoe sizes, and so on. After each call, the routine asks c the user to compare or interchange two items, until a special c return value signals that the sorting is completed. c c Licensing: c c This code is distributed under the GNU LGPL license. c c Modified: c c 25 January 2007 c c Author: c c Original FORTRAN77 version by Albert Nijenhuis, Herbert Wilf. c This FORTRAN77 version by John Burkardt. c c Reference: c c Albert Nijenhuis, Herbert Wilf, c Combinatorial Algorithms for Computers and Calculators, c Academic Press, 1978, c ISBN: 0-12-519260-6, c LC: QA164.N54. c c Parameters: c c Input, integer N, the number of items to be sorted. c c Input/output, integer INDX, the main communication signal. c c The user must set INDX to 0 before the first call. c Thereafter, the user should not change the value of INDX until c the sorting is done. c c On return, if INDX is c c greater than 0, c * interchange items I and J; c * call again. c c less than 0, c * compare items I and J; c * set ISGN = -1 if I .lt. J, ISGN = +1 if J .lt. I; c * call again. c c equal to 0, the sorting is done. c c Output, integer I, J, the indices of two items. c On return with INDX positive, elements I and J should be interchanged. c On return with INDX negative, elements I and J should be compared, and c the result reported in ISGN on the next call. c c Input, integer ISGN, results of comparison of elements I and J. c (Used only when the previous call returned INDX less than 0). c ISGN .le. 0 means I is less than or equal to J; c 0 .le. ISGN means I is greater than or equal to J. c implicit none integer i integer i_save integer indx integer isgn integer j integer j_save integer k integer k1 integer n integer n1 save i_save save j_save save k save k1 save n1 data i_save / 0 / data j_save / 0 / data k / 0 / data k1 / 0 / data n1 / 0 / c c INDX = 0: This is the first call. c if ( indx .eq. 0 ) then i_save = 0 j_save = 0 k = n / 2 k1 = k n1 = n c c INDX .lt. 0: The user is returning the results of a comparison. c else if ( indx .lt. 0 ) then if ( indx .eq. -2 ) then if ( isgn .lt. 0 ) then i_save = i_save + 1 end if j_save = k1 k1 = i_save indx = -1 i = i_save j = j_save return end if if ( 0 .lt. isgn ) then indx = 2 i = i_save j = j_save return end if if ( k .le. 1 ) then if ( n1 .eq. 1 ) then i_save = 0 j_save = 0 indx = 0 else i_save = n1 n1 = n1 - 1 j_save = 1 indx = 1 end if i = i_save j = j_save return end if k = k - 1 k1 = k c c 0 .lt. INDX, the user was asked to make an interchange. c else if ( indx .eq. 1 ) then k1 = k end if 10 continue i_save = 2 * k1 if ( i_save .eq. n1 ) then j_save = k1 k1 = i_save indx = -1 i = i_save j = j_save return else if ( i_save .le. n1 ) then j_save = i_save + 1 indx = -2 i = i_save j = j_save return end if if ( k .le. 1 ) then go to 20 end if k = k - 1 k1 = k go to 10 20 continue if ( n1 .eq. 1 ) then i_save = 0 j_save = 0 indx = 0 i = i_save j = j_save else i_save = n1 n1 = n1 - 1 j_save = 1 indx = 1 i = i_save j = j_save end if return end subroutine spline ( n, x, a ) c*********************************************************************72 c cc SPLINE returns the SPLINE matrix. c c Discussion: c c This matrix arises during interpolation with cubic splines. c c Formula: c c if ( I = 1 and J = I ) then c A(I,J) = 2 * X(I) c else if ( I = 1 and J = I + 1 ) then c A(I,J) = X(I) c else if ( I = N and J = I ) then c A(I,J) = 2 * X(N-1) c else if ( I = N and J = I - 1 ) then c A(I,J) = X(N-1) c else if ( J = I ) then c A(I,J) = 2 * (X(I-1)+X(I)) c else if ( J = I-1 ) then c A(I,J) = X(I-1) c else if ( J = I + 1 ) then c A(I,J) = X(I) c else c A(I,J) = 0 c c Example: c c N = 5 c X = ( 1, 1, 1, 1 ) c c 2 1 0 0 0 c 1 4 1 0 0 c 0 1 4 1 0 c 0 0 1 4 1 c 0 0 0 1 2 c c N = 5 c X = ( 1, 2, 3, 4 ) c c 2 1 0 0 0 c 1 6 2 0 0 c 0 2 10 3 0 c 0 0 3 14 4 c 0 0 0 4 8 c c Properties: c c A is symmetric: A' = A. c c Because A is symmetric, it is normal. c c Because A is normal, it is diagonalizable. c c A is tridiagonal. c c Because A is tridiagonal, it has property A (bipartite). c c A is banded, with bandwidth 3. c c If the entries of X are positive, then A is positive definite. c c If the entries of X are all of one sign, then A is diagonally dominant. c c Licensing: c c This code is distributed under the GNU LGPL license. c c Modified: c c 20 June 2011 c c Author: c c John Burkardt c c Parameters: c c Input, integer N, the order of the matrix. c c Input, double precision X(N-1), values that represent the spacing c between points, and which define the entries of A. c c Output, double precision A(N,N), the matrix. c implicit none integer n double precision a(n,n) integer i integer j double precision x(n-1) do j = 1, n do i = 1, n if ( i .eq. 1 .and. j .eq. i ) then a(i,j) = 2.0D+00 * x(1) else if ( i .eq. 1 .and. j .eq. i + 1 ) then a(i,j) = x(1) else if ( i .eq. n .and. j .eq. i ) then a(i,j) = 2.0D+00 * x(n-1) else if ( i .eq. n .and. j .eq. i - 1 ) then a(i,j) = x(n-1) else if ( j .eq. i ) then a(i,j) = 2.0D+00 * ( x(i-1) + x(i) ) else if ( j .eq. i - 1 ) then a(i,j) = x(i-1) else if ( j .eq. i + 1 ) then a(i,j) = x(i) else a(i,j) = 0.0D+00 end if end do end do return end subroutine spline_determinant ( n, x, determ ) c*********************************************************************72 c cc SPLINE_DETERMINANT computes the determinant of the SPLINE matrix. c c Licensing: c c This code is distributed under the GNU LGPL license. c c Modified: c c 20 June 2011 c c Author: c c John Burkardt c c Parameters: c c Input, integer N, the order of the matrix. c c Input, double precision X(N-1), the parameters. c c Output, double precision DETERM, the determinant. c implicit none integer n double precision determ double precision determ_nm1 double precision determ_nm2 integer i double precision x(n-1) determ_nm1 = 2.0D+00 * x(n-1) if ( n .eq. 1 ) then determ = determ_nm1 return end if determ_nm2 = determ_nm1 if ( n .eq. 2 ) then determ_nm1 = & 4.0D+00 * x(n-1) * x(n-1) - x(n-1) * x(n-1) else determ_nm1 = & 4.0D+00 * ( x(n-2) + x(n-1) ) * x(n-1) - x(n-1) * x(n-1) end if if ( n .eq. 2 ) then determ = determ_nm1 return end if do i = n - 2, 1, -1 if ( i .eq. 1 ) then determ = 2.0D+00 * x(i) * determ_nm1 & - x(i) * x(i) * determ_nm2 else determ = 2.0D+00 * ( x(i-1) + x(i) ) * determ_nm1 & - x(i) * x(i) * determ_nm2 end if determ_nm2 = determ_nm1 determ_nm1 = determ end do return end subroutine spline_inverse ( n, x, a ) c*********************************************************************72 c cc SPLINE_INVERSE returns the inverse of the SPLINE matrix. c c Licensing: c c This code is distributed under the GNU LGPL license. c c Modified: c c 20 June 2011 c c Author: c c John Burkardt c c Reference: c c CM daFonseca, J Petronilho, c Explicit Inverses of Some Tridiagonal Matrices, c Linear Algebra and Its Applications, c Volume 325, 2001, pages 7-21. c c Parameters: c c Input, integer N, the order of the matrix. c c Input, double precision X(N-1), the parameters. c c Output, double precision A(N,N), the inverse of the matrix. c implicit none integer n double precision a(n,n) double precision d(n) double precision e(n) integer i integer j double precision r8_mop double precision r8vec_product double precision x(n-1) d(n) = 2.0D+00 * x(n-1) do i = n - 1, 2, -1 d(i) = 2.0D+00 * ( x(i-1) + x(i) ) - x(i) * x(i) / d(i+1) end do d(1) = 2.0D+00 * x(1) - x(1) * x(1) / d(2) e(1) = 2.0D+00 * x(1) do i = 2, n - 1 e(i) = 2.0D+00 * ( x(i-1) + x(i) ) - x(i-1) * x(i-1) / e(i-1) end do e(n) = 2.0D+00 * x(n-1) - x(n-1) * x(n-1) / e(n-1) do i = 1, n do j = 1, i a(i,j) = r8_mop ( i + j ) & * r8vec_product ( i - j, x(j) ) & * r8vec_product ( n - i, d(i+1) ) & / r8vec_product ( n - j + 1, e(j) ) end do do j = i + 1, n a(i,j) = r8_mop ( i + j ) & * r8vec_product ( j - i, x(i) ) & * r8vec_product ( n - j, d(j+1) ) & / r8vec_product ( n - i + 1, e(i) ) end do end do return end subroutine stirling ( m, n, a ) c*********************************************************************72 c cc STIRLING returns the STIRLING matrix. c c Discussion: c c The entries of this matrix are the Stirling numbers of the first kind. c c The absolute value of the Stirling number S1(I,J) gives the number c of permutations on I objects having exactly J cycles, while the c sign of the Stirling number records the sign (odd or even) of c the permutations. For example, there are six permutations on 3 objects: c c A B C 3 cycles (A) (B) (C) c A C B 2 cycles (A) (BC) c B A C 2 cycles (AB) (C) c B C A 1 cycle (ABC) c C A B 1 cycle (ABC) c C B A 2 cycles (AC) (B) c c There are c c 2 permutations with 1 cycle, and S1(3,1) = 2 c 3 permutations with 2 cycles, and S1(3,2) = -3, c 1 permutation with 3 cycles, and S1(3,3) = 1. c c Since there are Nc permutations of N objects, the sum of the absolute c values of the Stirling numbers in a given row, c c sum ( 1 <= J <= I ) abs ( S1(I,J) ) = Nc c c First terms: c c I/J: 1 2 3 4 5 6 7 8 c c 1 1 0 0 0 0 0 0 0 c 2 -1 1 0 0 0 0 0 0 c 3 2 -3 1 0 0 0 0 0 c 4 -6 11 -6 1 0 0 0 0 c 5 24 -50 35 -10 1 0 0 0 c 6 -120 274 -225 85 -15 1 0 0 c 7 720 -1764 1624 -735 175 -21 1 0 c 8 -5040 13068 -13132 6769 -1960 322 -28 1 c c Recursion: c c S1(I,1) = (-1)^(I-1) * (I-1)! for all I. c S1(I,I) = 1 for all I. c S1(I,J) = 0 if I < J. c c S1(I,J) = S1(I-1,J-1) - (I-1) * S1(I-1,J) c c Properties: c c A is generally not symmetric: A' /= A. c c A is integral, therefore det ( A ) is integral, and c det ( A ) * inverse ( A ) is integral. c c A is lower triangular. c c det ( A ) = 1. c c A is unimodular. c c LAMBDA(1:N) = 1. c c After row 1, each row sums to 0. c c The family of matrices is nested as a function of N. c c Licensing: c c This code is distributed under the GNU LGPL license. c c Modified: c c 16 August 2008 c c Author: c c John Burkardt c c Parameters: c c Input, integer M, N, the order of the matrix. c c Output, double precision A(M,N), the matrix. c implicit none integer m integer n double precision a(m,n) integer i integer j a(1,1) = 1.0D+00 do j = 2, n a(1,j) = 0.0D+00 end do do i = 2, m a(i,1) = - dble ( i - 1 ) * a(i-1,1) do j = 2, n a(i,j) = a(i-1,j-1) - dble ( i - 1 ) * a(i-1,j) end do end do return end subroutine stirling_determinant ( n, determ ) c*********************************************************************72 c cc STIRLING_DETERMINANT returns the determinant of the STIRLING matrix. c c Licensing: c c This code is distributed under the GNU LGPL license. c c Modified: c c 16 August 2008 c c Author: c c John Burkardt c c Parameters: c c Input, integer N, the order of the matrix. c c Output, double precision DETERM, the determinant. c implicit none double precision determ integer n determ = 1.0D+00 return end subroutine stirling_eigenvalues ( n, lambda ) c*********************************************************************72 c cc STIRLING_EIGENVALUES returns the eigenvalues of the STIRLING matrix. c c Licensing: c c This code is distributed under the GNU LGPL license. c c Modified: c c 16 August 2008 c c Author: c c John Burkardt c c Parameters: c c Input, integer N, the order of the matrix. c c Output, double precision LAMBDA(N), the eigenvalues. c implicit none integer n integer i double precision lambda(n) do i = 1, n lambda(i) = 1.0D+00 end do return end subroutine stirling_inverse ( n, a ) c*********************************************************************72 c cc STIRLING_INVERSE returns the inverse of the STIRLING matrix. c c Comments: c c The inverse of S1, the matrix of Stirling numbers of the first kind, c is S2, the matrix of Stirling numbers of the second kind. c c S2(I,J) represents the number of distinct partitions of I elements c into J nonempty sets. For any I, the sum over J of the Stirling c numbers S2(I,J) is represented by B(I), called "Bell's number", c and represents the number of distinct partitions of I elements. c c For example, with 4 objects, there are: c c 1 partition into 1 set: c c (A,B,C,D) c c 7 partitions into 2 sets: c c (A,B,C) (D) c (A,B,D) (C) c (A,C,D) (B) c (A) (B,C,D) c (A,B) (C,D) c (A,C) (B,D) c (A,D) (B,C) c c 6 partitions into 3 sets: c c (A,B) (C) (D) c (A) (B,C) (D) c (A) (B) (C,D) c (A,C) (B) (D) c (A,D) (B) (C) c (A) (B,D) (C) c c 1 partition into 4 sets: c c (A) (B) (C) (D) c c So S2(4,1) = 1, S2(4,2) = 7, S2(4,3) = 6, S2(4,4) = 1, and B(4) = 15. c c c First terms: c c I/J: 1 2 3 4 5 6 7 8 c c 1 1 0 0 0 0 0 0 0 c 2 1 1 0 0 0 0 0 0 c 3 1 3 1 0 0 0 0 0 c 4 1 7 6 1 0 0 0 0 c 5 1 15 25 10 1 0 0 0 c 6 1 31 90 65 15 1 0 0 c 7 1 63 301 350 140 21 1 0 c 8 1 127 966 1701 1050 266 28 1 c c Recursion: c c S2(I,1) = 1 for all I. c S2(I,I) = 1 for all I. c S2(I,J) = 0 if I < J. c c S2(I,J) = J * S2(I-1,J) + S2(I-1,J-1) c c Properties: c c A is generally not symmetric: A' /= A. c c A is integral, therefore det ( A ) is integral, and c det ( A ) * inverse ( A ) is integral. c c A is lower triangular. c c A is nonnegative. c c det ( A ) = 1. c c A is unimodular. c c LAMBDA(1:N) = 1. c c Licensing: c c This code is distributed under the GNU LGPL license. c c Modified: c c 16 August 2008 c c Author: c c John Burkardt c c Parameters: c c Input, integer N, the order of the matrix. c c Output, double precision A(N,N), the matrix. c implicit none integer n double precision a(n,n) integer i integer j a(1,1) = 1.0D+00 do j = 2, n a(1,j) = 0.0D+00 end do do i = 2, n a(i,1) = 1.0D+00 do j = 2, n a(i,j) = dble ( j ) * a(i-1,j) + a(i-1,j-1) end do end do return end subroutine stripe ( n, a ) c*********************************************************************72 c cc STRIPE returns the STRIPE matrix. c c Example: c c N = 7 c c 5 2 1 1 . . . c 2 6 3 1 1 . . c 1 3 6 3 1 1 . c 1 1 3 6 3 1 1 c . 1 1 3 6 3 1 c . . 1 1 3 6 2 c . . . 1 1 2 5 c c Properties: c c A is integral, therefore det ( A ) is integral, and c det ( A ) * inverse ( A ) is integral. c c A is symmetric: A' = A. c c A is banded, with bandwidth 7. c c A is centrosymmetric: A(I,J) = A(N+1-I,N+1-J). c c Licensing: c c This code is distributed under the GNU LGPL license. c c Modified: c c 20 June 2011 c c Author: c c John Burkardt c c Reference: c c Joan Westlake, c A Handbook of Numerical Matrix Inversion and Solution of c Linear Equations, c John Wiley, 1968, c ISBN13: 978-0471936756, c LC: QA263.W47. c c Parameters: c c Input, integer N, the order of the matrix. c c Output, double precision A(N,N), the matrix. c implicit none integer n double precision a(n,n) integer i integer j do j = 1, n do i = 1, n if ( j .eq. i - 3 ) then a(i,j) = 1.0D+00 else if ( j .eq. i - 2 ) then a(i,j) = 1.0D+00 else if ( j .eq. i - 1 ) then if ( j .eq. 1 .or. j .eq. n - 1 ) then a(i,j) = 2.0D+00 else a(i,j) = 3.0D+00 end if else if ( j .eq. i ) then if ( i .eq. 1 .or. i .eq. n ) then a(i,j) = 5.0D+00 else a(i,j) = 6.0D+00 end if else if ( j .eq. i + 1 ) then if ( j .eq. 2 .or. j .eq. n ) then a(i,j) = 2.0D+00 else a(i,j) = 3.0D+00 end if else if ( j .eq. i + 2 ) then a(i,j) = 1.0D+00 else if ( j .eq. i + 3 ) then a(i,j) = 1.0D+00 else a(i,j) = 0.0D+00 end if end do end do return end subroutine subset_random ( n, seed, a ) c*********************************************************************72 c cc SUBSET_RANDOM selects a random subset of an N-set. c c Example: c c N = 4 c c 0 0 1 1 c 0 1 0 1 c 1 1 0 1 c 0 0 1 0 c 0 0 0 1 c 1 1 0 0 c c Licensing: c c This code is distributed under the GNU LGPL license. c c Modified: c c 25 January 2007 c c Author: c c Original FORTRAN77 version by Albert Nijenhuis, Herbert Wilf. c This FORTRAN77 version by John Burkardt. c c Reference: c c Albert Nijenhuis, Herbert Wilf, c Combinatorial Algorithms for Computers and Calculators, c Second Edition, c Academic Press, 1978, c ISBN: 0-12-519260-6, c LC: QA164.N54. c c Parameters: c c Input, integer N, the size of the full set. c c Input/output, integer SEED, a seed for the random number generator. c c Output, integer A(N). A vector to hold the information about c the set chosen. On return, if A(I) = 1, then c I is in the random subset, otherwise, A(I) = 0 c and I is not in the random subset. c implicit none integer n integer a(n) integer i integer i4_uniform_ab integer seed do i = 1, n a(i) = i4_uniform_ab ( 0, 1, seed ) end do return end subroutine summation ( m, n, a ) c*********************************************************************72 c cc SUMMATION returns the SUMMATION matrix. c c Example: c c M = 5, N = 5 c c 1 0 0 0 0 c 1 1 0 0 0 c 1 1 1 0 0 c 1 1 1 1 0 c 1 1 1 1 1 c c Properties: c c A is generally not symmetric: A' /= A. c c A is lower triangular. c c A is a 0/1 matrix. c c The vector Y = A * X contains the partial sums of the vector X. c c A is Toeplitz: constant along diagonals. c c A is nonsingular. c c det ( A ) = 1. c c A is unimodular. c c LAMBDA(1:N) = 1. c c The only eigenvector is (0,0,0,...,0,1). c c A is persymmetric: A(I,J) = A(N+1-J,N+1-I). c c The family of matrices is nested as a function of N. c c Licensing: c c This code is distributed under the GNU LGPL license. c c Modified: c c 20 June 2011 c c Author: c c John Burkardt c c Parameters: c c Input, integer M, N, the order of the matrix. c c Output, double precision A(M,N), the matrix. c implicit none integer m integer n double precision a(m,n) integer i integer j do j = 1, n do i = 1, m if ( j .le. i ) then a(i,j) = 1.0D+00 else a(i,j) = 0.0D+00 end if end do end do return end subroutine summation_condition ( n, cond ) c*********************************************************************72 c cc SUMMATION_CONDITION: L1 condition of the SUMMATION matrix. c c Licensing: c c This code is distributed under the GNU LGPL license. c c Modified: c c 10 April 2012 c c Author: c c John Burkardt c c Parameters: c c Input, integer N, the order of the matrix. c c Output, double precision COND, the L1 condition number. c implicit none double precision cond integer n if ( n .eq. 1 ) then cond = 1.0D+00 else cond = dble ( 2 * n ) end if return end subroutine summation_determinant ( n, determ ) c*********************************************************************72 c cc SUMMATION_DETERMINANT returns the determinant of the SUMMATION matrix. c c Licensing: c c This code is distributed under the GNU LGPL license. c c Modified: c c 21 May 2002 c c Author: c c John Burkardt c c Parameters: c c Input, integer N, the order of the matrix. c c Output, double precision DETERM, the determinant. c implicit none double precision determ integer n determ = 1.0D+00 return end subroutine summation_eigenvalues ( n, lambda ) c*********************************************************************72 c cc SUMMATION_EIGENVALUES returns the eigenvalues of the SUMMATION matrix. c c Licensing: c c This code is distributed under the GNU LGPL license. c c Modified: c c 13 October 2007 c c Author: c c John Burkardt c c Parameters: c c Input, integer N, the order of the matrix. c c Output, double precision LAMBDA(N), the eigenvalues. c implicit none integer n integer i double precision lambda(n) do i = 1, n lambda(i) = 1.0D+00 end do return end subroutine summation_inverse ( n, a ) c*********************************************************************72 c cc SUMMATION_INVERSE returns the inverse of the SUMMATION matrix. c c Example: c c N = 5 c c 1 0 0 0 0 c -1 1 0 0 0 c 0 -1 1 0 0 c 0 0 -1 1 0 c 0 0 0 -1 1 c c Properties: c c A is lower triangular. c c A is lower bidiagonal. c c Because A is bidiagonal, it has property A (bipartite). c c A is Toeplitz: constant along diagonals. c c A is nonsingular. c c det ( A ) = 1. c c A is unimodular. c c LAMBDA(1:N) = 1. c c A is persymmetric: A(I,J) = A(N+1-J,N+1-I). c c A is the inverse of the summation matrix. c c Licensing: c c This code is distributed under the GNU LGPL license. c c Modified: c c 15 April 1999 c c Author: c c John Burkardt c c Parameters: c c Input, integer N, the order of the matrix. c c Output, double precision A(N,N), the matrix. c implicit none integer n double precision a(n,n) integer i integer j do j = 1, n do i = 1, n if ( i .eq. j ) then a(i,j) = 1.0D+00 else if ( i .eq. j + 1 ) then a(i,j) = -1.0D+00 else a(i,j) = 0.0D+00 end if end do end do return end subroutine sweet1 ( a ) c*********************************************************************72 c cc SWEET1 returns the SWEET1 matrix. c c Example: c c 20.0 15.0 2.5 6.0 1.0 -2.0 c 15.0 20.0 15.0 2.5 6.0 1.0 c 2.5 15.0 20.0 15.0 2.5 6.0 c 6.0 2.5 15.0 20.0 15.0 2.5 c 1.0 6.0 2.5 15.0 20.0 15.0 c -2.0 1.0 6.0 2.5 15.0 20.0 c c Properties: c c A is symmetric: A' = A. c c Because A is symmetric, it is normal. c c Because A is normal, it is diagonalizable. c c A is Toeplitz: constant along diagonals. c c A is persymmetric: A(I,J) = A(N+1-J,N+1-I). c c Licensing: c c This code is distributed under the GNU LGPL license. c c Modified: c c 20 June 2011 c c Author: c c John Burkardt c c Reference: c c Per Hansen, Tony Chan, c FORTRAN Subroutines for General Toeplitz Systems, c ACM Transactions on Mathematical Software, c Volume 18, Number 3, September 1992, pages 256-273. c c Douglas Sweet, c The use of pivoting to improve the numerical performance of c Toeplitz solvers, c In "Advanced Algorithms and Architectures for Signal Processing", c Edited by J M Speiser, c Proceedings SPIE 696, 1986, pages 8-18. c c Parameters: c c Output, double precision A(6,6), the matrix. c implicit none integer n parameter ( n = 6 ) double precision a(n,n) integer i integer j double precision value(0:5) save value data value / & 20.0D+00, 15.0D+00, 2.5D+00, 6.0D+00, 1.0D+00, -2.0D+00 / do j = 1, n do i = 1, n a(i,j) = value ( abs ( j - i ) ) end do end do return end subroutine sweet1_condition ( cond ) c*********************************************************************72 c cc SWEET1_CONDITION: L1 condition of the SWEET1 matrix. c c Licensing: c c This code is distributed under the GNU LGPL license. c c Modified: c c 09 February 2014 c c Author: c c John Burkardt c c Parameters: c c Output, double precision COND, the L1 condition number. c implicit none double precision a_norm double precision b_norm double precision cond a_norm = 61.0D+00 b_norm = 0.278145899201815D+00 cond = a_norm * b_norm return end subroutine sweet1_determinant ( determ ) c*********************************************************************72 c cc SWEET1_DETERMINANT returns the determinant of the SWEET1 matrix. c c Licensing: c c This code is distributed under the GNU LGPL license. c c Modified: c c 29 January 2015 c c Author: c c John Burkardt c c Parameters: c c Output, double precision DETERM, the determinant. c implicit none double precision determ determ = - 2.0468186D+07 return end subroutine sweet1_inverse ( a ) c*********************************************************************72 c cc SWEET1_INVERSE returns the inverse of the SWEET1 matrix. c c Licensing: c c This code is distributed under the GNU LGPL license. c c Modified: c c 09 February 2015 c c Author: c c John Burkardt c c Parameters: c c Output, double precision A(6,6), the matrix. c implicit none integer n parameter ( n = 6 ) double precision a(n,n) double precision a_save(n,n) integer i integer j save a_save c c Note that the matrix entries are listed by column. c data a_save / & 0.073125159943338D+00, -0.029629732454063D+00, & -0.020045010339460D+00, 0.032364910109767D+00, & -0.056244145182187D+00, 0.052945000841794D+00, & -0.029629732454063D+00, 0.046796984109877D+00, & 0.019214941666057D+00, -0.056592264698005D+00, & 0.069667831091627D+00, -0.056244145182187D+00, & -0.020045010339460D+00, 0.019214941666057D+00, & 0.009031577102143D+00, 0.035236537326757D+00, & -0.056592264698005D+00, 0.032364910109767D+00, & 0.032364910109767D+00, -0.056592264698005D+00, & 0.035236537326757D+00, 0.009031577102143D+00, & 0.019214941666057D+00, -0.020045010339460D+00, & -0.056244145182187D+00, 0.069667831091627D+00, & -0.056592264698005D+00, 0.019214941666057D+00, & 0.046796984109877D+00, -0.029629732454063D+00, & 0.052945000841794D+00, -0.056244145182187D+00, & 0.032364910109767D+00, -0.020045010339460D+00, & -0.029629732454063D+00, 0.073125159943338D+00 / call r8mat_copy ( n, n, a_save, a ) return end subroutine sweet2 ( a ) c*********************************************************************72 c cc SWEET2 returns the SWEET2 matrix. c c Example: c c 4.0 8.0 1.0 6.0 2.0 3.0 c 6.0 4.0 8.0 1.0 6.0 2.0 c A 6.0 4.0 8.0 1.0 6.0 c 5.0 A 6.0 4.0 8.0 1.0 c 3.0 5.0 A 6.0 4.0 8.0 c 1.0 3.0 5.0 A 6.0 4.0 c c Properties: c c A is Toeplitz: constant along diagonals. c c A is generally not symmetric: A' /= A. c c Licensing: c c This code is distributed under the GNU LGPL license. c c Modified: c c 20 June 2011 c c Author: c c John Burkardt c c Reference: c c Per Hansen, Tony Chan, c FORTRAN Subroutines for General Toeplitz Systems, c ACM Transactions on Mathematical Software, c Volume 18, Number 3, September 1992, pages 256-273. c c Douglas Sweet, c The use of pivoting to improve the numerical performance of c Toeplitz solvers, c In "Advanced Algorithms and Architectures for Signal Processing", c Edited by J M Speiser, c Proceedings SPIE 696, 1986, pages 8-18. c c Parameters: c c Output, double precision A(6,6), the matrix. c implicit none integer n parameter ( n = 6 ) double precision a(n,n) integer i integer j double precision value(-5:5) save value data value / & 1.0D+00, 3.0D+00, 5.0D+00, 4.733333333333333D+00, 6.0D+00, & 4.0D+00, & 8.0D+00, 1.0D+00, 6.0D+00, 2.0D+00, 3.0D+00 / do j = 1, n do i = 1, n a(i,j) = value ( j - i ) end do end do return end subroutine sweet2_condition ( cond ) c*********************************************************************72 c cc SWEET2_CONDITION returns the L1 condition of the SWEET2 matrix. c c Licensing: c c This code is distributed under the GNU LGPL license. c c Modified: c c 18 February 2015 c c Author: c c John Burkardt c c Parameters: c c Output, double precision COND, the L1 condition. c implicit none double precision a_norm double precision b_norm double precision cond a_norm = 30.733333333333334D+00 b_norm = 1.601605164968818D+00 cond = a_norm * b_norm return end subroutine sweet2_determinant ( determ ) c*********************************************************************72 c cc SWEET2_DETERMINANT returns the determinant of the SWEET2 matrix. c c Licensing: c c This code is distributed under the GNU LGPL license. c c Modified: c c 29 January 2015 c c Author: c c John Burkardt c c Parameters: c c Output, double precision DETERM, the determinant. c implicit none double precision determ determ = 9.562518834567902D+03 return end subroutine sweet2_inverse ( a ) c*********************************************************************72 c cc SWEET2_INVERSE returns the inverse of the SWEET2 matrix. c c Licensing: c c This code is distributed under the GNU LGPL license. c c Modified: c c 18 February 2015 c c Author: c c John Burkardt c c Parameters: c c Output, double precision A(6,6), the matrix. c implicit none integer n parameter ( n = 6 ) double precision a(n,n) double precision a_save(n,n) save a_save c c Note that the matrix entries are listed by column. c data a_save / & -0.188192659589482D+00, 0.324411348442568D+00, & 0.038585525550130D+00, -0.105091418281329D+00, & -0.043938024069266D+00, -0.054227038968746D+00, & -0.145188896312202D+00, 0.213721529181228D+00, & 0.275974273184732D+00, -0.159756451255461D+00, & -0.157319070822594D+00, -0.043938024069265D+00, & 0.063613055049687D+00, -0.131983821377206D+00, & 0.137312031652403D+00, 0.216482246086901D+00, & -0.159756451255461D+00, -0.105091418281329D+00, & 0.406962974759668D+00, -0.344055452089408D+00, & -0.366985595257679D+00, 0.137312031652403D+00, & 0.275974273184732D+00, 0.038585525550129D+00, & 0.271408731947181D+00, -0.168794206390780D+00, & -0.344055452089408D+00, -0.131983821377206D+00, & 0.213721529181228D+00, 0.324411348442568D+00, & -0.526238847310597D+00, 0.271408731947181D+00, & 0.406962974759669D+00, 0.063613055049687D+00, & -0.145188896312202D+00, -0.188192659589482D+00 / call r8mat_copy ( n, n, a_save, a ) return end subroutine sweet3 ( a ) c*********************************************************************72 c cc SWEET3 returns the SWEET3 matrix. c c Example: c c 8 4 1 6 2 3 c 4 8 4 1 6 2 c -34 4 8 4 1 6 c 5 -34 4 8 4 1 c 3 5 -34 4 8 4 c 1 3 5 -34 4 8 c c Properties: c c A is Toeplitz: constant along diagonals. c c A is generally not symmetric: A' /= A. c c Licensing: c c This code is distributed under the GNU LGPL license. c c Modified: c c 20 June 2011 c c Author: c c John Burkardt c c Reference: c c Per Hansen, Tony Chan, c FORTRAN Subroutines for General Toeplitz Systems, c ACM Transactions on Mathematical Software, c Volume 18, Number 3, September 1992, pages 256-273. c c Douglas Sweet, c The use of pivoting to improve the numerical performance of c Toeplitz solvers, c In "Advanced Algorithms and Architectures for Signal Processing", c Edited by J M Speiser, c Proceedings SPIE 696, 1986, pages 8-18. c c Parameters: c c Output, double precision A(6,6), the matrix. c implicit none integer n parameter ( n = 6 ) double precision a(n,n) integer i integer j double precision value(-5:5) save value data value / & 1.0D+00, 3.0D+00, 5.0D+00, -34.0D+00, 4.0D+00, & 8.0D+00, 4.0D+00, 1.0D+00, 6.0D+00, 2.0D+00, 3.0D+00 / do j = 1, n do i = 1, n a(i,j) = value ( j - i ) end do end do return end subroutine sweet3_condition ( cond ) c*********************************************************************72 c cc SWEET3_CONDITION returns the L1 condition of the SWEET3 matrix. c c Licensing: c c This code is distributed under the GNU LGPL license. c c Modified: c c 23 February 2015 c c Author: c c John Burkardt c c Parameters: c c Output, double precision COND, the L1 condition. c implicit none double precision a_norm double precision b_norm double precision cond a_norm = 58.0D+00 b_norm = 0.427215561206108D+00 cond = a_norm * b_norm return end subroutine sweet3_determinant ( determ ) c*********************************************************************72 c cc SWEET3_DETERMINANT returns the determinant of the SWEET3 matrix. c c Licensing: c c This code is distributed under the GNU LGPL license. c c Modified: c c 29 January 2015 c c Author: c c John Burkardt c c Parameters: c c Output, double precision DETERM, the determinant. c implicit none double precision determ determ = -5.4056067D+07 return end subroutine sweet3_inverse ( a ) c*********************************************************************72 c cc SWEET3_INVERSE returns the inverse of the SWEET3 matrix. c c Licensing: c c This code is distributed under the GNU LGPL license. c c Modified: c c 23 February 2015 c c Author: c c John Burkardt c c Parameters: c c Output, double precision A(6,6), the matrix. c implicit none integer n parameter ( n = 6 ) double precision a(n,n) double precision a_save(n,n) save a_save c c Note that the matrix entries are listed by column. c data a_save / & 0.041073816931594D+00, 0.008091247186000D+00, & 0.006256245020564D+00, 0.038877153234252D+00, & -0.119845197024785D+00, 0.213071901808913D+00, & -0.007888550234334D+00, 0.017910145035154D+00, & 0.027534337635034D+00, -0.002789344626201D+00, & 0.170102571465290D+00, -0.119845197024785D+00, & -0.020859268211281D+00, 0.000156985153951D+00, & 0.003121055773444D+00, 0.008678729808441D+00, & -0.002789344626201D+00, 0.038877153234252D+00, & 0.000304369165444D+00, -0.024742218112169D+00, & 0.003970174152700D+00, 0.003121055773444D+00, & 0.027534337635034D+00, 0.006256245020564D+00, & -0.003979664299291D+00, -0.001114102511380D+00, & -0.024742218112169D+00, 0.000156985153951D+00, & 0.017910145035154D+00, 0.008091247186000D+00, & 0.004165693371662D+00, -0.003979664299291D+00, & 0.000304369165444D+00, -0.020859268211281D+00, & -0.007888550234334D+00, 0.041073816931594D+00 / call r8mat_copy ( n, n, a_save, a ) return end subroutine sweet4 ( a ) c*********************************************************************72 c cc SWEET4 returns the SWEET4 matrix. c c Example: c c 5.0 -1.0 6.0 2.0 5.6 5.8 3.0 -5.0 -2.0 -7.0 1.0 10.0 -15.0 c 1.0 5.0 -1.0 6.0 2.0 5.6 5.8 3.0 -5.0 -2.0 -7.0 1.0 10.0 c -3.0 1.0 5.0 -1.0 6.0 2.0 5.6 5.8 3.0 -5.0 -2.0 -7.0 1.0 c 12.7 -3.0 1.0 5.0 -1.0 6.0 2.0 5.6 5.8 3.0 -5.0 -2.0 -7.0 c -19.6 12.7 -3.0 1.0 5.0 -1.0 6.0 2.0 5.6 5.8 3.0 -5.0 -2.0 c 28.3 -19.6 12.7 -3.0 1.0 5.0 -1.0 6.0 2.0 5.6 5.8 3.0 -5.0 c -7.0 28.3 -19.6 12.7 -3.0 1.0 5.0 -1.0 6.0 2.0 5.6 5.8 3.0 c -1.0 -7.0 28.3 -19.6 12.7 -3.0 1.0 5.0 -1.0 6.0 2.0 5.6 5.8 c 2.0 -1.0 -7.0 28.3 -19.6 12.7 -3.0 1.0 5.0 -1.0 6.0 2.0 5.6 c 1.0 2.0 -1.0 -7.0 28.3 -19.6 12.7 -3.0 1.0 5.0 -1.0 6.0 2.0 c -6.0 1.0 2.0 -1.0 -7.0 28.3 -19.6 12.7 -3.0 1.0 5.0 -1.0 6.0 c 1.0 -6.0 1.0 2.0 -1.0 -7.0 28.3 -19.6 12.7 -3.0 1.0 5.0 -1.0 c -0.5 1.0 -6.0 1.0 2.0 -1.0 -7.0 28.3 -19.6 12.7 -3.0 1.0 5.0 c c Properties: c c A is Toeplitz: constant along diagonals. c c Licensing: c c This code is distributed under the GNU LGPL license. c c Modified: c c 20 June 2011 c c Author: c c John Burkardt c c Reference: c c Per Hansen, Tony Chan, c FORTRAN Subroutines for General Toeplitz Systems, c ACM Transactions on Mathematical Software, c Volume 18, Number 3, September 1992, pages 256-273. c c Douglas Sweet, c The use of pivoting to improve the numerical performance of c Toeplitz solvers, c In "Advanced Algorithms and Architectures for Signal Processing", c Edited by J M Speiser, c Proceedings SPIE 696, 1986, pages 8-18. c c Parameters: c c Output, double precision A(13,13), the matrix. c implicit none integer n parameter ( n = 13 ) double precision a(n,n) integer i integer j double precision perturb double precision value(-12:12) save value data value / & -0.5D+00, 1.0D+00, -6.0D+00, 1.0D+00, 2.0D+00, & -1.0D+00, -7.0D+00, 28.361D+00, -19.656D+00, 12.755D+00, & -3.0D+00, 1.0D+00, 5.0D+00, -1.0D+00, 6.0D+00, & 2.0D+00, 5.697D+00, 5.850D+00, 3.0D+00, -5.0D+00, & -2.0D+00, -7.0D+00, 1.0D+00, 10.0D+00, -15.0D+00 / do j = 1, n do i = 1, n a(i,j) = value ( j - i ) end do end do return end subroutine sweet4_condition ( cond ) c*********************************************************************72 c cc SWEET4_CONDITION returns the L1 condition of the SWEET4 matrix. c c Licensing: c c This code is distributed under the GNU LGPL license. c c Modified: c c 26 February 2015 c c Author: c c John Burkardt c c Parameters: c c Output, double precision COND, the L1 condition. c implicit none double precision a_norm double precision b_norm double precision cond a_norm = 100.3190000000000D+00 b_norm = 0.510081684645161D+00 cond = a_norm * b_norm return end subroutine sweet4_determinant ( determ ) c*********************************************************************72 c cc SWEET4_DETERMINANT returns the determinant of the SWEET4 matrix. c c Licensing: c c This code is distributed under the GNU LGPL license. c c Modified: c c 29 January 2015 c c Author: c c John Burkardt c c Parameters: c c Output, double precision DETERM, the determinant. c implicit none double precision determ determ = -6.463481763930611D+16 return end subroutine sweet4_inverse ( a ) c*********************************************************************72 c cc SWEET4_INVERSE returns the inverse of the SWEET4 matrix. c c Licensing: c c This code is distributed under the GNU LGPL license. c c Modified: c c 26 February 2015 c c Author: c c John Burkardt c c Parameters: c c Output, double precision A(13,13), the matrix. c implicit none integer n parameter ( n = 13 ) double precision a(n,n) double precision a_save(n,n) save a_save c c Note that the matrix entries are listed by column. c & data a_save / & -0.006395453515049D+00, 0.004338135763774D+00, & 0.011852844358462D+00, 0.013846756886370D+00, & 0.009447720973799D+00, 0.009432787993907D+00, & 0.006050784346575D+00, -0.001688517566864D+00, & -0.024098383394697D+00, -0.014571843537603D+00, & 0.006620954487991D+00, 0.017905883190490D+00, & -0.031068329896258D+00, & 0.030690839549686D+00, 0.039852868508471D+00, & 0.033292080046396D+00, 0.028058421670586D+00, & 0.021796805754657D+00, 0.039704365747118D+00, & 0.020779138484695D+00, -0.071337491505107D+00, & -0.082853404494777D+00, 0.050761162107706D+00, & -0.004862149070269D+00, -0.068187074515203D+00, & 0.017905883190490D+00, & -0.002288997065175D+00, -0.006409462970417D+00, & -0.005374341111703D+00, -0.009388803334490D+00, & 0.000727759422194D+00, -0.018354056201609D+00, & 0.018595613535238D+00, 0.069446707802933D+00, & 0.033466389466084D+00, -0.090910979018549D+00, & 0.029222791279654D+00, -0.004862149070269D+00, & 0.006620954487991D+00, & -0.008539260151857D+00, -0.010789166315387D+00, & -0.008875487063420D+00, -0.004500416153857D+00, & -0.008130365160809D+00, -0.002772215599655D+00, & -0.018881036665831D+00, 0.034560078451674D+00, & 0.079212314240954D+00, 0.012959017667649D+00, & -0.090910979018549D+00, 0.050761162107706D+00, & -0.014571843537603D+00, & -0.001015137652004D+00, 0.023605183638394D+00, & 0.031350558988152D+00, 0.032089285374445D+00, & 0.021992767390463D+00, 0.028789202755591D+00, & 0.017128957468121D+00, -0.059246627902032D+00, & -0.061573703805162D+00, 0.079212314240954D+00, & 0.033466389466084D+00, -0.082853404494777D+00, & -0.024098383394697D+00, & 0.040513470913244D+00, 0.023524498024753D+00, & 0.015098401236510D+00, 0.007746385727172D+00, & 0.013573971521042D+00, 0.020818744033636D+00, & 0.021782629702447D+00, -0.038486648845696D+00, & -0.059246627902032D+00, 0.034560078451674D+00, & 0.069446707802933D+00, -0.071337491505107D+00, & -0.001688517566864D+00, & 0.017598472282428D+00, 0.032221111978773D+00, & -0.004426214105193D+00, -0.018511813509106D+00, & -0.015354921685074D+00, -0.008277808905384D+00, & 0.006363468918819D+00, 0.021782629702447D+00, & 0.017128957468121D+00, -0.018881036665831D+00, & 0.018595613535238D+00, 0.020779138484695D+00, & 0.006050784346575D+00, & -0.008312925397734D+00, 0.010175588114759D+00, & 0.030910853378811D+00, -0.002525445590655D+00, & -0.016609776210723D+00, -0.017802710611741D+00, & -0.008277808905384D+00, 0.020818744033636D+00, & 0.028789202755591D+00, -0.002772215599655D+00, & -0.018354056201609D+00, 0.039704365747118D+00, & 0.009432787993907D+00, & -0.015546543686421D+00, -0.018129776994110D+00, & 0.012927937004693D+00, 0.039475608232317D+00, & 0.004261697864111D+00, -0.016609776210723D+00, & -0.015354921685074D+00, 0.013573971521042D+00, & 0.021992767390463D+00, -0.008130365160809D+00, & 0.000727759422194D+00, 0.021796805754657D+00, & 0.009447720973799D+00, & -0.010969455314610D+00, -0.028500341074603D+00, & -0.023901509668313D+00, 0.011543138436698D+00, & 0.039475608232316D+00, -0.002525445590655D+00, & -0.018511813509106D+00, 0.007746385727172D+00, & 0.032089285374445D+00, -0.004500416153857D+00, & -0.009388803334490D+00, 0.028058421670586D+00, & 0.013846756886370D+00, & -0.017014452081345D+00, -0.029318921760199D+00, & -0.035222171390576D+00, -0.023901509668313D+00, & 0.012927937004693D+00, 0.030910853378811D+00, & -0.004426214105193D+00, 0.015098401236510D+00, & 0.031350558988152D+00, -0.008875487063420D+00, & -0.005374341111703D+00, 0.033292080046396D+00, & 0.011852844358462D+00, & -0.017669033095207D+00, -0.030615698849391D+00, & -0.029318921760199D+00, -0.028500341074603D+00, & -0.018129776994110D+00, 0.010175588114759D+00, & 0.032221111978773D+00, 0.023524498024753D+00, & 0.023605183638394D+00, -0.010789166315387D+00, & -0.006409462970417D+00, 0.039852868508471D+00, & 0.004338135763774D+00, & -0.013805699365025D+00, -0.017669033095207D+00, & -0.017014452081345D+00, -0.010969455314610D+00, & -0.015546543686421D+00, -0.008312925397734D+00, & 0.017598472282428D+00, 0.040513470913244D+00, & -0.001015137652004D+00, -0.008539260151857D+00, & -0.002288997065175D+00, 0.030690839549686D+00, & -0.006395453515049D+00 / call r8mat_copy ( n, n, a_save, a ) return end subroutine sylvester ( n, nx, x, ny, y, a ) c*********************************************************************72 c cc SYLVESTER returns the SYLVESTER matrix. c c Formula: c c For rows 1 through NY, c c A(I,J) = X(NX+I-J) c c For rows NY+1 through NY+NX: c c A(I,J) = Y(I-J) c c Example: c c N = 5, c NX = 3, X = ( 1, 2, 3, 4 ), c NY = 2, Y = ( 5, 6, 7 ) c c 4 3 2 1 0 c 0 4 3 2 1 c 7 6 5 0 0 c 0 7 6 5 0 c 0 0 7 6 5 c c Properties: c c A is generally not symmetric: A' /= A. c c Given two polynomials, P1(X) and P2(X) of orders N1 and N2 respectively, c if P1 has the the roots X1 through XN1, and leading coefficient c A, then the resultant R(P1,P2) is c c R1(P1,P2) = A^N2 * P2(X1) * P2(X2) * ... * P2(XN1). c c The resultant is zero if and only if P1 and P2 have a common root. c c The determinant of the Sylvester matrix is the resultant of the c polynomials whose coefficient vectors are X and Y. Thus, the c polynomials have a common zero if and only if the resultant is zero. c This fact allows the resultant to be calculated without determining c the roots of the polynomial. c c The coefficient vector C(0:N) represents the polynomial c c C(N) * X^N + C(N-1) * X^(N-1) + ... + C(1) * X + C(0). c c Licensing: c c This code is distributed under the GNU LGPL license. c c Modified: c c 20 June 2011 c c Author: c c John Burkardt c c Reference: c c Jacqueline Burm, Paul Fishback, c Period-3 Orbits Via Sylvester's Theorem and Resultants, c Mathematics Magazine, c Volume 74, Number 1, February 2001, pages 47-51. c c Parameters: c c Input, integer N, the order of the matrix. c c Input, integer NX, the dimension of X. c c Input, double precision X(0:NX), the first polynomial coefficient vector. c c Input, integer NY, the dimension of Y. c c Input, double precision Y(0:NY), the second polynomial coefficient vector. c c Output, double precision A(N,N), the matrix. c implicit none integer n integer nx integer ny double precision a(n,n) integer i integer j double precision x(0:nx) double precision y(0:ny) if ( nx + ny .ne. n ) then write ( *, '(a)' ) ' ' write ( *, '(a)' ) 'SYLVESTER - Fatal error!' write ( *, '(a)' ) ' NX + NY = N is required.' write ( *, '(a,i8)' ) ' NX = ', nx write ( *, '(a,i8)' ) ' NY = ', ny write ( *, '(a,i8)' ) ' N = ', n stop 1 end if do j = 1, n do i = 1, n a(i,j) = 0.0D+00 end do end do do i = 1, nx + ny if ( i .le. ny ) then do j = i, i + nx a(i,j) = x(nx+i-j) end do else do j = i - ny, i a(i,j) = y(i-j) end do end if end do return end subroutine sylvester_kac ( n, a ) c*********************************************************************72 c cc SYLVESTER_KAC returns the SYLVESTER_KAC matrix. c c Formula: c c If J = I - 1 c A(I,J) = N + 1 - I c If J = I + 1 c A(I,J) = I c c Example: c c N = 5, c c 0 1 0 0 0 c 4 0 2 0 0 c 0 3 0 3 0 c 0 0 2 0 4 c 0 0 0 1 0 c c Properties: c c A is generally not symmetric: A' /= A. c c A is tridiagonal. c c If N is odd, the eigenvalues are: c -(N-1), -(N-3), ..., -2, 0, 2, ... (N-3), (N-1). c c If N is even, the eigenvalues are: c -(N-1), -(N-3), ..., -1, +1, ..., (N-3), (N-1). c c Licensing: c c This code is distributed under the GNU LGPL license. c c Modified: c c 13 April 2015 c c Author: c c John Burkardt c c Reference: c c Paul Clement, c A class of triple-diagonal matrices for test purposes, c SIAM Review, c Volume 1, 1959, pages 50-52. c c Olga Taussky, John Todd, c Another Look at a Matrix of Mark Kac, c Linear Algebra and its Applications, c Volume 150, 1991, pages 341-360. c c Parameters: c c Input, integer N, the order of the matrix. c c Output, double precision A(N,N), the matrix. c implicit none integer n double precision a(n,n) integer i integer j do j = 1, n do i = 1, n a(i,j) = 0.0D+00 end do end do do i = 1, n - 1 a(i,i+1) = dble ( i ) a(i+1,i) = dble ( n - i ) end do return end subroutine sylvester_kac_determinant ( n, value ) c*********************************************************************72 c cc SYLVESTER_KAC_DETERMINANT: determinant of the SYLVESTER_KAC matrix. c c Licensing: c c This code is distributed under the GNU LGPL license. c c Modified: c c 13 April 2015 c c Author: c c John Burkardt c c Parameters: c c Input, integer N, the order of the matrix. c c Output, double precision VALUE, the determinant. c implicit none integer n integer i double precision value if ( mod ( n, 2 ) .eq. 1 ) then value = 0.0D+00 else value = 1.0D+00 do i = - n + 1, n - 1, 2 value = value * dble ( i ) end do end if return end subroutine sylvester_kac_eigen_right ( n, v ) c*********************************************************************72 c cc SYLVESTER_KAC_EIGEN_RIGHT: right eigenvectors of the SYLVESTER_KAC matrix. c c Licensing: c c This code is distributed under the GNU LGPL license. c c Modified: c c 14 April 2015 c c Author: c c John Burkardt c c Parameters: c c Input, integer N, the order of the matrix. c c Output, double precision V(N,N), the matrix. c implicit none integer n double precision a(n) double precision b(n-1) double precision bot double precision c(n-1) integer i integer j double precision lam double precision r8_mop double precision v(n,n) do i = 1, n - 1 b(i) = dble ( i ) c(i) = dble ( n - i ) end do do j = 1, n lam = dble ( - n - 1 + 2 * j ) a(1) = 1.0D+00 a(2) = - lam do i = 3, n a(i) = - lam * a(i-1) - b(i-2) * c(i-2) * a(i-2) end do bot = 1.0D+00 v(1,j) = 1.0D+00 do i = 2, n bot = bot * b(i-1) v(i,j) = r8_mop ( i - 1 ) * a(i) / bot end do end do return end subroutine sylvester_kac_eigenvalues ( n, lam ) c*********************************************************************72 c cc SYLVESTER_KAC_EIGENVALUES: eigenvalues of the SYLVESTER_KAC matrix. c c Licensing: c c This code is distributed under the GNU LGPL license. c c Modified: c c 13 April 2015 c c Author: c c John Burkardt c c Parameters: c c Input, integer N, the order of the matrix. c c Output, double precision LAM(N), the eigenvalues. c implicit none integer n integer i integer j double precision lam(n) i = 1 do j = - n + 1, n - 1, 2 lam(i) = dble ( j ) i = i + 1 end do return end subroutine sylvester_kac_inverse ( n, a ) c**********************************************************************72 c cc SYLVESTER_KAC_INVERSE returns the inverse of the CLEMENT1 matrix. c c Example: c c N = 6: c c 0 1/5 0 -2/15 0 8/15 c 1 0 0 0 0 0 c 0 0 0 1/3 0 -4/3 c -4/3 0 1/3 0 0 0 c 0 0 0 0 0 1 c 8/15 0 -2/15 0 1/5 0 c c Licensing: c c This code is distributed under the GNU LGPL license. c c Modified: c c 16 April 2015 c c Author: c c John Burkardt c c Parameters: c c Input, integer N, the order of the matrix. c c Output, double precision A(N,N), the matrix. c implicit none integer n double precision a(n,n) integer i integer j double precision p1 double precision p2 if ( mod ( n, 2 ) .eq. 1 ) then write ( *, '(a)' ) ' ' write ( *, '(a)' ) 'SYLVESTER_KAC_INVERSE - Fatal error!' write ( *, '(a)' ) ' The matrix is singular for odd N.' stop 1 end if do j = 1, n do i = 1, n a(i,j) = 0.0D+00 end do end do do i = 1, n if ( mod ( i, 2 ) .eq. 1 ) then do j = i, n - 1, 2 if ( j .eq. i ) then p1 = 1.0D+00 / dble ( n - j ) p2 = 1.0D+00 / dble ( j ) else p1 = - p1 * dble ( j - 1 ) / dble ( n - j ) p2 = - p2 * dble ( n - j + 1 ) / dble ( j ) end if a(i,j+1) = p1 a(j+1,i) = p2 end do end if end do return end subroutine symm_random ( n, d, key, a ) c*********************************************************************72 c cc SYMM_RANDOM returns the SYMM_RANDOM matrix. c c Discussion: c c The user is able to specify the eigenvalues. c c Properties: c c A is symmetric: A' = A. c c The eigenvalues of A will be real. c c Licensing: c c This code is distributed under the GNU LGPL license. c c Modified: c c 11 March 2015 c c Author: c c John Burkardt c c Parameters: c c Input, integer N, the order of the matrix. c c Input, double precision D(N), the desired eigenvalues for the matrix. c c Input, integer KEY, a positive integer that selects the data. c c Output, double precision A(N,N), the matrix. c implicit none integer n double precision a(n,n) double precision d(n) integer i integer j integer k integer key double precision q(n,n) c c Get a random orthogonal matrix Q. c call orth_random ( n, key, q ) c c Set A = Q * Lambda * Q'. c do j = 1, n do i = 1, n a(i,j) = 0.0D+00 do k = 1, n a(i,j) = a(i,j) + q(i,k) * d(k) * q(j,k) end do end do end do return end subroutine symm_random_determinant ( n, d, key, determ ) c*********************************************************************72 c cc SYMM_RANDOM_DETERMINANT returns the determinant of the SYMM_RANDOM matrix. c c Licensing: c c This code is distributed under the GNU LGPL license. c c Modified: c c 11 March 2015 c c Author: c c John Burkardt c c Parameters: c c Input, integer N, the order of the matrix. c c Input, double precision D(N), the desired eigenvalues for the matrix. c c Input, integer KEY, a positive integer that selects the data. c c Output, double precision DETERM, the determinant. c implicit none integer n double precision d(n) double precision determ integer key double precision r8vec_product determ = r8vec_product ( n, d ) return end subroutine symm_random_eigen_left ( n, d, key, v ) c*********************************************************************72 c cc SYMM_RANDOM_EIGEN_LEFT returns left eigenvectors of the SYMM_RANDOM matrix. c c Licensing: c c This code is distributed under the GNU LGPL license. c c Modified: c c 11 March 2015 c c Author: c c John Burkardt c c Parameters: c c Input, integer N, the order of the matrix. c c Input, double precision D(N), the desired eigenvalues for the matrix. c c Input, integer KEY, a positive integer that selects the data. c c Output, double precision V(N,N), the vectors. c implicit none integer n double precision d(n) integer i integer j integer key double precision t double precision v(n,n) call orth_random ( n, key, v ) c c Transpose the matrix. c do i = 1, n do j = 1, i - 1 t = v(i,j) v(i,j) = v(j,i) v(j,i) = t end do end do return end subroutine symm_random_eigen_right ( n, d, key, v ) c*********************************************************************72 c cc SYMM_RANDOM_EIGEN_RIGHT returns right eigenvectors of the SYMM_RANDOM matrix. c c Licensing: c c This code is distributed under the GNU LGPL license. c c Modified: c c 11 March 2015 c c Author: c c John Burkardt c c Parameters: c c Input, integer N, the order of the matrix. c c Input, double precision D(N), the desired eigenvalues for the matrix. c c Input, integer KEY, a positive integer that selects the data. c c Output, double precision V(N,N), the vectors. c implicit none integer n double precision d(n) integer key double precision v(n,n) call orth_random ( n, key, v ) return end subroutine symm_random_eigenvalues ( n, d, key, lambda ) c*********************************************************************72 c cc SYMM_RANDOM_EIGENVALUES returns the eigenvalues of the SYMM_RANDOM matrix. c c Licensing: c c This code is distributed under the GNU LGPL license. c c Modified: c c 11 March 2015 c c Author: c c John Burkardt c c Parameters: c c Input, integer N, the order of the matrix. c c Input, double precision D(N), the desired eigenvalues for the matrix. c c Input, integer KEY, a positive integer that selects the data. c c Output, double precision LAMBDA(N), the eigenvalues. c implicit none integer n double precision d(n) integer i integer key double precision lambda(n) do i = 1, n lambda(i) = d(i) end do return end subroutine symm_random_inverse ( n, d, key, a ) c*********************************************************************72 c cc SYMM_RANDOM_INVERSE returns the inverse of the SYMM_RANDOM matrix. c c Discussion: c c The input value of SEED must be the same as the input value used c when defining the original matrix. c c For the inverse to exist, no entry of X may be zero. c c Licensing: c c This code is distributed under the GNU LGPL license. c c Modified: c c 11 March 2015 c c Author: c c John Burkardt c c Parameters: c c Input, integer N, the order of the matrix. c c Input, double precision D(N), the desired eigenvalues for the matrix. c c Input, integer KEY, a positive integer that selects the data. c c Output, double precision A(N,N), the matrix. c implicit none integer n double precision a(n,n) double precision d(n) integer i integer j integer k integer key double precision q(n,n) c c Get a random orthogonal matrix Q. c call orth_random ( n, key, q ) c c Set A = Q * Lambda * Q'. c do j = 1, n do i = 1, n a(i,j) = 0.0D+00 do k = 1, n a(i,j) = a(i,j) + q(i,k) * ( 1.0D+00 / d(k) ) * q(j,k) end do end do end do 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 GNU LGPL 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 subroutine toeplitz ( n, x, a ) c*********************************************************************72 c cc TOEPLITZ returns a TOEPLITZ matrix. c c Formula: c c A(I,J) = X(N+J-I) c c Example: c c N = 5, X = ( 1, 2, 3, 4, 5, 6, 7, 8, 9 ) c c 5 6 7 8 9 c 4 5 6 7 8 c 3 4 5 6 7 c 2 3 4 5 6 c 1 2 3 4 5 c c Properties: c c A is generally not symmetric: A' /= A. c c A is persymmetric: A(I,J) = A(N+1-J,N+1-I). c c A is Toeplitz: constant along diagonals. c c Licensing: c c This code is distributed under the GNU LGPL license. c c Modified: c c 19 June 2011 c c Author: c c John Burkardt c c Parameters: c c Input, integer N, the order of the matrix. c c Input, double precision X(2*N-1), the diagonals of A, with X(1) being c the A(N,1) entry, X(N) being the main diagonal value of A, c and X(2*N-1) being the A(1,N) entry. c c Output, double precision A(N,N), the matrix. c implicit none integer n double precision a(n,n) integer i integer j double precision x(2*n-1) do i = 1, n do j = 1, n a(i,j) = x(n-i+j) end do end do return end subroutine toeplitz_5diag ( n, d1, d2, d3, d4, d5, a ) c*********************************************************************72 c cc TOEPLITZ_5DIAG returns the TOEPLITZ_5DIAG matrix. c c Discussion: c c The matrix is a pentadiagonal Toeplitz matrix. c c Formula: c c if ( I - J .eq. 2 ) then c A(I,J) = D1 c else if ( I - J .eq. 1 ) then c A(I,J) = D2 c else if ( I - J .eq. 0 ) then c A(I,J) = D3 c else if ( I - J .eq. -1 ) then c A(I,J) = D4 c else if ( I - J .eq. -2 ) then c A(I,J) = D5 c else c A(I,J) = 0.0D+00 c c Example: c c N = 5, D1 = 1, D2 = -10, D3 = 0, D4 = 10, D5 = 1 c c 0 10 1 . . c -10 0 10 1 . c 1 -10 0 10 1 c . 1 -10 0 10 c . . 1 -10 0 c c Properties: c c A is generally not symmetric: A' /= A. c c A is Toeplitz: constant along diagonals. c c A is banded, with bandwidth 5. c c A is persymmetric: A(I,J) = A(N+1-J,N+1-I). c c The special data D1 = 1, D2 = -10, D3 = 0, D4 = 10, D5 = 1 corresponds c to a matrix of Rutishauser. c c The matrix has eigenvalues lying approximately on the complex line c segment 2 * cos ( 2 * t ) + 20 * I * sin ( t ). c c The family of matrices is nested as a function of N. c c Licensing: c c This code is distributed under the GNU LGPL license. c c Modified: c c 19 June 2011 c c Author: c c John Burkardt c c Reference: c c RM Beam, RF Warming, c The asymptotic spectra of banded Toeplitz and quasi-Toeplitz matrices, c SIAM Journal on Scientific and Statistical Computing, c Volume 14, Number 4, 1993, pages 971-1006. c c Heinz Rutishauser, c On test matrices, c Programmation en Mathematiques Numeriques, c Centre National de la Recherche Scientifique, c 1966, pages 349-365. c c Parameters: c c Input, integer N, the order of the matrix. c N should be at least 3. c c Input, double precision D1, D2, D3, D4, D5, values that define the c nonzero diagonals of the matrix. c c Output, double precision A(N,N), the matrix. c implicit none integer n double precision a(n,n) double precision d1 double precision d2 double precision d3 double precision d4 double precision d5 integer i integer j do j = 1, n do i = 1, n if ( i - j .eq. 2 ) then a(i,j) = d1 else if ( i - j .eq. 1 ) then a(i,j) = d2 else if ( i - j .eq. 0 ) then a(i,j) = d3 else if ( i - j .eq. -1 ) then a(i,j) = d4 else if ( i - j .eq. -2 ) then a(i,j) = d5 else a(i,j) = 0.0D+00 end if end do end do return end subroutine toeplitz_5s ( row_num, col_num, alpha, beta, gamma, & n, a ) c*********************************************************************72 c cc TOEPLITZ_5S returns the TOEPLITZ_5S matrix. c c Discussion: c c The matrix is a block matrix, symmetric, c of order N = ROW_NUM * COL_NUM, with 5 constant diagonals. c c Formula: c c if ( J = I ) c A(I,J) = ALPHA c else if ( J = I + 1 or J = I - 1 ) c A(I,J) = BETA c else if ( J = I + COL_NUM or J = I - COL_NUM ) c A(I,J) = GAMMA c else c A(I,J) = 0 c c Example: c c ROW_NUM = 2, COL_NUM = 3, c ALPHA = 6, BETA = 4, GAMMA = 2 c c 6 4 0 | 2 0 0 c 4 6 4 | 0 2 0 c 0 4 6 | 0 0 2 c ------+------ c 2 0 0 | 6 4 0 c 0 2 0 | 4 6 4 c 0 0 2 | 0 4 6 c c Properties: c c A is symmetric: A' = A. c c Because A is symmetric, it is normal. c c Because A is normal, it is diagonalizable. c c A is Toeplitz: constant along diagonals. c c A has just 5 nonzero diagonals. c c A is persymmetric: A(I,J) = A(N+1-J,N+1-I). c c A is "block tridiagonal". c c A has eigenvalues c c LAMBDA(I,J) = ALPHA + 2 * BETA * COS(I*PI/(COL_NUM+1)) c + 2 * GAMMA * COS(J*PI/(ROW_NUM+1)), c I = 1 to COL_NUM, J = 1 to ROW_NUM c c If ALPHA = -4, BETA = GAMMA = 1, the matrix is associated with c approximations to the Laplacian operator on a rectangular c ROW_NUM by COL_NUM grid of equally spaced points. See routine POISSON. c c Licensing: c c This code is distributed under the GNU LGPL license. c c Modified: c c 19 June 2011 c c Author: c c John Burkardt c c Reference: c c Robert Gregory, David Karney, c A Collection of Matrices for Testing Computational Algorithms, c Wiley, 1969, c ISBN: 0882756494, c LC: QA263.68 c c Parameters: c c Input, integer ROW_NUM, the block order of the matrix. c c Input, integer COL_NUM, the order of the subblocks. c c Input, double precision ALPHA, BETA, GAMMA, the scalars. c c Output, integer N, the order of the matrix. c c Output, double precision A(ROW_NUM*COL_NUM,ROW_NUM*COL_NUM), c the matrix. c implicit none integer col_num integer row_num double precision a(row_num*col_num,row_num*col_num) double precision alpha double precision beta double precision gamma integer i integer j integer n n = row_num * col_num do j = 1, n do i = 1, n if ( j .eq. i ) then a(i,j) = alpha else if ( j .eq. i + 1 .or. j .eq. i - 1 ) then a(i,j) = beta else if ( j .eq. i + col_num .or. j .eq. i - col_num ) then a(i,j) = gamma else a(i,j) = 0.0D+00 end if end do end do return end subroutine toeplitz_5s_determinant ( row_num, col_num, alpha, & beta, gamma, lambda ) c*********************************************************************72 c cc TOEPLITZ_5S_DETERMINANT returns the determinant of the TOEPLITZ_5S matrix. c c Licensing: c c This code is distributed under the GNU LGPL license. c c Modified: c c 18 March 2015 c c Author: c c John Burkardt c c Parameters: c c Input, integer ROW_NUM, the block order of A. c c Input, integer COL_NUM, the order of the subblocks of A. c c Input, double precision ALPHA, BETA, GAMMA, the scalars that define A. c c Output, double precision VALUE, the determinant. c implicit none integer col_num integer row_num double precision alpha double precision beta double precision gamma double precision lambda(row_num*col_num) double precision r8vec_product double precision value call toeplitz_5s_eigenvalues ( row_num, col_num, alpha, & beta, gamma, lambda ) value = r8vec_product ( row_num * col_num, lambda ) return end subroutine toeplitz_5s_eigenvalues ( row_num, col_num, alpha, & beta, gamma, lambda ) c*********************************************************************72 c cc TOEPLITZ_5S_EIGENVALUES returns the eigenvalues of the TOEPLITZ_5S matrix. c c Licensing: c c This code is distributed under the GNU LGPL license. c c Modified: c c 19 June 2011 c c Author: c c John Burkardt c c Reference: c c Robert Gregory, David Karney, c A Collection of Matrices for Testing Computational Algorithms, c Wiley, 1969, c ISBN: 0882756494, c LC: QA263.68 c c Parameters: c c Input, integer ROW_NUM, the block order of A. c c Input, integer COL_NUM, the order of the subblocks of A. c c Input, double precision ALPHA, BETA, GAMMA, the scalars that define A. c c Output, double precision LAMBDA(ROW_NUM*COL_NUM), the eigenvalues. c implicit none integer col_num integer row_num double precision alpha double precision angle_i double precision angle_j double precision beta double precision gamma integer i integer j integer k double precision lambda(row_num*col_num) double precision r8_pi parameter ( r8_pi = 3.141592653589793D+00 ) k = 0 do i = 1, col_num angle_i = r8_pi * dble ( i ) / dble ( col_num + 1 ) do j = 1, row_num angle_j = r8_pi * dble ( j ) / dble ( row_num + 1 ) k = k + 1 lambda(k) = alpha & + 2.0D+00 * beta * cos ( angle_i ) & + 2.0D+00 * gamma * cos ( angle_j ) end do end do return end subroutine toeplitz_pds ( m, n, x, y, a ) c*********************************************************************72 c cc TOEPLITZ_PDS returns the TOEPLITZ_PDS matrix. c c Discussion: c c The matrix is a Toeplitz positive definite symmetric matrix. c c Formula: c c A(I,J) = sum ( 1 <= K <= M ) Y(K) * cos ( 2 * PI * X(K) * (I-J) ) c c Example: c c N = 5, M = 5, c X = ( -0.0625, - 0.03125, 0.0, 0.03125, 0.0625 ), c Y = ( 0.2, 0.2, 0.2, 0.2, 0.2) c c 1.000000 0.961866 0.852395 0.685661 0.482843 c 0.961866 1.000000 0.961866 0.852395 0.685661 c 0.852395 0.961866 1.000000 0.961866 0.852395 c 0.685661 0.852395 0.961866 1.000000 0.961866 c 0.482843 0.685661 0.852395 0.961866 1.000000 c c Properties: c c A is symmetric: A' = A. c c Because A is symmetric, it is normal. c c Because A is normal, it is diagonalizable. c c A is Toeplitz: constant along diagonals. c c A is persymmetric: A(I,J) = A(N+1-J,N+1-I). c c A is positive definite or positive semi-definite, depending on c the values of X. c c Licensing: c c This code is distributed under the GNU LGPL license. c c Modified: c c 19 June 2011 c c Author: c c John Burkardt c c Reference: c c George Cybenko, Charles Van Loan, c Computing the minimum eigenvalue of a symmetric positive definite c Toeplitz matrix, c SIAM Journal on Scientific and Statistical Computing, c Volume 7, 1986, pages 123-131. c c Parameters: c c Input, integer M, the number of terms of X and Y. c c Input, integer N, the order of the matrix. c c Input, double precision X(M), used to define the matrix. c c Input, double precision Y(M), a set of positive weights c used to define the matrix. c c Output, double precision A(N,N), the matrix. c implicit none integer m integer n double precision a(n,n) double precision angle integer i integer j integer k double precision r8_pi parameter ( r8_pi = 3.141592653589793D+00 ) double precision x(m) double precision y(m) do j = 1, n do i = 1, n a(i,j) = 0.0D+00 do k = 1, m angle = 2.0D+00 * r8_pi * x(k) * dble ( i - j ) a(i,j) = a(i,j) + y(k) * cos ( angle ) end do end do end do return end subroutine tournament_random ( n, key, a ) c*********************************************************************72 c cc TOURNAMENT_RANDOM returns the TOURNAMENT_RANDOM matrix. c c Example: c c N = 5 c c 0 -1 1 1 -1 c 1 0 1 1 1 c -1 -1 0 1 -1 c -1 -1 -1 0 -1 c 1 -1 1 1 0 c c Properties: c c A is generally not symmetric: A' /= A. c c A is antisymmetric: A' = -A. c c Because A is antisymmetric, it is normal. c c Because A is normal, it is diagonalizable. c c The diagonal of A is zero. c c All the eigenvalues of A are imaginary. c c If N is odd, then A is singular. c c If N is even, then A is nonsingular. c c Licensing: c c This code is distributed under the GNU LGPL license. c c Modified: c c 06 July 2011 c c Author: c c John Burkardt c c Parameters: c c Input, integer N, the order of the matrix. c c Input, integer KEY, a positive integer that selects the data. c c Output, double precision A(N,N), the matrix. c implicit none integer n double precision a(n,n) integer i integer j integer key integer seed seed = key call r8mat_uniform_01 ( n, n, seed, a ) do i = 1, n a(i,i) = 0.0D+00 do j = i + 1, n if ( 0.5D+00 .lt. a(i,j) ) then a(i,j) = + 1.0D+00 else a(i,j) = - 1.0D+00 end if a(j,i) = - a(i,j) end do end do return end subroutine tournament_random_determinant ( n, key, determ ) c*********************************************************************72 c cc TOURNAMENT_RANDOM_DETERMINANT: determinant of the TOURNAMENT_RANDOM matrix. c c Licensing: c c This code is distributed under the GNU LGPL license. c c Modified: c c 06 July 2011 c c Author: c c John Burkardt c c Parameters: c c Input, integer N, the order of the matrix. c c Input, integer KEY, a positive integer that selects the data. c c Output, double precision DETERM, the determinant. c implicit none double precision determ integer key integer n integer seed determ = 0.0D+00 return end subroutine transition_random ( n, key, a ) c*********************************************************************72 c cc TRANSITION_RANDOM returns the TRANSITION_RANDOM matrix. c c Discussion: c c A transition matrix is distinguished by two properties: c c * All matrix entries are nonnegative; c * The sum of the entries in each column is 1. c c Example: c c N = 4 c c 1/10 1 5/10 2/10 2/10 c 2/10 0 2/10 2/10 2/10 c 3/10 0 3/10 2/10 2/10 c 4/10 0 0/10 4/10 4/10 c c Properties: c c A is generally not symmetric: A' /= A. c c A is nonnegative. c c 0 <= A(I,J) <= 1.0D+00 for every I and J. c c The sum of the entries in each column of A is 1. c c Because A has a constant column sum of 1, c it has an eigenvalue of 1, c and it has a left eigenvector of (1,1,1,...,1). c c All the eigenvalues of A have modulus no greater than 1. c c Licensing: c c This code is distributed under the GNU LGPL license. c c Modified: c c 19 June 2011 c c Author: c c John Burkardt c c Parameters: c c Input, integer N, the order of the matrix. c c Input, integer KEY, a positive integer that selects the data. c c Output, double precision A(N,N), the matrix. c implicit none integer n double precision a(n,n) double precision col_sum integer i integer j integer key double precision r8vec_sum integer seed seed = key call r8mat_uniform_01 ( n, n, seed, a ) do j = 1, n col_sum = r8vec_sum ( n, a(1,j) ) do i = 1, n a(i,j) = a(i,j) / col_sum end do end do return end subroutine trench ( alpha, m, n, a ) c*********************************************************************72 c cc TRENCH returns the TRENCH matrix. c c Discussion: c c Using a small value of ALPHA causes every third leading principal c submatrix to be nearly singular. The standard Levinson algorithm c for fast solution of Toeplitz matrices will perform poorly if c the leading principal submatrices are poorly conditioned in this way, c although the full matrix may have a good condition number. c c A is related to the KMS matrix. c c Formula: c c if I .eq. J c A(I,J) = ALPHA c else c A(I,J) = (1/2)^( abs ( I - J ) - 1 ) c c Example: c c ALPHA = 0.01, N = 5 c c 0.01 1 1/2 1/4 1/8 c 1 0.01 1 1/2 1/4 c 1/2 1 0.01 1 1/2 c 1/4 1/2 1 0.01 1 c 1/8 1/4 1/2 1 0.01 c c Properties: c c A is Toeplitz: constant along diagonals. c c A is symmetric: A' = A. c c Because A is symmetric, it is normal. c c Because A is normal, it is diagonalizable. c c A is persymmetric: A(I,J) = A(N+1-J,N+1-I). c c A is centrosymmetric: A(I,J) = A(N+1-I,N+1-J). c c If ALPHA = 0, then every third leading principal submatrix c is exactly singular. c c The family of matrices is nested as a function of N. c c Licensing: c c This code is distributed under the GNU LGPL license. c c Modified: c c 19 June 2011 c c Author: c c John Burkardt c c Reference: c c Per Christian Hansen, Tony Chan, c FORTRAN Subroutines for General Toeplitz Systems, c ACM Transactions on Mathematical Software, c Volume 18, Number 3, September 1992, pages 256-273. c c William Trench, c Numerical solution of the eigenvalue problem for Hermitian c Toeplitz matrices, c SIAM Journal on Matrix Analysis and Applications, c Volume 10, 1989, pages 135-146. c c Parameters: c c Input, double precision ALPHA, the scalar that defines A. For testing c Toeplitz solvers, ALPHA should be a small multiple of the c machine precision. c c Input, integer M, N, the order of the matrix. c c Output, double precision A(M,N), the matrix. c implicit none integer m integer n double precision a(m,n) double precision alpha integer i integer j do j = 1, n do i = 1, m if ( i .eq. j ) then a(i,j) = alpha else a(i,j) = 1.0D+00 / dble ( 2 ** ( abs ( i - j ) - 1 ) ) end if end do end do return end subroutine tri_l1_inverse ( n, a, b ) c*********************************************************************72 c cc TRI_L1_INVERSE inverts a unit lower triangular R8MAT. c c Discussion: c c An R8MAT is an array of R8 values. c c A unit lower triangular matrix is a matrix with only 1's on the main c diagonal, and only 0's above the main diagonal. c c The inverse of a unit lower triangular matrix is also c a unit lower triangular matrix. c c This routine can invert a matrix in place, that is, with no extra c storage. If the matrix is stored in A, then the call c c call r8mat_l1_inverse ( n, a, a ) c c will result in A being overwritten by its inverse. c c Licensing: c c This code is distributed under the GNU LGPL license. c c Modified: c c 19 June 2011 c c Author: c c John Burkardt c c Reference: c c Albert Nijenhuis, Herbert Wilf, c Combinatorial Algorithms, c Academic Press, 1978, second edition, c ISBN 0-12-519260-6. c c Parameters: c c Input, integer N, the order of the matrix. c c Input, double precision A(N,N), the unit lower triangular matrix. c c Output, double precision B(N,N), the inverse matrix. c implicit none integer n double precision a(n,n) double precision b(n,n) double precision dot integer i integer j integer k do j = 1, n do i = 1, n if ( i .lt. j ) then b(i,j) = 0.0D+00 else if ( j .eq. i ) then b(i,j) = 1.0D+00 else dot = 0.0D+00 do k = 1, i - 1 dot = dot + a(i,k) * b(k,j) end do b(i,j) = - dot end if end do end do return end subroutine tri_u_inverse ( n, a, b ) c*********************************************************************72 c cc TRI_U_INVERSE inverts an upper triangular R8MAT. c c Discussion: c c An R8MAT is an array of R8 values. c c An upper triangular matrix is a matrix whose only nonzero entries c occur on or above the diagonal. c c The inverse of an upper triangular matrix is an upper triangular matrix. c c Licensing: c c This code is distributed under the GNU LGPL license. c c Modified: c c 19 June 2011 c c Author: c c Original FORTRAN77 version by Albert Nijenhuis, Herbert Wilf. c This FORTRAN77 version by John Burkardt. c c Reference: c c Albert Nijenhuis, Herbert Wilf, c Combinatorial Algorithms, c Academic Press, 1978, second edition, c ISBN 0-12-519260-6. c c Parameters: c c Input, integer N, the order of the matrix. c c Input, double precision A(N,N), the upper triangular matrix. c c Output, double precision B(N,N), the inverse matrix. c implicit none integer n double precision a(n,n) double precision b(n,n) double precision dot integer i integer j integer k do j = n, 1, -1 do i = n, 1, -1 if ( j .lt. i ) then b(i,j) = 0.0D+00 else if ( i .eq. j ) then b(i,j) = 1.0D+00 / a(i,j) else dot = 0.0D+00 do k = i + 1, j dot = dot + a(i,k) * b(k,j) end do b(i,j) = - dot / a(i,i) end if end do end do return end subroutine tri_upper ( alpha, n, a ) c*********************************************************************72 c cc TRI_UPPER returns the TRI_UPPER matrix. c c Discussion: c c This matrix is known as the Wilkinson upper triangular matrix. c c Formula: c c if ( I = J ) c A(I,J) = 1 c if ( I < J ) c A(I,J) = ALPHA c else c A(I,J) = 0 c c Example: c c ALPHA = 3, N = 5 c c 1 3 3 3 3 c 0 1 3 3 3 c 0 0 1 3 3 c 0 0 0 1 3 c 0 0 0 0 1 c c Properties: c c A is generally not symmetric: A' /= A. c c A is nonsingular. c c A is upper triangular. c c det ( A ) = 1. c c A is unimodular. c c LAMBDA(1:N) = 1. c c A is Toeplitz: constant along diagonals. c c A is persymmetric: A(I,J) = A(N+1-J,N+1-I). c c The family of matrices is nested as a function of N. c c Licensing: c c This code is distributed under the GNU LGPL license. c c Modified: c c 19 June 2011 c c Author: c c John Burkardt c c Parameters: c c Input, double precision ALPHA, value used on the superdiagonals. c c Input, integer N, the order of the matrix. c c Output, double precision A(N,N), the matrix. c implicit none integer n double precision a(n,n) double precision alpha integer i integer j do j = 1, n do i = 1, n if ( i .eq. j ) then a(i,j) = 1.0D+00 else if ( i .lt. j ) then a(i,j) = alpha else a(i,j) = 0.0D+00 end if end do end do return end subroutine tri_upper_condition ( alpha, n, cond ) c*********************************************************************72 c cc TRI_UPPER_CONDITION returns the L1 condition of the TRI_UPPER matrix. c c Licensing: c c This code is distributed under the GNU LGPL license. c c Modified: c c 18 January 2015 c c Author: c c John Burkardt c c Parameters: c c Input, double precision ALPHA, value used on the superdiagonals. c c Input, integer N, the order of the matrix. c c Output, double precision COND, the L1 condition. c implicit none double precision a_norm double precision alpha double precision b_norm double precision cond integer n a_norm = dble ( n - 1 ) * abs ( alpha ) + 1.0D+00 b_norm = 1.0D+00 + abs ( alpha ) & * ( ( abs ( alpha - 1.0D+00 ) ) ** ( n - 1 ) - 1.0D+00 ) & / ( abs ( alpha - 1.0D+00 ) - 1.0D+00 ) cond = a_norm * b_norm return end subroutine tri_upper_determinant ( alpha, n, determ ) c*********************************************************************72 c cc TRI_UPPER_DETERMINANT returns the determinant of the TRI_UPPER matrix. c c Licensing: c c This code is distributed under the GNU LGPL license. c c Modified: c c 19 June 2011 c c Author: c c John Burkardt c c Parameters: c c Input, double precision ALPHA, value used on the superdiagonals. c c Input, integer N, the order of the matrix. c c Output, double precision DETERM, the determinant. c implicit none double precision alpha double precision determ integer n determ = 1.0D+00 return end subroutine tri_upper_eigenvalues ( n, lambda ) c*********************************************************************72 c cc TRI_UPPER_EIGENVALUES returns the eigenvalues of the TRI_UPPER matrix. c c Licensing: c c This code is distributed under the GNU LGPL license. c c Modified: c c 19 June 2011 c c Author: c c John Burkardt c c Parameters: c c Input, integer N, the order of the matrix. c c Output, double precision LAMBDA(N), the eigenvalues. c implicit none integer n integer i double precision lambda(n) do i = 1, n lambda(i) = 1.0D+00 end do return end subroutine tri_upper_inverse ( alpha, n, a ) c*********************************************************************72 c cc TRI_UPPER_INVERSE returns the inverse of the TRI_UPPER matrix. c c Formula: c c if ( I = J ) then c A(I,J) = 1 c else if ( I = J - 1 ) then c A(I,J) = -ALPHA c else if ( I < J ) then c A(I,J) = - ALPHA * ( 1-ALPHA)^(J-I-1) c else c A(I,J) = 0 c c Example: c c ALPHA = 3, N = 5 c c 1 -3 6 -12 24 c 0 1 -3 6 -12 c 0 0 1 -3 6 c 0 0 0 1 -3 c 0 0 0 0 1 c c Properties: c c A is generally not symmetric: A' /= A. c c A is nonsingular. c c A is upper triangular. c c A is Toeplitz: constant along diagonals. c c A is persymmetric: A(I,J) = A(N+1-J,N+1-I). c c det ( A ) = 1. c c A is unimodular. c c LAMBDA(1:N) = 1. c c Licensing: c c This code is distributed under the GNU LGPL license. c c Modified: c c 19 June 2011 c c Author: c c John Burkardt c c Parameters: c c Input, double precision ALPHA, value used on the superdiagonals. c c Input, integer N, the order of the matrix. c c Output, double precision A(N,N), the matrix. c implicit none integer n double precision a(n,n) double precision alpha integer i integer j do j = 1, n do i = 1, n if ( i .eq. j ) then a(i,j) = 1.0D+00 else if ( i .eq. j - 1 ) then a(i,j) = - alpha else if ( i .lt. j ) then a(i,j) = - alpha * ( 1.0D+00 - alpha ) ** ( j - i - 1 ) else a(i,j) = 0.0D+00 end if end do end do return end subroutine tridiagonal_determinant ( n, a, determ ) c*********************************************************************72 c cc TRIDIAGONAL_DETERMINANT computes the determinant of a tridiagonal matrix. c c Licensing: c c This code is distributed under the GNU LGPL license. c c Modified: c c 19 June 2011 c c Author: c c John Burkardt c c Parameters: c c Input, integer N, the order of the matrix. c c Input, double precision A(N,N), the matrix. c c Output, double precision DETERM, the determinant. c implicit none integer n double precision a(n,n) double precision determ double precision determ_nm1 double precision determ_nm2 integer i determ_nm1 = a(n,n) if ( n .eq. 1 ) then determ = determ_nm1 return end if determ_nm2 = determ_nm1 determ_nm1 = a(n-1,n-1) * a(n,n) - a(n-1,n) * a(n,n-1) if ( n .eq. 2 ) then determ = determ_nm1 return end if do i = n - 2, 1, -1 determ = a(i,i) * determ_nm1 - a(i,i+1) * a(i+1,i) * determ_nm2 determ_nm2 = determ_nm1 determ_nm1 = determ end do return end subroutine tris ( m, n, x, y, z, a ) c*********************************************************************72 c cc TRIS returns the TRIS matrix. c c Discussion: c c The matrix is a tridiagonal matrix defined by three scalars. c c See page 155 of the Todd reference. c c Formula: c c if ( J = I-1 ) c A(I,J) = X c else if ( J = I ) c A(I,J) = Y c else if ( J = I + 1 ) c A(I,J) = Z c else c A(I,J) = 0 c c Example: c c M = 5, N = 5, X = 1, Y = 2, Z = 3 c c 2 3 0 0 0 c 1 2 3 0 0 c 0 1 2 3 0 c 0 0 1 2 3 c 0 0 0 1 2 c c Properties: c c A is generally not symmetric: A' /= A. c c A is tridiagonal. c c Because A is tridiagonal, it has property A (bipartite). c c A is banded, with bandwidth 3. c c A is Toeplitz: constant along diagonals. c c If Y is not zero, then for A to be singular, it must be the case that c c 0.5 * Y / sqrt ( X * Z ) < 1 c c and c c cos (K*PI/(N+1)) = - 0.5 * Y / sqrt ( X * Z ) for some 1 <= K <= N. c c If Y is zero, then A is singular when N is odd, or if X or Z is zero. c c A is persymmetric: A(I,J) = A(N+1-J,N+1-I). c c A has eigenvalues c c LAMBDA(I) = Y + 2 * sqrt(X*Z) * COS(I*PI/(N+1)) c c The eigenvalues will be complex if X * Z < 0. c c If X = Z, the matrix is symmetric. c c As long as X and Z are nonzero, the matrix is irreducible. c c If X = Z = -1, and Y = 2, the matrix is a symmetric, positive c definite M matrix, the negative of the second difference matrix. c c The family of matrices is nested as a function of N. c c Licensing: c c This code is distributed under the GNU LGPL license. c c Modified: c c 17 July 2008 c c Author: c c John Burkardt c c Reference: c c John Todd, c Basic Numerical Mathematics, c Volume 2: Numerical Algebra, c Birkhauser, 1980, c ISBN: 0817608117, c LC: QA297.T58. c c Parameters: c c Input, integer M, N, the order of the matrix. c c Input, double precision X, Y, Z, the scalars that define A. c c Output, double precision A(M,N), the matrix. c implicit none integer m integer n double precision a(m,n) integer i integer j double precision x double precision y double precision z do j = 1, n do i = 1, m if ( j .eq. i - 1 ) then a(i,j) = x else if ( j .eq. i ) then a(i,j) = y else if ( j .eq. i + 1 ) then a(i,j) = z else a(i,j) = 0.0D+00 end if end do end do return end subroutine tris_determinant ( n, x, y, z, determ ) c*********************************************************************72 c cc TRIS_DETERMINANT returns the determinant of the TRIS matrix. c c Licensing: c c This code is distributed under the GNU LGPL license. c c Modified: c c 26 July 2008 c c Author: c c John Burkardt c c Parameters: c c Input, integer N, the order of the matrix. c c Input, double precision X, Y, Z, the scalars that define the matrix. c c Output, double precision DETERM, the determinant. c implicit none double precision angle double precision determ integer i integer i_hi integer n double precision r8_pi parameter ( r8_pi = 3.141592653589793D+00 ) double precision x double precision y double precision z determ = 1.0D+00 if ( 0.0D+00 .le. x * z ) then do i = 1, n angle = dble ( i ) * r8_pi / dble ( n + 1 ) determ = determ & * ( y + 2.0D+00 * sqrt ( x * z ) * cos ( angle ) ) end do else i_hi = n / 2 do i = 1, i_hi angle = dble ( i ) * r8_pi / dble ( n + 1 ) determ = determ & * ( y * y - 4.0D+00 * x * z * cos ( angle ) ** 2 ) end do if ( mod ( n, 2 ) .eq. 1 ) then determ = determ * y end if end if return end subroutine tris_eigenvalues ( n, x, y, z, lambda ) c*********************************************************************72 c cc TRIS_EIGENVALUES returns the eigenvalues of the TRIS matrix. c c Discussion: c c The eigenvalues will be complex if X * Z < 0. c c Licensing: c c This code is distributed under the GNU LGPL license. c c Modified: c c 17 July 2008 c c Author: c c John Burkardt c c Parameters: c c Input, integer N, the order of the matrix. c c Input, double precision X, Y, Z, the scalars that define A. c c Output, double complex LAMBDA(N), the eigenvalues. c implicit none integer n double precision angle double complex arg integer i double complex lambda(n) double precision r8_pi parameter ( r8_pi = 3.141592653589793D+00 ) double precision x double precision y double precision z do i = 1, n angle = dble ( i ) * r8_pi / dble ( n + 1 ) arg = cmplx ( x * z, 0.0D+00 ) lambda(i) = y + 2.0D+00 * sqrt ( arg ) * cos ( angle ) end do return end subroutine tris_inverse ( n, alpha, beta, gamma, a ) c*********************************************************************72 c cc TRIS_INVERSE returns the inverse of the TRIS matrix. c c Licensing: c c This code is distributed under the GNU LGPL license. c c Modified: c c 19 June 2011 c c Author: c c John Burkardt c c Reference: c c CM daFonseca, J Petronilho, c Explicit Inverses of Some Tridiagonal Matrices, c Linear Algebra and Its Applications, c Volume 325, 2001, pages 7-21. c c Parameters: c c Input, integer N, the order of the matrix. c c Input, double precision ALPHA, BETA, GAMMA, the constant values c associated with the subdiagonal, diagonal and superdiagonal of c the matrix. c c Output, double precision A(N,N), the inverse of the matrix. c implicit none integer n double precision a(n,n) double precision alpha double precision beta double precision d(n) double precision gamma integer i integer j double precision r8_mop double precision r8vec_product d(n) = beta do i = n - 1, 1, -1 d(i) = beta - alpha * gamma / d(i+1) end do do i = 1, n do j = 1, i a(i,j) = r8_mop ( i + j ) * alpha ** ( i - j ) & * r8vec_product ( n - i, d(i+1) ) & / r8vec_product ( n - j + 1, d ) end do do j = i + 1, n a(i,j) = r8_mop ( i + j ) * gamma ** ( j - i ) & * r8vec_product ( n - j, d(j+1) ) & / r8vec_product ( n - i + 1, d ) end do end do return end subroutine triv ( n, x, y, z, a ) c*********************************************************************72 c cc TRIV returns the TRIV matrix. c c Discussion: c c The three vectors define the subdiagonal, main diagonal, and c superdiagonal. c c Formula: c c if ( J = I - 1 ) c A(I,J) = X(J) c else if ( J = I ) c A(I,J) = Y(I) c else if ( J = I + 1 ) c A(I,J) = Z(I) c else c A(I,J) = 0 c c Example: c c N = 5, X = ( 1, 2, 3, 4 ), Y = ( 5, 6, 7, 8, 9 ), Z = ( 10, 11, 12, 13 ) c c 5 10 0 0 0 c 1 6 11 0 0 c 0 2 7 12 0 c 0 0 3 8 13 c 0 0 0 4 9 c c Properties: c c A is tridiagonal. c c A is banded, with bandwidth 3. c c A is generally not symmetric: A' /= A. c c The family of matrices is nested as a function of N. c c Licensing: c c This code is distributed under the GNU LGPL license. c c Modified: c c 19 June 2011 c c Author: c c John Burkardt c c Parameters: c c Input, integer N, the order of the matrix. c c Input, double precision X(N-1), Y(N), Z(N-1), the vectors that define c the subdiagonal, diagonal, and superdiagonal of A. c c Output, double precision A(N,N), the matrix. c implicit none integer n double precision a(n,n) integer i integer j double precision x(n-1) double precision y(n) double precision z(n-1) do j = 1, n do i = 1, n if ( j .eq. i - 1 ) then a(i,j) = x(j) else if ( j .eq. i ) then a(i,j) = y(i) else if ( j .eq. i + 1 ) then a(i,j) = z(i) else a(i,j) = 0.0D+00 end if end do end do return end subroutine triv_determinant ( n, x, y, z, determ ) c*********************************************************************72 c cc TRIV_DETERMINANT computes the determinant of the TRIV matrix. c c Licensing: c c This code is distributed under the GNU LGPL license. c c Modified: c c 19 June 2011 c c Author: c c John Burkardt c c Parameters: c c Input, integer N, the order of the matrix. c c Input, double precision X(N-1), Y(N), Z(N-1), the vectors that define c the subdiagonal, diagonal, and superdiagonal of A. c c Output, double precision DETERM, the determinant. c implicit none integer n double precision determ double precision determ_nm1 double precision determ_nm2 integer i double precision x(n-1) double precision y(n) double precision z(n-1) determ_nm1 = y(n) if ( n .eq. 1 ) then determ = determ_nm1 return end if determ_nm2 = determ_nm1 determ_nm1 = y(n-1) * y(n) - z(n-1) * x(n-1) if ( n .eq. 2 ) then determ = determ_nm1 return end if do i = n - 2, 1, -1 determ = y(i) * determ_nm1 - z(i) * x(i) * determ_nm2 determ_nm2 = determ_nm1 determ_nm1 = determ end do return end subroutine triv_inverse ( n, x, y, z, a ) c*********************************************************************72 c cc TRIV_INVERSE returns the inverse of the TRIV matrix. c c Licensing: c c This code is distributed under the GNU LGPL license. c c Modified: c c 19 June 2011 c c Author: c c John Burkardt c c Reference: c c CM daFonseca, J Petronilho, c Explicit Inverses of Some Tridiagonal Matrices, c Linear Algebra and Its Applications, c Volume 325, 2001, pages 7-21. c c Parameters: c c Input, integer N, the order of the matrix. c c Input, double precision X(N-1), Y(N), Z(N-1), the vectors that define c the subdiagonal, diagonal, and superdiagonal of A. c No entry of Y can be zero. c c Output, double precision A(N,N), the inverse of the matrix. c implicit none integer n double precision a(n,n) double precision d(n) double precision e(n) integer i integer j double precision r8_mop double precision r8vec_product double precision x(n-1) double precision y(n) double precision z(n-1) do i = 1, n if ( y(i) .eq. 0.0D+00 ) then write ( *, '(a)' ) '' write ( *, '(a)' ) 'TRIV_INVERSE - Fatal error!' write ( *, '(a)' ) ' No entry of Y can be zero!' stop 1 end if end do d(n) = y(n) do i = n - 1, 1, -1 d(i) = y(i) - x(i) * z(i) / d(i+1) end do e(1) = y(1) do i = 2, n e(i) = y(i) - x(i-1) * z(i-1) / e(i-1) end do do i = 1, n do j = 1, i a(i,j) = r8_mop ( i + j ) & * r8vec_product ( i - j, x(j) ) & * r8vec_product ( n - i, d(i+1) ) & / r8vec_product ( n - j + 1, e(j) ) end do do j = i + 1, n a(i,j) = r8_mop ( i + j ) & * r8vec_product ( j - i, z(i) ) & * r8vec_product ( n - j, d(j+1) ) & / r8vec_product ( n - i + 1, e(i) ) end do end do return end subroutine triw ( alpha, k, n, a ) c*********************************************************************72 c cc TRIW returns the TRIW matrix. c c Discussion: c c The matrix is the Wilkinson banded upper triangular matrix. c c Formula: c c if ( I = J ) c A(I,J) = 1 c else if ( I < J and J <= K + I ) c A(I,J) = ALPHA c else c A(I,J) = 0 c c Example: c c ALPHA = 3, K = 2, N = 5 c c 1 3 3 0 0 c 0 1 3 3 0 c 0 0 1 3 3 c 0 0 0 1 3 c 0 0 0 0 1 c c Properties: c c A is generally not symmetric: A' /= A. c c A is nonsingular. c c A is upper triangular. c c det ( A ) = 1. c c A is unimodular. c c LAMBDA(1:N) = 1. c c A is Toeplitz: constant along diagonals. c c A is persymmetric: A(I,J) = A(N+1-J,N+1-I). c c Adding -2^(2-N) to the (N,1) element makes the matrix singular. c c The family of matrices is nested as a function of N. c c Licensing: c c This code is distributed under the GNU LGPL license. c c Modified: c c 19 June 2011 c c Author: c c John Burkardt c c Reference: c c Gene Golub, James Wilkinson, c Ill-conditioned eigensystems and the computation of the Jordan c canonical form, c SIAM Review, c Volume 18, Number 4, 1976, pages 578-619. c c W Kahan, c Numerical linear algebra, c Canadian Mathematical Bulletin, c Volume 9, 1966, pages 757-801. c c AM Ostrowski, c On the spectrum of a one-parametric family of matrices, c Journal fuer Reine und Angewandte Mathematik, c Volume 193, Number (3/4), 1954, pages 143-160. c c James Wilkinson, c Singular-value decomposition - basic aspects, c in Numerical Software - Needs and Availability, c edited by DAH Jacobs, c Academic Press, London, 1978, pages 109-135. c c Parameters: c c Input, double precision ALPHA, the superdiagonal value. c A typical value is -1. c c Input, integer K, the number of nonzero superdiagonals. c A typical value is N-1. c c Input, integer N, the order of the matrix. c c Output, double precision A(N,N), the matrix. c implicit none integer n double precision a(n,n) double precision alpha integer i integer j integer k do j = 1, n do i = 1, n if ( i .eq. j ) then a(i,j) = 1.0D+00 else if ( i .lt. j .and. j - i .le. k ) then a(i,j) = alpha else a(i,j) = 0.0D+00 end if end do end do return end subroutine triw_determinant ( alpha, k, n, determ ) c*********************************************************************72 c cc TRIW_DETERMINANT returns the determinant of the TRIW matrix. c c Licensing: c c This code is distributed under the GNU LGPL license. c c Modified: c c 08 October 2007 c c Author: c c John Burkardt c c Parameters: c c Input, double precision ALPHA, the superdiagonal value. c A typical value is -1. c c Input, integer K, the number of nonzero superdiagonals. c A typical value is N-1. c c Input, integer N, the order of the matrix. c c Output, double precision DETERM, the determinant. c implicit none double precision alpha double precision determ integer k integer n determ = 1.0D+00 return end subroutine triw_eigenvalues ( n, lambda ) c*********************************************************************72 c cc TRIW_EIGENVALUES returns the eigenvalues of the TRIW matrix. c c Licensing: c c This code is distributed under the GNU LGPL license. c c Modified: c c 19 June 2011 c c Author: c c John Burkardt c c Parameters: c c Input, integer N, the order of the matrix. c c Output, double precision LAMBDA(N), the eigenvalues. c implicit none integer n integer i double precision lambda(n) do i = 1, n lambda(i) = 1.0D+00 end do return end subroutine triw_inverse ( alpha, k, n, a ) c*********************************************************************72 c cc TRIW_INVERSE sets the inverse of the TRIW matrix. c c Example: c c ALPHA = 3, K = 2, N = 5 c c 1 -3 6 -9 9 c 0 1 -3 6 -9 c 0 0 1 -3 6 c 0 0 0 1 -3 c 0 0 0 0 1 c c Properties: c c A is nonsingular. c c A is upper triangular. c c A is Toeplitz: constant along diagonals. c c A is persymmetric: A(I,J) = A(N+1-J,N+1-I). c c det ( A ) = 1. c c A is unimodular. c c LAMBDA(1:N) = 1. c c Licensing: c c This code is distributed under the GNU LGPL license. c c Modified: c c 19 June 2011 c c Author: c c John Burkardt c c Parameters: c c Input, double precision ALPHA, value used on the superdiagonals. c c Input, integer K, the number of nonzero superdiagonals. c c Input, integer N, the order of the matrix. c c Output, double precision A(N,N), the matrix. c implicit none integer n double precision a(n,n) double precision alpha integer i integer j integer k integer kk integer klo double precision prod do j = 1, n do i = 1, n a(i,j) = 0.0D+00 end do end do do i = 1, n a(i,i) = 1.0D+00 end do c c Compute the product of row 1 of the inverse with columns 2, c 3,..., N of the original matrix, up to, but not including, c the next unknown entry of the inverse. That unknown entry c is multiplied by 1, and the resulting sum must be zero. c So the unknown entry equals minus the sum of all the c other products. And all the entries along its superdiagonal c have the same value. c do j = 2, n prod = 0.0D+00 klo = max ( 1, j-k ) do kk = klo, j - 1 prod = prod + a(1,kk) * alpha end do do i = 1, n - j + 1 a(i,i+j-1) = - prod end do end do return end subroutine unitary_random ( n, key, a ) c*********************************************************************72 c cc UNITARY_RANDOM returns the UNITARY_RANDOM matrix. c c Properties: c c The inverse of A is equal to A^H. c c A is unitary: A * A^H = A^H * A = I. c c Because A is unitary, it is normal: A^H * A = A * A^H. c c Columns and rows of A have unit Euclidean norm. c c Distinct pairs of columns of A are complex orthogonal. c c Distinct pairs of rows of A are complex orthogonal. c c The L2 vector norm of A*x = the L2 vector norm of x for any vector x. c c The L2 matrix norm of A*B = the L2 matrix norm of B for any matrix B. c c det ( A ) = +1 or -1. c c A is unimodular. c c All the eigenvalues of A have modulus 1. c c All singular values of A are 1. c c Every entry of A is no greater than 1 in complex absolute value. c c Licensing: c c This code is distributed under the GNU LGPL license. c c Modified: c c 19 June 2011 c c Author: c c John Burkardt c c Reference: c c Pete Stewart, c Efficient Generation of Random Orthogonal Matrices With an Application c to Condition Estimators, c SIAM Journal on Numerical Analysis, c Volume 17, Number 3, June 1980, pages 403-409. c c Parameters: c c Input, integer N, the order of the matrix. c c Input, integer KEY, a positive integer that selects the data. c c Output, double complex A(N,N), the matrix. c implicit none integer n double complex a(n,n) integer i integer j integer key integer seed double complex v(n) double complex x(n) double complex c8_normal_01 c c Start with A = the identity matrix. c do j = 1, n do i = 1, n if ( i .eq. j ) then a(i,j) = dcmplx ( 1.0D+00, 0.0D+00 ) else a(i,j) = dcmplx ( 0.0D+00, 0.0D+00 ) end if end do end do c c Now behave as though we were computing the QR factorization of c some other random matrix. Generate the N elements of the first column, c compute the Householder matrix H1 that annihilates the subdiagonal elements, c and set A := A * conjg ( H1 ) = A * H. c c On the second step, generate the lower N-1 elements of the second column, c compute the Householder matrix H2 that annihilates them, c and set A := A * conjg ( H2 ) = A * H2 = H1 * H2. c c On the N-1 step, generate the lower 2 elements of column N-1, c compute the Householder matrix HN-1 that annihilates them, and c and set A := A * conjg ( H(N-1) ) = A * H(N-1) = H1 * H2 * ... * H(N-1). c This is our random unitary matrix. c seed = key do j = 1, n - 1 c c Set the vector that represents the J-th column to be annihilated. c do i = 1, j - 1 x(i) = dcmplx ( 0.0D+00, 0.0D+00 ) end do do i = j, n x(i) = c8_normal_01 ( seed ) end do c c Compute the vector V that defines a Householder transformation matrix c H(V) that annihilates the subdiagonal elements of X. c call c8vec_house_column ( n, x, j, v ) c c Postmultiply the matrix A by conjg ( H(V) ) = H(V). c call c8mat_house_axh ( n, a, v, a ) end do return end subroutine unitary_random_determinant ( n, key, determ ) c*********************************************************************72 c cc UNITARY_RANDOM_DETERMINANT: determinant of a UNITARY_RANDOM matrix. c c Licensing: c c This code is distributed under the GNU LGPL license. c c Modified: c c 09 February 2015 c c Author: c c John Burkardt c c Parameters: c c Input, integer N, the order of the matrix. c c Input, integer KEY, a positive integer that selects the data. c c Output, double complex DETERM, the determinant. c implicit none integer n double complex determ integer key determ = dcmplx ( 1.0D+00, 0.0D+00 ) return end subroutine unitary_random_inverse ( n, key, a ) c*********************************************************************72 c cc UNITARY_RANDOM_INVERSE returns the inverse of the UNITARY_RANDOM matrix. c c Licensing: c c This code is distributed under the GNU LGPL license. c c Modified: c c 09 February 2015 c c Author: c c John Burkardt c c Parameters: c c Input, integer N, the order of the matrix. c c Input, integer KEY, a positive integer that selects the data. c c Output, double complex A(N,N), the matrix. c implicit none integer n double complex a(n,n) integer i integer j integer key double complex t call unitary_random ( n, key, a ) do i = 1, n do j = 1, i - 1 t = conjg ( a(i,j) ) a(i,j) = conjg ( a(j,i) ) a(j,i) = t end do end do return end subroutine upshift ( n, a ) c*********************************************************************72 c cc UPSHIFT returns the UPSHIFT matrix. c c Formula: c c if ( J-I .eq. 1 mod ( n ) ) c A(I,J) = 1 c else c A(I,J) = 0 c c Example: c c N = 4 c c 0 1 0 0 c 0 0 1 0 c 0 0 0 1 c 1 0 0 0 c c Properties: c c A is integral, therefore det ( A ) is integral, and c det ( A ) * inverse ( A ) is integral. c c A is a zero/one matrix. c c A is generally not symmetric: A' .ne. A. c c A is nonsingular. c c A is a permutation matrix. c c If N is even, det ( A ) = -1. c If N is odd, det ( A ) = +1. c c A is unimodular. c c A is persymmetric: A(I,J) = A(N+1-J,N+1-I). c c A is a Hankel matrix: constant along anti-diagonals. c c A is an N-th root of the identity matrix. c c The inverse of A is the downshift matrix. c c A is a circulant matrix: each row is shifted once to get the next row. c c A circulant matrix C, whose first row is (c1, c2, ..., cn), can be c written as a polynomial in A: c c C = c1 * I + c2 * A + c3 * A^2 + ... + cn * A^n-1. c c Licensing: c c This code is distributed under the GNU LGPL license. c c Modified: c c 19 June 2011 c c Author: c c John Burkardt c c Parameters: c c Input, integer N, the order of the matrix. c c Output, double precision A(N,N), the matrix. c implicit none integer n double precision a(n,n) integer i integer j integer i4_modp do j = 1, n do i = 1, n if ( i4_modp ( j - i, n ) .eq. 1 ) then a(i,j) = 1.0D+00 else a(i,j) = 0.0D+00 end if end do end do return end subroutine upshift_condition ( n, cond ) c*********************************************************************72 c cc UPSHIFT_CONDITION returns the L1 condition of the UPSHIFT matrix. c c Licensing: c c This code is distributed under the GNU LGPL license. c c Modified: c c 08 February 2015 c c Author: c c John Burkardt c c Parameters: c c Input, integer N, the order of the matrix. c c Output, double precision COND, the L1 condition. c implicit none double precision a_norm double precision b_norm double precision cond integer n a_norm = 1.0D+00 b_norm = 1.0D+00 cond = a_norm * b_norm return end subroutine upshift_determinant ( n, determ ) c*********************************************************************72 c cc UPSHIFT_DETERMINANT returns the determinant of the UPSHIFT matrix. c c Licensing: c c This code is distributed under the GNU LGPL license. c c Modified: c c 07 October 2007 c c Author: c c John Burkardt c c Parameters: c c Input, integer N, the order of the matrix. c c Output, double precision DETERM, the determinant. c implicit none double precision determ integer n if ( mod ( n, 2 ) .eq. 0 ) then determ = -1.0D+00 else determ = +1.0D+00 end if return end subroutine upshift_eigenvalues ( n, lambda ) c*********************************************************************72 c cc UPSHIFT_EIGENVALUES returns the eigenvalues of the UPSHIFT matrix. c c Licensing: c c This code is distributed under the GNU LGPL license. c c Modified: c c 19 October 2007 c c Author: c c John Burkardt c c Parameters: c c Input, integer N, the order of the matrix. c c Output, double complex LAMBDA(N), the eigenvalues. c implicit none integer n double complex lambda(n) call c8vec_unity ( n, lambda ) return end subroutine upshift_inverse ( n, a ) c*********************************************************************72 c cc UPSHIFT_INVERSE returns the inverse of the UPSHIFT matrix. c c Licensing: c c This code is distributed under the GNU LGPL license. c c Modified: c c 19 October 2007 c c Author: c c John Burkardt c c Parameters: c c Input, integer N, the order of the matrix. c c Output, double precision A(N,N), the matrix. c implicit none integer n double precision a(n,n) call downshift ( n, a ) return end subroutine vand1 ( n, x, a ) c*********************************************************************72 c cc VAND1 returns the VAND1 matrix. c c Formula: c c A(I,J) = X(J)^(I-1) c c Example: c c N = 5, c X = ( 2, 3, 4, 5, 6 ) c c 1 1 1 1 1 c 2 3 4 5 6 c 4 9 16 25 36 c 8 27 64 125 216 c 16 81 256 625 1296 c c Properties: c c A is generally not symmetric: A' .ne. A. c c A is nonsingular if, and only if, the X values are distinct. c c det ( A ) = product ( 1 <= I <= N ) ( 1 <= J .lt. I ) ( X(I) - X(J) ). c = product ( 1 <= J <= N ) X(J) c * product ( 1 <= I .lt. J ) ( X(J) - X(I) ). c c A is generally ill-conditioned. c c The family of matrices is nested as a function of N. c c Licensing: c c This code is distributed under the GNU LGPL license. c c Modified: c c 19 June 2011 c c Author: c c John Burkardt c c Reference: c c Robert Gregory, David Karney, c A Collection of Matrices for Testing Computational Algorithms, c Wiley, 1969, c ISBN: 0882756494, c LC: QA263.68 c c Nicholas Higham, c Stability analysis of algorithms for solving confluent c Vandermonde-like systems, c SIAM Journal on Matrix Analysis and Applications, c Volume 11, 1990, pages 23-41. c c Parameters: c c Input, integer N, the order of the matrix. c c Input, double precision X(N), the values that define A. c c Output, double precision A(N,N), the matrix. c implicit none integer n double precision a(n,n) integer i integer j double precision x(n) do j = 1, n do i = 1, n if ( i .eq. 1 .and. x(j) .eq. 0.0D+00 ) then a(i,j) = 1.0D+00 else a(i,j) = x(j) ** ( i - 1 ) end if end do end do return end subroutine vand1_determinant ( n, x, determ ) c*********************************************************************72 c cc VAND1_DETERMINANT returns the determinant of the VAND1 matrix. c c Licensing: c c This code is distributed under the GNU LGPL license. c c Modified: c c 19 June 2011 c c Author: c c John Burkardt c c Parameters: c c Input, integer N, the order of the matrix. c c Input, double precision X(N), the values that define A. c c Output, double precision DETERM, the determinant. c implicit none integer n double precision determ integer i integer j double precision x(n) determ = 1.0D+00 do i = 1, n do j = 1, i - 1 determ = determ * ( x(i) - x(j) ) end do end do return end subroutine vand1_inverse ( n, x, a ) c*********************************************************************72 c cc VAND1_INVERSE returns the inverse of the VAND1 matrix. c c Formula: c c A(I,J) = coefficient of X^(J-1) in I-th Lagrange basis polynomial. c c Example: c c N = 5, c X = ( 2, 3, 4, 5, 6 ) c c 15.00 -14.25 4.96 -0.75 0.04 c -40.00 44.67 -17.33 2.83 -0.17 c 45.00 -54.00 22.75 -4.00 0.25 c -24.00 30.00 -13.33 2.50 -0.17 c 5.00 -6.42 2.96 -0.58 0.04 c c Properties: c c The sum of the entries of A is c c 1 - product ( 1 <= I <= N ) ( 1 - 1 / X(I) ). c c Licensing: c c This code is distributed under the GNU LGPL license. c c Modified: c c 19 June 2011 c c Author: c c John Burkardt c c Parameters: c c Input, integer N, the order of the matrix. c c Input, double precision X(N), the values that define A. c c Output, double precision A(N,N), the matrix. c implicit none integer n double precision a(n,n) integer i integer index integer j integer k double precision x(n) do j = 1, n do i = 1, n if ( j .eq. 1 ) then a(i,j) = 1.0D+00 else a(i,j) = 0.0D+00 end if end do end do do i = 1, n index = 0 do k = 1, n if ( k .ne. i ) then index = index + 1 do j = index + 1, 1, -1 a(i,j) = - x(k) * a(i,j) / ( x(i) - x(k) ) if ( 1 .lt. j ) then a(i,j) = a(i,j) + a(i,j-1) / ( x(i) - x(k) ) end if end do end if end do end do return end subroutine vand1_inverse_ul ( n, x, u, l ) c*********************************************************************72 c cc VAND1_INVERSE_UL returns the UL factors of the Vandermonde1 inverse. c c Discussion: c c inverse ( A ) = U * L. c c Licensing: c c This code is distributed under the GNU LGPL license. c c Modified: c c 02 November 2013 c c Author: c c John Burkardt c c Reference: c c Richard Turner, c Inverse of the Vandermonde Matrix with Applications, c NASA Technical Note TN D-3547, 1966. c c Parameters: c c Input, integer N, the order of the matrix. c c Input, double precision X(N), the values that define A. c c Output, double precision U(N,N), L(N,N), the UL factors of inverse(A). c implicit none integer n integer i integer j integer k double precision l(n,n) double precision u(n,n) double precision x(n) do i = 1, n do j = 1, i u(j,i) = 1.0D+00 end do u(i+1,i) = 0.0D+00 do j = 1, i do k = 1, i if ( j .ne. k ) then u(j,i) = u(j,i) / ( x(j) - x(k) ) end if end do end do end do do i = 1, n do j = 1, i - 1 l(j,i) = 0.0D+00 end do l(i,i) = 1.0D+00 if ( i .eq. 1 ) then do j = i + 1, n l(j,i) = - l(j-1,i) * x(j-1) end do else do j = i + 1, n l(j,i) = l(j-1,i-1) - l(j-1,i) * x(j-1) end do end if end do return end subroutine vand2 ( n, x, a ) c*********************************************************************72 c cc VAND2 returns the VAND2 matrix. c c Discussion: c c For this version of the Vandermonde matrix, the 1's occur in the c first column. c c Formula: c c A(I,J) = X(I)^(J-1) c c Example: c c N = 5, c X = (2, 3, 4, 5, 6) c c 1 2 4 8 16 c 1 3 9 27 81 c 1 4 16 64 256 c 1 5 25 125 625 c 1 6 36 216 1296 c c Properties: c c A is generally not symmetric: A' .ne. A. c c A is nonsingular if, and only if, the X values are distinct. c c det ( A ) = product ( 1 <= I <= N ) ( c product ( 1 <= J .lt. I ) ( ( X(I) - X(J) ) ) ). c c det ( A ) = product ( 1 <= I <= N ) ( c X(I) * product ( 1 <= J <= I - 1 ) ( ( X(I) - X(J) ) ). c c A is generally ill-conditioned. c c The sum of the entries of A is c c 1 - product ( 1 <= I <= N ) ( 1 - 1 / X(I) ). c c The family of matrices is nested as a function of N. c c Licensing: c c This code is distributed under the GNU LGPL license. c c Modified: c c 19 June 2011 c c Author: c c John Burkardt c c Reference: c c Nicholas Higham, c Stability analysis of algorithms for solving confluent c Vandermonde-like systems, c SIAM Journal on Matrix Analysis and Applications, c Volume 11, 1990, pages 23-41. c c Parameters: c c Input, integer N, the order of the matrix. c c Input, double precision X(N), the values that define A. c c Output, double precision A(N,N), the matrix. c implicit none integer n double precision a(n,n) integer i integer j double precision x(n) do j = 1, n do i = 1, n if ( j .eq. 1 .and. x(i) .eq. 0.0D+00 ) then a(i,j) = 1.0D+00 else a(i,j) = x(i) ** ( j - 1 ) end if end do end do return end subroutine vand2_determinant ( n, x, determ ) c*********************************************************************72 c cc VAND2_DETERMINANT returns the determinant of the VAND2 matrix. c c Licensing: c c This code is distributed under the GNU LGPL license. c c Modified: c c 19 June 2011 c c Author: c c John Burkardt c c Parameters: c c Input, integer N, the order of the matrix. c c Input, double precision X(N), the values that define A. c c Output, double precision DETERM, the determinant. c implicit none integer n double precision determ integer i integer j double precision x(n) determ = 1.0D+00 do j = 1, n do i = 1, j - 1 determ = determ * ( x(i) - x(j) ) end do end do return end subroutine vand2_inverse ( n, x, a ) c*********************************************************************72 c cc VAND2_INVERSE returns the inverse of the VAND2 matrix. c c Formula: c c A(I,J) = coefficient of X^(I-1) in J-th Lagrange basis polynomial. c c Example: c c N = 5, X = ( 2, 3, 4, 5, 6 ) c c 15.00 -40.00 45.00 -24.00 5.00 c -14.25 44.67 -54.00 30.00 -6.42 c 4.96 -17.33 22.75 -13.33 2.96 c -0.75 2.83 -4.00 2.50 -0.58 c 0.04 -0.17 0.25 -0.17 0.04 c c Licensing: c c This code is distributed under the GNU LGPL license. c c Modified: c c 19 June 2011 c c Author: c c John Burkardt c c Parameters: c c Input, integer N, the order of the matrix. c c Input, double precision X(N), the values that define the matrix. c c Output, double precision A(N,N), the matrix. c implicit none integer n double precision a(n,n) integer i integer index integer j integer k double precision x(n) do j = 1, n do i = 1, n if ( i .eq. 1 ) then a(i,j) = 1.0D+00 else a(i,j) = 0.0D+00 end if end do end do do i = 1, n index = 0 do k = 1, n if ( k .ne. i ) then index = index + 1 do j = index + 1, 1, -1 a(j,i) = - x(k) * a(j,i) / ( x(i) - x(k) ) if ( 1 .lt. j ) then a(j,i) = a(j,i) + a(j-1,i) / ( x(i) - x(k) ) end if end do end if end do end do return end subroutine vand2_inverse_ul ( n, x, u, l ) c*********************************************************************72 c cc VAND2_INVERSE_UL returns the UL factors of the Vandermonde2 inverse. c c Discussion: c c inverse ( A ) = U * L. c c Licensing: c c This code is distributed under the GNU LGPL license. c c Modified: c c 02 November 2013 c c Author: c c John Burkardt c c Reference: c c Richard Turner, c Inverse of the Vandermonde Matrix with Applications, c NASA Technical Note TN D-3547, 1966. c c Parameters: c c Input, integer N, the order of the matrix. c c Input, double precision X(N), the values that define A. c c Output, double precision U(N,N), L(N,N), the UL factors of inverse(A). c implicit none integer n integer i integer j integer k double precision l(n,n) double precision u(n,n) double precision x(n) do i = 1, n do j = 1, i - 1 u(i,j) = 0.0D+00 end do u(i,i) = 1.0D+00 if ( i .eq. 1 ) then do j = i + 1, n u(i,j) = - u(i,j-1) * x(j-1) end do else do j = i + 1, n u(i,j) = u(i-1,j-1) - u(i,j-1) * x(j-1) end do end if end do do i = 1, n do j = 1, i l(i,j) = 1.0D+00 end do do j = 1, i do k = 1, i if ( j .ne. k ) then l(i,j) = l(i,j) / ( x(j) - x(k) ) end if end do end do do j = i + 1, n l(i,j) = 0.0D+00 end do end do return end subroutine vand2_lu ( n, x, l, u ) c*********************************************************************72 c cc VAND2_LU returns the LU factors of the Vandermonde2 matrix. c c Licensing: c c This code is distributed under the GNU LGPL license. c c Modified: c c 05 November 2013 c c Author: c c John Burkardt c c Reference: c c Halil Oruc, George Phillips, c Explicit factorization of the Vandermonde matrix, c Linear Algebra and its Applications, c Volume 315, Number 1-3, 15 August 2000, pages 113-123. c c Parameters: c c Input, integer N, the order of the matrix. c c Input, double precision X(N), the values that define the matrix. c c Output, double precision L(N,N), U(N,N), the LU factors of the matrix. c implicit none integer n integer i integer j integer k double precision l(n,n) double precision u(n,n) double precision value double precision x(n) do i = 1, n do j = 1, i l(i,j) = 1.0D+00 do k = 1, j - 1 l(i,j) = l(i,j) * ( x(i) - x(k) ) / ( x(j) - x(k) ) end do end do do j = i + 1, n l(i,j) = 0.0D+00 end do end do do i = 1, n do j = 1, i - 1 u(i,j) = 0.0D+00 end do do j = i, n call complete_symmetric_poly ( i, j - i, x, value ) u(i,j) = value do k = 1, i - 1 u(i,j) = u(i,j) * ( x(i) - x(k) ) end do end do end do return end subroutine vand2_plu ( n, x, p, l, u ) c*********************************************************************72 c cc VAND2_PLU returns the PLU factors of the Vandermonde2 matrix. c c Licensing: c c This code is distributed under the GNU LGPL license. c c Modified: c c 05 November 2013 c c Author: c c John Burkardt c c Reference: c c Halil Oruc, George Phillips, c Explicit factorization of the Vandermonde matrix, c Linear Algebra and its Applications, c Volume 315, Number 1-3, 15 August 2000, pages 113-123. c c Parameters: c c Input, integer N, the order of the matrix. c c Input, double precision X(N), the values that define the matrix. c c Output, double precision P(N,N), L(N,N), U(N,N), the PLU factors. c implicit none integer n integer i integer j integer k double precision l(n,n) double precision p(n,n) double precision u(n,n) double precision value double precision x(n) do j = 1, n do i = 1, n p(i,j) = 0.0D+00 end do p(j,j) = 1.0D+00 end do do i = 1, n do j = 1, i l(i,j) = 1.0D+00 do k = 1, j - 1 l(i,j) = l(i,j) * ( x(i) - x(k) ) / ( x(j) - x(k) ) end do end do do j = i + 1, n l(i,j) = 0.0D+00 end do end do do i = 1, n do j = 1, i - 1 u(i,j) = 0.0D+00 end do do j = i, n call complete_symmetric_poly ( i, j - i, x, value ) u(i,j) = value do k = 1, i - 1 u(i,j) = u(i,j) * ( x(i) - x(k) ) end do end do end do return end subroutine wathen ( nx, ny, n, a ) c*********************************************************************72 c cc WATHEN returns the WATHEN matrix. c c Discussion: c c The Wathen matrix is a finite element matrix which is sparse. c c The entries of the matrix depend in part on a physical quantity c related to density. That density is here assigned random values between c 0 and 100. c c The matrix order N is determined by the input quantities NX and NY, c which would usually be the number of elements in the X and Y directions. c The value of N is c c N = 3*NX*NY + 2*NX + 2*NY + 1, c c and sufficient storage in A must have been set aside to hold c the matrix. c c A is the consistent mass matrix for a regular NX by NY grid c of 8 node serendipity elements. c c The local element numbering is c c 3--2--1 c | | c 4 8 c | | c 5--6--7 c c Here is an illustration for NX = 3, NY = 2: c c 23-24-25-26-27-28-29 c | | | | c 19 20 21 22 c | | | | c 12-13-14-15-16-17-18 c | | | | c 8 9 10 11 c | | | | c 1--2--3--4--5--6--7 c c For this example, the total number of nodes is, as expected, c c N = 3 * 3 * 2 + 2 * 2 + 2 * 3 + 1 = 29 c c Properties: c c A is symmetric positive definite for any positive values of the c density RHO(NX,NY), which is here given the value 1. c c The problem could be reprogrammed so that RHO is nonconstant, c but positive. c c Licensing: c c This code is distributed under the GNU LGPL license. c c Modified: c c 19 June 2011 c c Author: c c John Burkardt c c Reference: c c Nicholas Higham, c Algorithm 694: A Collection of Test Matrices in MATLAB, c ACM Transactions on Mathematical Software, c Volume 17, Number 3, September 1991, pages 289-305. c c Andrew Wathen, c Realistic eigenvalue bounds for the Galerkin mass matrix, c IMA Journal of Numerical Analysis, c Volume 7, Number 4, October 1987, pages 449-457. c c Parameters: c c Input, integer NX, NY, values which determine the size of A. c c Input, integer N, the order of the matrix. c c Output, double precision A(N,N), the matrix. c implicit none integer n double precision a(n,n) double precision em(8,8) integer i integer j integer kcol integer krow integer nx integer ny integer node(8) double precision r8_uniform_01 double precision rho integer seed save em data em / & 6.0, -6.0, 2.0, -8.0, 3.0, -8.0, 2.0, -6.0, & -6.0, 32.0, -6.0, 20.0, -8.0, 16.0, -8.0, 20.0, & 2.0, -6.0, 6.0, -6.0, 2.0, -8.0, 3.0, -8.0, & -8.0, 20.0, -6.0, 32.0, -6.0, 20.0, -8.0, 16.0, & 3.0, -8.0, 2.0, -6.0, 6.0, -6.0, 2.0, -8.0, & -8.0, 16.0, -8.0, 20.0, -6.0, 32.0, -6.0, 20.0, & 2.0, -8.0, 3.0, -8.0, 2.0, -6.0, 6.0, -6.0, & -6.0, 20.0, -8.0, 16.0, -8.0, 20.0, -6.0, 32.0 / do j = 1, n do i = 1, n a(i,j) = 0.0D+00 end do end do seed = 123456789 do j = 1, ny do i = 1, nx c c For the element (I,J), determine the indices of the 8 nodes. c node(1) = 3 * j * nx + 2 * j + 2 * i + 1 node(2) = node(1) - 1 node(3) = node(1) - 2 node(4) = ( 3 * j - 1 ) * nx + 2 * j + i - 1 node(8) = node(4) + 1 node(5) = ( 3 * j - 3 ) * nx + 2 * j + 2 * i - 3 node(6) = node(5) + 1 node(7) = node(5) + 2 rho = 100.0D+00 * r8_uniform_01 ( seed ) do krow = 1, 8 do kcol = 1, 8 a(node(krow),node(kcol)) = a(node(krow),node(kcol)) & + rho * em(krow,kcol) end do end do end do end do return end subroutine wathen_order ( nx, ny, n ) c*********************************************************************72 c cc WATHEN_ORDER returns the order of the WATHEN matrix. c c Discussion: c c N = 3 * 3 * 2 + 2 * 2 + 2 * 3 + 1 = 29 c c Licensing: c c This code is distributed under the GNU LGPL license. c c Modified: c c 17 June 2011 c c Author: c c John Burkardt c c Reference: c c Nicholas Higham, c Algorithm 694: A Collection of Test Matrices in MATLAB, c ACM Transactions on Mathematical Software, c Volume 17, Number 3, September 1991, pages 289-305. c c Andrew Wathen, c Realistic eigenvalue bounds for the Galerkin mass matrix, c IMA Journal of Numerical Analysis, c Volume 7, 1987, pages 449-457. c c Parameters: c c Input, integer NX, NY, values which determine the size of A. c c Output, integer N, the order of the matrix, c as determined by NX and NY. c implicit none integer n integer nx integer ny n = 3 * nx * ny + 2 * nx + 2 * ny + 1 return end subroutine wilk03 ( a ) c*********************************************************************72 c cc WILK03 returns the WILK03 matrix. c c Formula: c c 1.0D-10 0.9 -0.4 c 0 0.9 -0.4 c 0 0 1.0D-10 c c Discussion: c c The linear equation under study is c A * X = B, c where A is the 3 by 3 Wilkinson matrix, and c B = ( 0, 0, 1 )' c and the correct solution is c X = ( 0, 4.0D+10 / 9.0D+00, 1.0D+10 ) c c Since the matrix is already in upper triangular form, errors can c occur only in the backsubstitution. c c Properties: c c A is generally not symmetric: A' /= A. c c A is upper triangular. c c det ( A ) = 0.9D-20 c c LAMBDA = ( 1.0D-10, 0.9, 1.0D-10 ) c c Licensing: c c This code is distributed under the GNU LGPL license. c c Modified: c c 12 June 2011 c c Author: c c John Burkardt c c Reference: c c James Wilkinson, c Error Analysis of Direct Methods of Matrix Inversion, c Journal of the Association for Computing Machinery, c Volume 8, 1961, pages 281-330. c c Parameters: c c Output, double precision A(3,3), the matrix. c implicit none double precision a(3,3) double precision a_save(3,3) save a_save c c Note that the matrix entries are listed by column. c data a_save / & 1.0D-10, 0.0D+00, 0.0D+00, & 0.9D+00, 0.9D+00, 0.0D+00, & -0.4D+00, -0.4D+00, 1.0D-10 / call r8mat_copy ( 3, 3, a_save, a ) return end subroutine wilk03_condition ( cond ) c*********************************************************************72 c cc WILK03_CONDITION returns the L1 condition of the WILK03 matrix. c c Licensing: c c This code is distributed under the GNU LGPL license. c c Modified: c c 18 January 2015 c c Author: c c John Burkardt c c Parameters: c c Output, double precision COND, the L1 condition. c implicit none double precision cond cond = 1.8D+00 * ( 13.0D+00 * 1.0D+10 / 9.0D+00 ) return end subroutine wilk03_determinant ( determ ) c*********************************************************************72 c cc WILK03_DETERMINANT returns the determinant of the WILK03 matrix. c c Licensing: c c This code is distributed under the GNU LGPL license. c c Modified: c c 12 June 2011 c c Author: c c John Burkardt c c Parameters: c c Output, double precision DETERM, the determinant of the matrix. c implicit none double precision determ determ = 0.9D-20 return end subroutine wilk03_eigenvalues ( lambda ) c*********************************************************************72 c cc WILK03_EIGENVALUES returns the eigenvalues of the WILK03 matrix. c c Licensing: c c This code is distributed under the GNU LGPL license. c c Modified: c c 12 June 2011 c c Author: c c John Burkardt c c Parameters: c c Output, double precision LAMBDA(3), the eigenvalues of the matrix. c implicit none double precision lambda(3) double precision lambda_save(3) save lambda_save data lambda_save / & 1.0D-10, 1.0D-10, 0.9D+00 / call r8vec_copy ( 3, lambda_save, lambda ) return end subroutine wilk03_inverse ( a ) c*********************************************************************72 c cc WILK03_INVERSE returns the inverse of the WILK03 matrix. c c Formula: c c 1.0D+10 -1.0D+10 0 c 0 10/9 4/9 * 1.0D+10 c 0 0 1.0D+10 c c Licensing: c c This code is distributed under the GNU LGPL license. c c Modified: c c 12 June 2011 c c Author: c c John Burkardt c c Parameters: c c Output, double precision A(3,3), the matrix. c implicit none double precision a(3,3) a(1,1) = 1.0D+10 a(2,1) = 0.0D+00 a(3,1) = 0.0D+00 a(1,2) = - 1.0D+10 a(2,2) = 10.0D+00 / 9.0D+00 a(3,2) = 0.0D+00 a(1,3) = 0.0D+00 a(2,3) = 4.0D+10 / 9.0D+00 a(3,3) = 1.0D+10 return end subroutine wilk03_rhs ( b ) c*********************************************************************72 c cc WILK03_RHS returns the right hand side of the WILK03 linear system. c c Licensing: c c This code is distributed under the GNU LGPL license. c c Modified: c c 12 June 2011 c c Author: c c John Burkardt c c Parameters: c c Output, double precision B(3), the right hand side of the system. c implicit none double precision b(3) b(1) = 0.0D+00 b(2) = 0.0D+00 b(3) = 1.0D+00 return end subroutine wilk03_solution ( x ) c*********************************************************************72 c cc WILK03_SOLUTION returns the solution of the WILK03 linear system. c c Licensing: c c This code is distributed under the GNU LGPL license. c c Modified: c c 12 June 2011 c c Author: c c John Burkardt c c Parameters: c c Output, double precision X(3), the solution of the linear system. c implicit none double precision x(3) x(1) = 0.0D+00 x(2) = 4.0D+10 / 9.0D+00 x(3) = 1.0D+10 return end subroutine wilk04 ( a ) c*********************************************************************72 c cc WILK04 returns the WILK04 matrix. c c Formula: c c 0.9143D-04 0.0D+00 0.0D+00 0.0D+00 c 0.8762 0.7156D-04 0.0D+00 0.0D+00 c 0.7943 0.8143 0.9504D-04 0.0D+00 c 0.8017 0.6123 0.7165 0.7123D-04 c c Properties: c c A is lower triangular. c c LAMBDA = ( 0.9143D-04, 0.7156D-04, 0.9504D-04, 0.7123D-04 ). c c Discussion: c c Since the matrix is already in lower triangular form, errors can c occur only in the backsubstitution. However, even a double c precision calculation will show a significant degradation in the c solution. It is also instructive to compare the actual error in c the solution to the residual error, A*x-b. c c Licensing: c c This code is distributed under the GNU LGPL license. c c Modified: c c 12 June 2011 c c Author: c c John Burkardt c c Reference: c c James Wilkinson, c Rounding Errors in Algebraic Processes, c Prentice Hall, 1963, page 105. c c Parameters: c c Output, double precision A(4,4), the matrix. c implicit none double precision a(4,4) a(1,1) = 0.9143D-04 a(2,1) = 0.8762D+00 a(3,1) = 0.7943D+00 a(4,1) = 0.8017D+00 a(1,2) = 0.0000D+00 a(2,2) = 0.7156D-04 a(3,2) = 0.8143D+00 a(4,2) = 0.6123D+00 a(1,3) = 0.0000D+00 a(2,3) = 0.0000D+00 a(3,3) = 0.9504D-04 a(4,3) = 0.7165D+00 a(1,4) = 0.0000D+00 a(2,4) = 0.0000D+00 a(3,4) = 0.0000D+00 a(4,4) = 0.7123D-04 return end subroutine wilk04_condition ( cond ) c*********************************************************************72 c cc WILK04_CONDITION returns the L1 condition of the WILK04 matrix. c c Licensing: c c This code is distributed under the GNU LGPL license. c c Modified: c c 08 February 2015 c c Author: c c John Burkardt c c Parameters: c c Output, double precision COND, the L1 condition. c implicit none double precision a_norm double precision b_norm double precision cond a_norm = 2.1306D+00 b_norm = 1.154098458240528D+16 cond = a_norm * b_norm return end subroutine wilk04_determinant ( determ ) c*********************************************************************72 c cc WILK04_DETERMINANT returns the determinant of the WILK04 matrix. c c Licensing: c c This code is distributed under the GNU LGPL license. c c Modified: c c 12 June 2011 c c Author: c c John Burkardt c c Parameters: c c Output, double precision DETERM, the determinant. c implicit none double precision determ determ = 0.9143D-04 * 0.7156D-04 * 0.9504D-04 * 0.7123D-04 return end subroutine wilk04_eigenvalues ( lambda ) c*********************************************************************72 c cc WILK04_EIGENVALUES returns the eigenvalues of the WILK04 matrix. c c Licensing: c c This code is distributed under the GNU LGPL license. c c Modified: c c 12 June 2011 c c Author: c c John Burkardt c c Parameters: c c Output, double precision LAMBDA(4), the eigenvalues. c implicit none double precision lambda(4) double precision lambda_save(4) save lambda_save data lambda_save / & 0.9143D-04, 0.7156D-04, 0.9504D-04, 0.7123D-04 / call r8vec_copy ( 4, lambda_save, lambda ) return end subroutine wilk04_inverse ( a ) c*********************************************************************72 c cc WILK04_INVERSE returns the inverse of the WILK04 matrix. c c Licensing: c c This code is distributed under the GNU LGPL license. c c Modified: c c 12 June 2011 c c Author: c c John Burkardt c c Parameters: c c Output, double precision A(4,4), the matrix. c implicit none double precision a(4,4) double precision a_save(4,4) save a_save c c Note that the matrix entries are listed by column. c data a_save / & 0.000000000001094D+16, & -0.000000013391962D+16, & 0.000114732803288D+16, & -1.153978022391245D+16, & 0.000000000000000D+00, & 0.000000000001397D+16, & -0.000000011973129D+16, & 0.000120425263952D+16, & 0.000000000000000D+00, & 0.000000000000000D+00, & 0.000000000001052D+16, & -0.000000010583927D+16, & 0.000000000000000D+00, & 0.000000000000000D+00, & 0.000000000000000D+00, & 0.000000000001404D+16 / call r8mat_copy ( 4, 4, a_save, a ) return end subroutine wilk04_rhs ( b ) c*********************************************************************72 c cc WILK04_RHS returns the right hand side of the WILK04 linear system. c c Formula: c c 0.6524 c 0.3127 c 0.4186 c 0.7853 c c Licensing: c c This code is distributed under the GNU LGPL license. c c Modified: c c 12 June 2011 c c Author: c c John Burkardt c c Parameters: c c Output, double precision B(4), the right hand side of the system. c implicit none double precision b(4) b(1) = 0.6524D+00 b(2) = 0.3127D+00 b(3) = 0.4186D+00 b(4) = 0.7853D+00 return end subroutine wilk04_solution ( x ) c*********************************************************************72 c cc WILK04_SOLUTION returns the solution of the WILK04 linear system. c c Licensing: c c This code is distributed under the GNU LGPL license. c c Modified: c c 12 June 2011 c c Author: c c John Burkardt c c Parameters: c c Output, double precision X(4), the solution of the system. c implicit none double precision x(4) double precision x_save(4) save x_save data x_save / & -9.061709180193406D+15, & 9.456494826647572D+11, & -8.311117178175363D+07, & 1.102484908044364D+04 / call r8vec_copy ( 4, x_save, x ) return end subroutine wilk05 ( a ) c*********************************************************************72 c cc WILK05 returns the WILK05 matrix. c c Formula: c c A(I,J) = 1.8144 / ( I + J + 1 ) c c Example: c c 0.604800 0.453600 0.362880 0.302400 0.259200 c 0.453600 0.362880 0.302400 0.259200 0.226800 c 0.362880 0.302400 0.259200 0.226800 0.201600 c 0.302400 0.259200 0.226800 0.201600 0.181440 c 0.259200 0.226800 0.201600 0.181440 0.164945 c c Properties: c c A is symmetric: A' = A. c c Because A is symmetric, it is normal. c c Because A is normal, it is diagonalizable. c c A is essentially a scaled portion of the Hilbert matrix. c c Licensing: c c This code is distributed under the GNU LGPL license. c c Modified: c c 12 June 2011 c c Author: c c John Burkardt c c Reference: c c James Wilkinson, c The Algebraic Eigenvalue Problem, c Oxford University Press, 1965, c page 234. c c Parameters: c c Output, double precision A(5,5), the matrix. c implicit none integer n parameter ( n = 5 ) double precision a(n,n) integer i integer j do j = 1, n do i = 1, n a(i,j) = 1.8144D+00 / dble ( i + j + 1 ) end do end do return end subroutine wilk05_condition ( value ) c*********************************************************************72 c cc WILK05_CONDITION returns the L1 condition of the WILK05 matrix. c c Licensing: c c This code is distributed under the GNU LGPL license. c c Modified: c c 08 February 2015 c c Author: c c John Burkardt c c Parameters: c c Output, double precision VALUE, the L1 condition. c implicit none double precision a_norm double precision b_norm double precision value a_norm = 1.98288D+00 b_norm = 4.002777777857721D+06 value = a_norm * b_norm return end subroutine wilk05_determinant ( determ ) c*********************************************************************72 c cc WILK05_DETERMINANT returns the determinant of the WILK05 matrix. c c Licensing: c c This code is distributed under the GNU LGPL license. c c Modified: c c 12 June 2011 c c Author: c c John Burkardt c c Parameters: c c Output, double precision DETERM, the determinant. c implicit none double precision determ determ = 3.7995D-15 return end subroutine wilk05_inverse ( a ) c*********************************************************************72 c cc WILK05_INVERSE returns the inverse of the WILK05 matrix. c c Licensing: c c This code is distributed under the GNU LGPL license. c c Modified: c c 12 June 2011 c c Author: c c John Burkardt c c Parameters: c c Output, double precision A(5,5), the matrix. c implicit none double precision a(5,5) double precision a_save(5,5) save a_save c c Note that the matrix entries are listed by column. c data a_save / & 0.002025462963002D+06, & -0.016203703704040D+06, & 0.043750000000952D+06, & -0.048611111112203D+06, & 0.019097222222661D+06, & -0.016203703704042D+06, & 0.138271604941179D+06, & -0.388888888897095D+06, & 0.444444444453843D+06, & -0.178240740744515D+06, & 0.043750000000962D+06, & -0.388888888897136D+06, & 1.125000000023251D+06, & -1.312500000026604D+06, & 0.534722222232897D+06, & -0.048611111112219D+06, & 0.444444444453930D+06, & -1.312500000026719D+06, & 1.555555555586107D+06, & -0.641666666678918D+06, & 0.019097222222669D+06, & -0.178240740744564D+06, & 0.534722222232983D+06, & -0.641666666678964D+06, & 0.267361111116040D+06 / call r8mat_copy ( 5, 5, a_save, a ) return end subroutine wilk12 ( a ) c*********************************************************************72 c cc WILK12 returns the WILK12 matrix. c c Formula: c c 12 11 0 0 0 0 0 0 0 0 0 0 c 11 11 10 0 0 0 0 0 0 0 0 0 c 10 10 10 9 0 0 0 0 0 0 0 0 c 9 9 9 9 8 0 0 0 0 0 0 0 c 8 8 8 8 8 7 0 0 0 0 0 0 c 7 7 7 7 7 7 6 0 0 0 0 0 c 6 6 6 6 6 6 6 5 0 0 0 0 c 5 5 5 5 5 5 5 5 4 0 0 0 c 4 4 4 4 4 4 4 4 4 3 0 0 c 3 3 3 3 3 3 3 3 3 3 2 0 c 2 2 2 2 2 2 2 2 2 2 2 1 c 1 1 1 1 1 1 1 1 1 1 1 1 c c Properties: c c A is generally not symmetric: A' /= A. c c A is integral, therefore det ( A ) is integral, and c det ( A ) * inverse ( A ) is integral. c c det ( A ) = 1. c c A is lower Hessenberg. c c The smaller eigenvalues are very ill conditioned. c c Licensing: c c This code is distributed under the GNU LGPL license. c c Modified: c c 15 June 2011 c c Author: c c John Burkardt c c Reference: c c James Wilkinson, c Rounding Errors in Algebraic Processes, c Prentice Hall, 1963, c page 151. c c Parameters: c c Output, double precision A(12,12), the matrix. c implicit none integer n parameter ( n = 12 ) double precision a(n,n) integer i integer j do j = 1, n do i = 1, n if ( j .le. i + 1 ) then a(i,j) = dble ( n + 1 - max ( i, j ) ) else a(i,j) = 0.0D+00 end if end do end do return end subroutine wilk12_condition ( value ) c*********************************************************************72 c cc WILK12_CONDITION returns the L1 condition of the WILK12 matrix. c c Licensing: c c This code is distributed under the GNU LGPL license. c c Modified: c c 19 April 2015 c c Author: c c John Burkardt c c Parameters: c c Output, double precision VALUE, the L1 condition. c implicit none double precision a_norm double precision b_norm double precision value a_norm = 78.0D+00 b_norm = 87909427.13689443D+00 value = a_norm * b_norm return end subroutine wilk12_determinant ( determ ) c*********************************************************************72 c cc WILK12_DETERMINANT returns the determinant of the WILK12 matrix. c c Licensing: c c This code is distributed under the GNU LGPL license. c c Modified: c c 17 October 2007 c c Author: c c John Burkardt c c Parameters: c c Output, double precision DETERM, the determinant. c implicit none double precision determ determ = 1.0D+00 return end subroutine wilk12_eigenvalues ( lambda ) c*********************************************************************72 c cc WILK12_EIGENVALUES returns the eigenvalues of the WILK12 matrix. c c Formula: c c 32.2288915 c 20.1989886 c 12.3110774 c 6.96153309 c 3.51185595 c 1.55398871 c 0.643505319 c 0.284749721 c 0.143646520 c 0.081227659240405 c 0.049507429185278 c 0.031028060644010 c c Licensing: c c This code is distributed under the GNU LGPL license. c c Modified: c c 15 June 2011 c c Author: c c John Burkardt c c Parameters: c c Output, double precision LAMBDA(12), the eigenvalues. c implicit none double precision lambda(12) double precision lambda_save(12) save lambda_save data lambda_save / & 32.2288915D+00, 20.1989886D+00, & 12.3110774D+00, 6.96153309D+00, & 3.51185595D+00, 1.55398871D+00, & 0.643505319D+00, 0.284749721D+00, & 0.143646520D+00, 0.081227659240405D+00, & 0.049507429185278D+00, 0.031028060644010D+00 / call r8vec_copy ( 12, lambda_save, lambda ) return end subroutine wilk12_eigen_right ( a ) c*********************************************************************72 c cc WILK12_EIGEN_RIGHT returns right eigenvectors of the WILK12 matrix. c c Licensing: c c This code is distributed under the GNU LGPL license. c c Modified: c c 20 June 2011 c c Author: c c John Burkardt c c Parameters: c c Output, double precision A(12,12), the right eigenvector matrix. c implicit none double precision a(12,12) double precision a_save(12,12) save a_save c c Note that the matrix entries are listed by column. c data a_save / & 0.075953934362606D+00, 0.139678536121698D+00, & 0.212972721043730D+00, 0.286424756003626D+00, & 0.349485357102525D+00, 0.392486174053140D+00, & 0.408397328102426D+00, 0.393960067241308D+00, & 0.350025473229225D+00, 0.281131870150006D+00, & 0.194509944233873D+00, 0.098787565402021D+00, & 0.047186270176379D+00, 0.035170881219766D+00, & -0.019551243493406D+00, -0.113663824929275D+00, & -0.229771631994320D+00, -0.342302599090153D+00, & -0.425606879283194D+00, -0.461118871576638D+00, & -0.441461339130489D+00, -0.370865208095037D+00, & -0.262574394436703D+00, -0.134619530658877D+00, & 0.087498415888682D+00, 0.002474434526797D+00, & -0.095923839958749D+00, -0.124601769209776D+00, & -0.044875899531161D+00, 0.121565513387420D+00, & 0.312274076477727D+00, 0.458792947263280D+00, & 0.515554022627437D+00, 0.471997957002961D+00, & 0.348267903145709D+00, 0.181505588624358D+00, & 0.356080027225304D+00, -0.163099766915005D+00, & -0.325820728704039D+00, -0.104423010988819D+00, & 0.176053383568728D+00, 0.245040317292912D+00, & 0.069840787629820D+00, -0.207165420169259D+00, & -0.418679217847974D+00, -0.475318237218216D+00, & -0.383234018094179D+00, -0.206444528035974D+00, & -0.709141914617340D+00, 0.547208974924657D+00, & 0.370298143032545D+00, -0.087024255226817D+00, & -0.174710647675812D+00, -0.026657290116937D+00, & 0.077762060814618D+00, 0.057335745807230D+00, & -0.018499801182824D+00, -0.070417566622935D+00, & -0.072878348819266D+00, -0.042488463457934D+00, & -0.713561589955660D+00, 0.677624765946043D+00, & 0.144832629941422D+00, -0.095987754186127D+00, & -0.033167043991408D+00, 0.015790103726845D+00, & 0.009303310423290D+00, -0.002909858414229D+00, & -0.003536176142936D+00, 0.000317090937139D+00, & 0.002188160441481D+00, 0.001613099168127D+00, & 0.694800915350134D+00, -0.717318445412803D+00, & -0.021390540433709D+00, 0.047257308713196D+00, & 0.000033398195785D+00, -0.003862799912030D+00, & 0.000145902034404D+00, 0.000419891505074D+00, & -0.000039486945846D+00, -0.000069994145516D+00, & 0.000013255774472D+00, 0.000029720715023D+00, & 0.684104842982405D+00, -0.728587222991804D+00, & 0.028184117194646D+00, 0.019000894182572D+00, & -0.002364147875169D+00, -0.000483008341150D+00, & 0.000145689574886D+00, 0.000006899341493D+00, & -0.000009588938470D+00, 0.000001123011584D+00, & 0.000000762677095D+00, -0.000000504464129D+00, & 0.679348386306787D+00, -0.732235872680797D+00, & 0.047657921019166D+00, 0.006571283153133D+00, & -0.001391439772868D+00, 0.000028271472280D+00, & 0.000025702435813D+00, -0.000004363907083D+00, & -0.000000016748075D+00, 0.000000170826901D+00, & -0.000000050888575D+00, 0.000000010256625D+00, & 0.677141058069838D+00, -0.733699103817717D+00, & 0.056254187307821D+00, 0.000845330889853D+00, & -0.000600573479254D+00, 0.000060575011829D+00, & -0.000000899585454D+00, -0.000000703890529D+00, & 0.000000147573166D+00, -0.000000020110423D+00, & 0.000000002229508D+00, -0.000000000216223D+00, & 0.675994567035284D+00, -0.734406182106934D+00, & 0.060616915148887D+00, -0.002116889869553D+00, & -0.000112561724387D+00, 0.000026805640571D+00, & -0.000002875297806D+00, 0.000000236938971D+00, & -0.000000016773740D+00, 0.000000001068110D+00, & -0.000000000062701D+00, 0.000000000003446D+00, & -0.675318870608569D+00, 0.734806603365595D+00, & -0.063156546323253D+00, 0.003858723645845D+00, & -0.000198682768218D+00, 0.000009145253582D+00, & -0.000000387365950D+00, 0.000000015357316D+00, & -0.000000000576294D+00, 0.000000000020662D+00, & -0.000000000000713D+00, 0.000000000000023D+00 / call r8mat_copy ( 12, 12, a_save, a ) return end subroutine wilk20 ( alpha, a ) c*********************************************************************72 c cc WILK20 returns the WILK20 matrix. c c Formula: c c if ( I = J ) c A(I,J) = I c else if ( I = J-1 ) c A(I,J) = 20 c else if ( I = N, J = 1 ) then c A(I,J) = ALPHA c else c A(I,J) = 0 c c Example: c c 1 20 . . . . . . . . . . . . . . . . . . c . 2 20 . . . . . . . . . . . . . . . . . c . . 3 20 . . . . . . . . . . . . . . . . c . . . 4 20 . . . . . . . . . . . . . . . c . . . . 5 20 . . . . . . . . . . . . . . c . . . . . 6 20 . . . . . . . . . . . . . c . . . . . . 7 20 . . . . . . . . . . . . c . . . . . . . 8 20 . . . . . . . . . . . c . . . . . . . . 9 20 . . . . . . . . . . c . . . . . . . . . 10 20 . . . . . . . . . c . . . . . . . . . . 11 20 . . . . . . . . c . . . . . . . . . . . 12 20 . . . . . . . c . . . . . . . . . . . . 13 20 . . . . . . c . . . . . . . . . . . . . 14 20 . . . . . c . . . . . . . . . . . . . . 15 20 . . . . c . . . . . . . . . . . . . . . 16 20 . . . c . . . . . . . . . . . . . . . . 17 20 . . c . . . . . . . . . . . . . . . . . 18 20 . c . . . . . . . . . . . . . . . . . . 19 20 c ALPHA. . . . . . . . . . . . . . . . . . 20 c c Properties: c c A is generally not symmetric: A' /= A. c c If ALPHA = 0, then c c LAMBDA(I) = i c c and the characteristic equation is c c product ( 1 <= I <= 20 ) ( I - LAMBDA ) = 0 c c and the condition number of eigenvalue I is c c COND(LAMBDA(I)) = (20-I)! * (I-1)! / 20^19. c c If ALPHA is nonzero, the characteristic equation is c c product ( 1 <= I <= 20 ) ( I - LAMBDA ) = 20^19 * ALPHA. c c If ALPHA = 1.0D-10, there are 6 real eigenvalues, and 14 complex c eigenvalues with considerable imaginary parts. c c Licensing: c c This code is distributed under the GNU LGPL license. c c Modified: c c 15 June 2011 c c Author: c c John Burkardt c c Reference: c c Robert Gregory, David Karney, c A Collection of Matrices for Testing Computational Algorithms, c Wiley, 1969, c ISBN: 0882756494, c LC: QA263.68 c c Joan Westlake, c A Handbook of Numerical Matrix Inversion and Solution of c Linear Equations, c John Wiley, 1968, c ISBN13: 978-0471936756, c LC: QA263.W47. c c James Wilkinson, c Rounding Errors in Algebraic Processes, c Prentice Hall, 1963, c page 138. c c Parameters: c c Input, double precision ALPHA, the perturbation. c c Output, double precision A(20,20), the matrix. c implicit none integer n parameter ( n = 20 ) double precision a(n,n) double precision alpha integer i integer j do i = 1, n do j = 1, n if ( i .eq. j ) then a(i,j) = dble ( i ) else if ( j .eq. i + 1 ) then a(i,j) = dble ( n ) else a(i,j) = 0.0D+00 end if end do end do a(n,1) = alpha return end subroutine wilk21 ( n, a ) c*********************************************************************72 c cc WILK21 returns the WILK21 matrix. c c Discussion: c c By using values of N not equal to 21, WILK21 can return a variety c of related matrices. c c Formula: c c if ( I = J ) c A(I,J) = nint ( abs ( i - real ( n+1 ) / 2.0D+00 ) ) c else if ( I = J - 1 or I = J + 1 ) c A(I,J) = 1 c else c A(I,J) = 0 c c Example: c c N = 21 c c 10 1 . . . . . . . . . . . . . . . . . . . c 1 9 1 . . . . . . . . . . . . . . . . . . c . 1 8 1 . . . . . . . . . . . . . . . . . c . . 1 7 1 . . . . . . . . . . . . . . . . c . . . 1 6 1 . . . . . . . . . . . . . . . c . . . . 1 5 1 . . . . . . . . . . . . . . c . . . . . 1 4 1 . . . . . . . . . . . . . c . . . . . . 1 3 1 . . . . . . . . . . . . c . . . . . . . 1 2 1 . . . . . . . . . . . c . . . . . . . . 1 1 1 . . . . . . . . . . c . . . . . . . . . 1 0 1 . . . . . . . . . c . . . . . . . . . . 1 1 1 . . . . . . . . c . . . . . . . . . . . 1 2 1 . . . . . . . c . . . . . . . . . . . . 1 3 1 . . . . . . c . . . . . . . . . . . . . 1 4 1 . . . . . c . . . . . . . . . . . . . . 1 5 1 . . . . c . . . . . . . . . . . . . . . 1 6 1 . . . c . . . . . . . . . . . . . . . . 1 7 1 . . c . . . . . . . . . . . . . . . . . 1 8 1 . c . . . . . . . . . . . . . . . . . . 1 9 1 c . . . . . . . . . . . . . . . . . . . 1 10 c c Properties: c c A is tridiagonal. c c Because A is tridiagonal, it has property A (bipartite). c c A is integral, therefore det ( A ) is integral, and c det ( A ) * inverse ( A ) is integral. c c A is symmetric: A' = A. c c Because A is symmetric, it is normal. c c Because A is normal, it is diagonalizable. c c A is persymmetric: A(I,J) = A(N+1-J,N+1-I). c c Licensing: c c This code is distributed under the GNU LGPL license. c c Modified: c c 15 June 2011 c c Author: c c John Burkardt c c Reference: c c James Wilkinson, c The Algebraic Eigenvalue Problem, c Oxford University Press, 1965, c page 308. c c Parameters: c c Input, integer N, the order of the matrix. c c Output, double precision A(N,N), the matrix. c implicit none integer n double precision a(n,n) integer i integer j do i = 1, n do j = 1, n if ( i .eq. j ) then a(i,j) = anint ( abs ( dble ( i ) & - dble ( n + 1 ) / 2.0D+00 ) ) else if ( j .eq. i + 1 ) then a(i,j) = 1.0D+00 else if ( j .eq. i - 1 ) then a(i,j) = 1.0D+00 else a(i,j) = 0.0D+00 end if end do end do return end subroutine wilk21_determinant ( n, determ ) c*********************************************************************72 c cc WILK21_DETERMINANT computes the determinant of the WILK21 matrix. c c Licensing: c c This code is distributed under the GNU LGPL license. c c Modified: c c 21 November 2007 c c Author: c c John Burkardt c c Parameters: c c Input, integer N, the order of the matrix. c c Output, double precision DETERM, the determinant. c implicit none integer n double precision d(n) double precision determ double precision determ_nm1 double precision determ_nm2 integer i do i = 1, n d(i) = anint ( abs ( dble ( i ) & - dble ( n + 1 ) / 2.0D+00 ) ) end do determ_nm1 = d(n) if ( n .eq. 1 ) then determ = determ_nm1 return end if determ_nm2 = determ_nm1 determ_nm1 = d(n-1) * d(n) - 1.0D+00 if ( n .eq. 2 ) then determ = determ_nm1 return end if do i = n - 2, 1, -1 determ = d(i) * determ_nm1 - determ_nm2 determ_nm2 = determ_nm1 determ_nm1 = determ end do return end subroutine wilk21_inverse ( n, a ) c*********************************************************************72 c cc WILK21_INVERSE returns the inverse of the WILK21 matrix. c c Licensing: c c This code is distributed under the GNU LGPL license. c c Modified: c c 22 November 2007 c c Author: c c John Burkardt c c Reference: c c CM daFonseca, J Petronilho, c Explicit Inverses of Some Tridiagonal Matrices, c Linear Algebra and Its Applications, c Volume 325, 2001, pages 7-21. c c Parameters: c c Input, integer N, the order of the matrix. c c Output, double precision A(N,N), the inverse of the matrix. c implicit none integer n double precision a(n,n) double precision d(n) double precision e(n) integer i integer j double precision r8_mop double precision r8vec_product double precision y(n) do i = 1, n y(i) = anint ( abs ( dble ( i ) - dble ( n + 1 ) / 2.0D+00 ) ) end do d(n) = y(n) do i = n - 1, 1, -1 d(i) = y(i) - 1.0D+00 / d(i+1) end do e(1) = y(1) do i = 2, n e(i) = y(i) - 1.0D+00 / e(i-1) end do do i = 1, n do j = 1, i a(i,j) = r8_mop ( i + j ) * r8vec_product ( n - i, d(i+1) ) & / r8vec_product ( n - j + 1, e(j) ) end do do j = i + 1, n a(i,j) = r8_mop ( i + j ) * r8vec_product ( n - j, d(j+1) ) & / r8vec_product ( n - i + 1, e(i) ) end do end do return end subroutine wilson ( a ) c*********************************************************************72 c cc WILSON returns the WILSON matrix. c c Formula: c c A = c 5 7 6 5 c 7 10 8 7 c 6 8 10 9 c 5 7 9 10 c c Properties: c c The Higham/MATLAB version of this matrix has rows and columns c 1 and 2 interchanged. c c A is symmetric: A' = A. c c Because A is symmetric, it is normal. c c Because A is normal, it is diagonalizable. c c A is positive definite. c c det ( A ) = 1. c c A is ill-conditioned. c c A * X = B, where X is the Wilson solution vector, and B is the c Wilson right hand side. c c A is integral, therefore det ( A ) is integral, and c det ( A ) * inverse ( A ) is integral. c c Licensing: c c This code is distributed under the GNU LGPL license. c c Modified: c c 12 June 2011 c c Author: c c John Burkardt c c Reference: c c Joan Westlake, c A Handbook of Numerical Matrix Inversion and Solution of c Linear Equations, c John Wiley, 1968, c ISBN13: 978-0471936756, c LC: QA263.W47. c c Parameters: c c Output, double precision A(4,4), the matrix. c implicit none double precision a(4,4) double precision a_save(4,4) save a_save c c Note that the matrix entries are listed by column. c data a_save / & 5.0D+00, 7.0D+00, 6.0D+00, 5.0D+00, & 7.0D+00, 10.0D+00, 8.0D+00, 7.0D+00, & 6.0D+00, 8.0D+00, 10.0D+00, 9.0D+00, & 5.0D+00, 7.0D+00, 9.0D+00, 10.0D+00 / call r8mat_copy ( 4, 4, a_save, a ) return end subroutine wilson_condition ( cond ) c*********************************************************************72 c cc WILSON_CONDITION returns the L1 condition of the WILSON matrix. c c Licensing: c c This code is distributed under the GNU LGPL license. c c Modified: c c 10 April 2012 c c Author: c c John Burkardt c c Parameters: c c Input, integer N, the order of the matrix. c c Output, double precision COND, the L1 condition. c implicit none double precision cond cond = 4488.0D+00 return end subroutine wilson_determinant ( n, determ ) c*********************************************************************72 c cc WILSON_DETERMINANT returns the determinant of the WILSON matrix. c c Licensing: c c This code is distributed under the GNU LGPL license. c c Modified: c c 12 June 2011 c c Author: c c John Burkardt c c Parameters: c c Input, integer N, the order of the matrix. c c Output, double precision DETERM, the determinant. c implicit none double precision determ integer n determ = 1.0D+00 return end subroutine wilson_eigen_right ( a ) c*********************************************************************72 c cc WILSON_EIGEN_RIGHT returns right eigenvectors of the WILSON matrix. c c Licensing: c c This code is distributed under the GNU LGPL license. c c Modified: c c 15 June 2011 c c Author: c c John Burkardt c c Parameters: c c Output, double precision A(4,4), the right eigenvector matrix. c implicit none double precision a(4,4) double precision a_save(4,4) save a_save c c Note that the matrix entries are listed by column. c data a_save / & 0.380262074390714D+00, 0.528567849528642D+00, & 0.551954849631663D+00, 0.520924780743657D+00, & 0.396305561186082D+00, 0.614861280394151D+00, & -0.271601039711768D+00, -0.625396181050490D+00, & 0.093305039089285D+00, -0.301652326903523D+00, & 0.760318430013036D+00, -0.567640668325261D+00, & 0.830443752841578D+00, -0.501565058582058D+00, & -0.208553600252039D+00, 0.123697458332363D+00 / call r8mat_copy ( 4, 4, a_save, a ) return end subroutine wilson_eigenvalues ( lambda ) c*********************************************************************72 c cc WILSON_EIGENVALUES returns the eigenvalues of the WILSON matrix. c c Licensing: c c This code is distributed under the GNU LGPL license. c c Modified: c c 22 June 2011 c c Author: c c John Burkardt c c Parameters: c c Output, double precision X(4), the eigenvalues. c implicit none double precision lambda(4) double precision lambda_save(4) save lambda_save data lambda_save / & 30.288685345802129D+00, & 3.858057455944950D+00, & 0.843107149855033D+00, & 0.010150048397892D+00 / call r8vec_copy ( 4, lambda_save, lambda ) return end subroutine wilson_inverse ( a ) c*********************************************************************72 c cc WILSON_INVERSE returns the inverse of the WILSON matrix. c c Formula: c c 68 -41 -17 10 c -41 25 10 -6 c -17 10 5 -3 c 10 -6 -3 2 c c Properties: c c A is symmetric: A' = A. c c Because A is symmetric, it is normal. c c Because A is normal, it is diagonalizable. c c A is integral, therefore det ( A ) is integral, and c det ( A ) * inverse ( A ) is integral. c c Licensing: c c This code is distributed under the GNU LGPL license. c c Modified: c c 12 June 2011 c c Author: c c John Burkardt c c Reference: c c Joan Westlake, c A Handbook of Numerical Matrix Inversion and Solution of c Linear Equations, c John Wiley, 1968, c ISBN13: 978-0471936756, c LC: QA263.W47. c c Parameters: c c Output, double precision A(4,4), the matrix. c implicit none double precision a(4,4) double precision a_save(4,4) save a_save c c Note that the matrix entries are listed by column. c data a_save / & 68.0D+00, -41.0D+00, -17.0D+00, 10.0D+00, & -41.0D+00, 25.0D+00, 10.0D+00, -6.0D+00, & -17.0D+00, 10.0D+00, 5.0D+00, -3.0D+00, & 10.0D+00, -6.0D+00, -3.0D+00, 2.0D+00 / call r8mat_copy ( 4, 4, a_save, a ) return end subroutine wilson_llt ( a ) c*********************************************************************72 c cc WILSON_LLT returns the lower Cholesky factor of the WILSON matrix. c c Licensing: c c This code is distributed under the GNU LGPL license. c c Modified: c c 15 March 2015 c c Author: c c John Burkardt c c Parameters: c c Output, double precision A(4,4), the matrix. c implicit none double precision a(4,4) double precision a_save(4,4) save a_save c c Note that the matrix entries are listed by column. c data a_save / & 2.236067977499790D+00, 3.130495168499706D+00, & 2.683281572999748D+00, 2.236067977499790D+00, & 0.0D+00, 0.447213595499957D+00, & -0.894427190999918D+00, 0.0D+00, & 0.0D+00, 0.0D+00, & 1.414213562373093D+00, 2.121320343559645D+00, & 0.0D+00, 0.0D+00, & 0.0D+00, 0.707106781186539D+00 / call r8mat_copy ( 4, 4, a_save, a ) return end subroutine wilson_plu ( p, l, u ) c*********************************************************************72 c cc WILSON_PLU returns the PLU factors of the WILSON matrix. c c Licensing: c c This code is distributed under the GNU LGPL license. c c Modified: c c 28 June 2011 c c Author: c c John Burkardt c c Parameters: c c Output, double precision P(4,4), L(4,4), U(4,4), the PLU factors. c implicit none double precision l(4,4) double precision l_save(4,4) double precision p(4,4) double precision p_save(4,4) double precision u(4,4) double precision u_save(4,4) save l_save save p_save save u_save c c Note that the matrix entries are listed by column. c data l_save / & 1.0D+00, 0.857142857142857D+00, & 0.714285714285714D+00, 0.714285714285714D+00, & 0.0D+00, 1.00D+00, & 0.25D+00, 0.25D+00, & 0.0D+00, 0.00D+00, & 1.0D+00, -0.20D+00, & 0.0D+00, 0.00D+00, & 0.0D+00, 1.00D+00 / data p_save / & 0.0D+00, 1.0D+00, 0.0D+00, 0.0D+00, & 0.0D+00, 0.0D+00, 1.0D+00, 0.0D+00, & 0.0D+00, 0.0D+00, 0.0D+00, 1.0D+00, & 1.0D+00, 0.0D+00, 0.0D+00, 0.0D+00 / data u_save / & 7.0D+00, 0.00D+00, 0.00D+00, 0.0D+00, & 10.0D+00, -0.571428571428571D+00, 0.00D+00, 0.0D+00, & 8.0D+00, 3.142857142857143D+00, 2.50D+00, 0.0D+00, & 7.0D+00, 3.00D+00, 4.25D+00, 0.10D+00 / call r8mat_copy ( 4, 4, l_save, l ) call r8mat_copy ( 4, 4, p_save, p ) call r8mat_copy ( 4, 4, u_save, u ) return end subroutine wilson_rhs ( b ) c*********************************************************************72 c cc WILSON_RHS returns the WILSON right hand side. c c Licensing: c c This code is distributed under the GNU LGPL license. c c Modified: c c 12 June 2011 c c Author: c c John Burkardt c c Parameters: c c Output, double precision B(4), the right hand side vector. c implicit none double precision b(4) double precision b_save(4) save b_save data b_save / & 23.0D+00, 32.0D+00, 33.0D+00, 31.0D+00 / call r8vec_copy ( 4, b_save, b ) return end subroutine wilson_solution ( x ) c*********************************************************************72 c cc WILSON_SOLUTION returns the WILSON solution. c c Licensing: c c This code is distributed under the GNU LGPL license. c c Modified: c c 12 June 2011 c c Author: c c John Burkardt c c Parameters: c c Output, double precision X(4), the solution vector. c implicit none double precision x(4) double precision x_save(4) save x_save data x_save / & 1.0D+00, 1.0D+00, 1.0D+00, 1.0D+00 / call r8vec_copy ( 4, x_save, x ) return end subroutine zero ( m, n, a ) c*********************************************************************72 c cc ZERO returns the ZERO matrix. c c Formula: c c A(I,J) = 0 c c Example: c c M = 4, N = 5 c c 0 0 0 0 0 c 0 0 0 0 0 c 0 0 0 0 0 c 0 0 0 0 0 c c Properties: c c A is integral. c c A is Toeplitz: constant along diagonals. c c A is a Hankel matrix: constant along anti-diagonals. c c A is a circulant matrix: each row is shifted once to get the next row. c c A is an anticirculant matrix. c c A is singular. c c A is symmetric: A' = A. c c Because A is symmetric, it is normal. c c Because A is normal, it is diagonalizable. c c LAMBDA(1:N) = 0. c c The matrix of eigenvectors of A is I. c c det ( A ) = 0. c c For any vector v, A*v = 0. c c For any matrix B, A*B = B*A = 0. c c A is persymmetric: A(I,J) = A(N+1-J,N+1-I). c c The family of matrices is nested as a function of N. c c Licensing: c c This code is distributed under the GNU LGPL license. c c Modified: c c 12 June 2011 c c Author: c c John Burkardt c c Parameters: c c Input, integer M, N, the order of the matrix. c c Output, double precision A(M,N), the matrix. c implicit none integer m integer n double precision a(m,n) integer i integer j do j = 1, n do i = 1, m a(i,j) = 0.0D+00 end do end do return end subroutine zero_determinant ( n, determ ) c*********************************************************************72 c cc ZERO_DETERMINANT returns the determinant of the ZERO matrix. c c Licensing: c c This code is distributed under the GNU LGPL license. c c Modified: c c 12 June 2011 c c Author: c c John Burkardt c c Parameters: c c Input, integer N, the order of the matrix. c c Output, double precision DETERM, the determinant. c implicit none double precision determ integer n determ = 0.0D+00 return end subroutine zero_eigen_right ( n, a ) c*********************************************************************72 c cc ZERO_EIGEN_RIGHT returns right eigenvectors of the ZERO matrix. c c Licensing: c c This code is distributed under the GNU LGPL license. c c Modified: c c 26 November 2007 c c Author: c c John Burkardt c c Parameters: c c Input, integer N, the order of the matrix. c c Output, double precision A(N,N), the matrix. c implicit none integer n double precision a(n,n) integer i integer j do i = 1, n do j = 1, n if ( i .eq. j ) then a(i,j) = 1.0D+00 else a(i,j) = 0.0D+00 end if end do end do return end subroutine zero_eigenvalues ( n, lambda ) c*********************************************************************72 c cc ZERO_EIGENVALUES returns the eigenvalues of the ZERO matrix. c c Licensing: c c This code is distributed under the GNU LGPL license. c c Modified: c c 12 June 2011 c c Author: c c John Burkardt c c Parameters: c c Input, integer N, the order of the matrix. c c Output, double precision LAMBDA(N), the eigenvalues. c implicit none integer n integer i double precision lambda(n) do i = 1, n lambda(i) = 0.0D+00 end do return end subroutine zero_null_left ( m, n, x ) c*********************************************************************72 c cc ZERO_NULL_LEFT returns a left null vector of the ZERO matrix. c c Licensing: c c This code is distributed under the GNU LGPL license. c c Modified: c c 06 March 2015 c c Author: c c John Burkardt c c Parameters: c c Input, integer M, N, the order of the matrix. c c Output, double precision X(M), a null vector. c implicit none integer m integer n integer i double precision x(m) do i = 1, m x(i) = 1.0D+00 end do return end subroutine zero_null_right ( m, n, x ) c*********************************************************************72 c cc ZERO_NULL_RIGHT returns a right null vector of the ZERO matrix. c c Licensing: c c This code is distributed under the GNU LGPL license. c c Modified: c c 12 June 2011 c c Author: c c John Burkardt c c Parameters: c c Input, integer N, the order of the matrix. c c Output, double precision X(N), a null vector. c implicit none integer m integer n integer i double precision x(n) do i = 1, n x(i) = 1.0D+00 end do return end subroutine zielke ( n, x, y, z, a ) c*********************************************************************72 c cc ZIELKE returns the ZIELKE matrix. c c Formula: c c if ( I = J ) then c if ( I + J <= N ) c A(I,J) = X+Y+Z c else if ( I + J ) < 2*N ) c A(I,J) = X +Z c else c A(I,J) = X-Y+Z c else c if ( I + J <= N ) c A(I,J) = X+Y c else c A(I,J) = X c c Example: c c N = 5, X = 1, Y = 2, Z = 5 c c 8 3 3 3 1 c 3 8 3 1 1 c 3 3 6 1 1 c 3 1 1 6 1 c 1 1 1 1 4 c c Properties: c c A is symmetric: A' = A. c c Because A is symmetric, it is normal. c c Because A is normal, it is diagonalizable. c c There are clusters of eigenvalues. c c Licensing: c c This code is distributed under the GNU LGPL license. c c Modified: c c 17 August 2008 c c Author: c c John Burkardt c c Reference: c c Gerhard Zielke, c Testmatrizen mit maximaler Konditionszahl, c (Test matrices with maximal condition number), c Computing, c Volume 13, Number 1, March 1974, pages 33-54. c c Parameters: c c Input, integer N, the order of the matrix. c c Input, double precision X, Y, Z, parameters that define the matrix. c c Output, double precision A(N,N), the matrix. c implicit none integer n double precision a(n,n) integer i integer j double precision x double precision y double precision z do i = 1, n do j = 1, n if ( i .eq. j ) then if ( i + j .le. n ) then a(i,j) = x + y + z else if ( i + j .lt. 2 * n ) then a(i,j) = x + z else a(i,j) = x - y + z end if else if ( i + j .le. n ) then a(i,j) = x + y else a(i,j) = x end if end if end do end do return end