subroutine a123_matrix ( a ) !*****************************************************************************80 ! !! a123_matrix() returns the A123 matrix. ! ! Example: ! ! 1 2 3 ! 4 5 6 ! 7 8 9 ! ! Properties: ! ! A is integral. ! ! A is not symmetric. ! ! A is singular. ! ! Licensing: ! ! This code is distributed under the MIT license. ! ! Modified: ! ! 06 March 2015 ! ! Author: ! ! John Burkardt ! ! Output: ! ! real ( kind = rk ) A(3,3), the matrix. ! implicit none integer, parameter :: rk = kind ( 1.0D+00 ) real ( kind = rk ) 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) = real ( k, kind = rk ) end do end do return end subroutine a123_determinant ( value ) !*****************************************************************************80 ! !! a123_determinant() returns the determinant of the A123 matrix. ! ! Licensing: ! ! This code is distributed under the MIT license. ! ! Modified: ! ! 06 March 2015 ! ! Author: ! ! John Burkardt ! ! Output: ! ! real ( kind = rk ) VALUE, the determinant. ! implicit none integer, parameter :: rk = kind ( 1.0D+00 ) real ( kind = rk ) value value = 0.0D+00 return end subroutine a123_eigen_left ( a ) !*****************************************************************************80 ! !! a123_eigen_left() returns the left eigenvectors of the A123 matrix. ! ! Licensing: ! ! This code is distributed under the MIT license. ! ! Modified: ! ! 13 March 2015 ! ! Author: ! ! John Burkardt ! ! Output: ! ! real ( kind = rk ) A(3,3), the eigenvectors. ! implicit none integer, parameter :: rk = kind ( 1.0D+00 ) real ( kind = rk ) a(3,3) ! ! Note that the matrix entries are listed by column. ! real ( kind = rk ), dimension ( 3, 3 ), save :: a_save = reshape ( (/ & -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 /), (/ 3, 3 /) ) call r8mat_copy ( 3, 3, a_save, a ) return end subroutine a123_eigen_right ( a ) !*****************************************************************************80 ! !! a123_eigen_right() returns the right eigenvectors of the A123 matrix. ! ! Licensing: ! ! This code is distributed under the MIT license. ! ! Modified: ! ! 06 March 2015 ! ! Author: ! ! John Burkardt ! ! Output: ! ! real ( kind = rk ) A(3,3), the right eigenvector matrix. ! implicit none integer, parameter :: rk = kind ( 1.0D+00 ) real ( kind = rk ) a(3,3) ! ! Note that the matrix entries are listed by column. ! real ( kind = rk ), dimension ( 3, 3 ), save :: a_save = reshape ( (/ & -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 /), (/ 3, 3 /) ) call r8mat_copy ( 3, 3, a_save, a ) return end subroutine a123_eigenvalues ( lambda ) !*****************************************************************************80 ! !! a123_eigenvalues() returns the eigenvalues of the A123 matrix. ! ! Licensing: ! ! This code is distributed under the MIT license. ! ! Modified: ! ! 06 March 2015 ! ! Author: ! ! John Burkardt ! ! Output: ! ! real ( kind = rk ) LAMBDA(3), the eigenvalues. ! implicit none integer, parameter :: rk = kind ( 1.0D+00 ) real ( kind = rk ) lambda(3) real ( kind = rk ), dimension ( 3 ) :: lambda_save = (/ & 16.116843969807043D+00, -1.116843969807043D+00, 0.0D+00 /) call r8vec_copy ( 3, lambda_save, lambda ) return end subroutine a123_inverse ( b ) !*****************************************************************************80 ! !! a123_inverse() returns the pseudo-inverse of the A123 matrix. ! ! Example: ! ! -0.638888888888888 -0.166666666666666 0.305555555555555 ! -0.055555555555556 0.000000000000000 0.055555555555556 ! 0.527777777777777 0.166666666666666 -0.194444444444444 ! ! Licensing: ! ! This code is distributed under the MIT license. ! ! Modified: ! ! 06 March 2015 ! ! Author: ! ! John Burkardt ! ! Output: ! ! real ( kind = rk ) B(3,3), the matrix. ! implicit none integer, parameter :: rk = kind ( 1.0D+00 ) real ( kind = rk ) b(3,3) real ( kind = rk ), dimension ( 3, 3 ) :: b_save = reshape ( (/ & -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 /), & (/ 3, 3 /) ) call r8mat_copy ( 3, 3, b_save, b ) return end subroutine a123_null_left ( x ) !*****************************************************************************80 ! !! a123_null_left() returns a left null vector of the A123 matrix. ! ! Licensing: ! ! This code is distributed under the MIT license. ! ! Modified: ! ! 06 March 2015 ! ! Author: ! ! John Burkardt ! ! Output: ! ! real ( kind = rk ) X(3), a left null vector. ! implicit none integer, parameter :: rk = kind ( 1.0D+00 ) real ( kind = rk ) x(3) x(1) = 1.0D+00 x(2) = -2.0D+00 x(3) = 1.0D+00 return end subroutine a123_null_right ( x ) !*****************************************************************************80 ! !! a123_null_right() returns a right null vector of the A123 matrix. ! ! Licensing: ! ! This code is distributed under the MIT license. ! ! Modified: ! ! 06 March 2015 ! ! Author: ! ! John Burkardt ! ! Output: ! ! real ( kind = rk ) X(3), a right null vector. ! implicit none integer, parameter :: rk = kind ( 1.0D+00 ) real ( kind = rk ) 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 ) !*****************************************************************************80 ! !! a123_plu() returns the PLU factors of the A123 matrix. ! ! Licensing: ! ! This code is distributed under the MIT license. ! ! Modified: ! ! 06 March 2015 ! ! Author: ! ! John Burkardt ! ! Output: ! ! real ( kind = rk ) P(3,3), L(3,3), U(3,3), the PLU factors. ! implicit none integer, parameter :: rk = kind ( 1.0D+00 ) real ( kind = rk ) l(3,3) real ( kind = rk ), dimension (3,3), save :: l_save = reshape ( (/ & 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 /), & (/ 3, 3 /) ) real ( kind = rk ) p(3,3) real ( kind = rk ), dimension (3,3), save :: p_save = reshape ( (/ & 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 /), (/ 3, 3 /) ) real ( kind = rk ) u(3,3) real ( kind = rk ), dimension (3,3), save :: u_save = reshape ( (/ & 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 /), & (/ 3, 3 /) ) 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 ) !*****************************************************************************80 ! !! a123_qr() returns the QR factors of the A123 matrix. ! ! Licensing: ! ! This code is distributed under the MIT license. ! ! Modified: ! ! 06 March 2015 ! ! Author: ! ! John Burkardt ! ! Output: ! ! real ( kind = rk ) Q(3,3), R(3,3), the QR factors. ! implicit none integer, parameter :: rk = kind ( 1.0D+00 ) real ( kind = rk ) q(3,3) real ( kind = rk ), dimension (3,3), save :: q_save = reshape ( (/ & -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 /), & (/ 3, 3 /) ) real ( kind = rk ) r(3,3) real ( kind = rk ), dimension (3,3), save :: r_save = reshape ( (/ & -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 /), & (/ 3, 3 /) ) call r8mat_copy ( 3, 3, q_save, q ) call r8mat_copy ( 3, 3, r_save, r ) return end subroutine a123_rhs ( b ) !*****************************************************************************80 ! !! a123_rhs() returns the A123 right hand side. ! ! Licensing: ! ! This code is distributed under the MIT license. ! ! Modified: ! ! 08 March 2015 ! ! Author: ! ! John Burkardt ! ! Output: ! ! real ( kind = rk ) B(3), the vector. ! implicit none integer, parameter :: rk = kind ( 1.0D+00 ) real ( kind = rk ) b(3) real ( kind = rk ), dimension ( 3 ), save :: b_save = (/ & 10.0D+00, 28.0D+00, 46.0D+00 /) call r8vec_copy ( 3, b_save, b ) return end subroutine a123_solution ( x ) !*****************************************************************************80 ! !! a123_solution() returns the A123 solution vector. ! ! Licensing: ! ! This code is distributed under the MIT license. ! ! Modified: ! ! 08 March 2015 ! ! Author: ! ! John Burkardt ! ! Output: ! ! real ( kind = rk ) X(3), the solution. ! implicit none integer, parameter :: rk = kind ( 1.0D+00 ) real ( kind = rk ) x(3) real ( kind = rk ), dimension ( 3 ), save :: 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 ) !*****************************************************************************80 ! !! a123_svd() returns the SVD factors of the A123 matrix. ! ! Licensing: ! ! This code is distributed under the MIT license. ! ! Modified: ! ! 06 March 2015 ! ! Author: ! ! John Burkardt ! ! Output: ! ! real ( kind = rk ) U(3,3), S(3,3), V(3,3), the SVD factors. ! implicit none integer, parameter :: rk = kind ( 1.0D+00 ) real ( kind = rk ) s(3,3) real ( kind = rk ), dimension (3,3), save :: s_save = reshape ( (/ & 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 /), & (/ 3, 3 /) ) real ( kind = rk ) u(3,3) real ( kind = rk ), dimension (3,3), save :: u_save = reshape ( (/ & -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 /), & (/ 3, 3 /) ) real ( kind = rk ) v(3,3) real ( kind = rk ), dimension (3,3), save :: v_save = reshape ( (/ & -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 /),& (/ 3, 3 /) ) 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_matrix ( n, a ) !*****************************************************************************80 ! !! aegerter_matrix() returns the AEGERTER matrix. ! ! Formula: ! ! if ( I == N ) ! A(I,J) = J ! else if ( J == N ) ! A(I,J) = I ! else if ( I == J ) ! A(I,J) = 1 ! else ! A(I,J) = 0 ! ! Example: ! ! N = 5 ! ! 1 0 0 0 1 ! 0 1 0 0 2 ! 0 0 1 0 3 ! 0 0 0 1 4 ! 1 2 3 4 5 ! ! Properties: ! ! A is integral, therefore det ( A ) is integral, and ! det ( A ) * inverse ( A ) is integral. ! ! A is symmetric: A' = A. ! ! Because A is symmetric, it is normal. ! ! Because A is normal, it is diagonalizable. ! ! A is border-banded. ! ! det ( A ) = N * ( - 2 * N * N + 3 * N + 5 ) / 6 ! ! A has N-2 eigenvalues equal to 1. ! ! The other two eigenvalues are ! ! ( N + 1 + sqrt ( ( N + 1 )^2 - 4 * det ( A ) ) ) / 2 ! ( N + 1 - sqrt ( ( N + 1 )^2 - 4 * det ( A ) ) ) / 2 ! ! Licensing: ! ! This code is distributed under the MIT license. ! ! Modified: ! ! 09 September 2006 ! ! Author: ! ! John Burkardt ! ! Reference: ! ! MJ Aegerter, ! Construction of a Set of Test Matrices, ! Communications of the ACM, ! Volume 2, Number 8, August 1959, pages 10-12. ! ! Input: ! ! integer N, the order of the matrix. ! ! Output: ! ! real ( kind = rk ) A(N,N), the matrix. ! implicit none integer, parameter :: rk = kind ( 1.0D+00 ) integer n real ( kind = rk ) a(n,n) integer i integer j do j = 1, n do i = 1, n if ( i == n ) then a(i,j) = real ( j, kind = rk ) else if ( j == n ) then a(i,j) = real ( i, kind = rk ) else if ( i == 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 ) !*****************************************************************************80 ! !! aegerter_condition(): L1 condition of the AEGERTER matrix. ! ! Licensing: ! ! This code is distributed under the MIT license. ! ! Modified: ! ! 31 March 2012 ! ! Author: ! ! John Burkardt ! ! Input: ! ! integer N, the order of the matrix. ! ! Output: ! ! real ( kind = rk ) COND, the L1 condition number. ! implicit none integer, parameter :: rk = kind ( 1.0D+00 ) integer n real ( kind = rk ) a_norm real ( kind = rk ) b(n,n) real ( kind = rk ) b_norm real ( kind = rk ) cond real ( kind = rk ) r8mat_norm_l1 a_norm = real ( ( ( n + 1 ) * n ) / 2, kind = rk ) call aegerter_inverse ( n, b ) b_norm = r8mat_norm_l1 ( n, n, b ) cond = a_norm * b_norm return end subroutine aegerter_determinant ( n, value ) !*****************************************************************************80 ! !! aegerter_determinant() returns the determinant of the AEGERTER matrix. ! ! Licensing: ! ! This code is distributed under the MIT license. ! ! Modified: ! ! 13 October 2007 ! ! Author: ! ! John Burkardt ! ! Input: ! ! integer N, the order of the matrix. ! ! Output: ! ! real ( kind = rk ) VALUE, the determinant. ! implicit none integer, parameter :: rk = kind ( 1.0D+00 ) integer n real ( kind = rk ) value value = real ( n - ( ( n - 1 ) * n * ( 2 * n - 1 ) ) / 6, kind = rk ) return end subroutine aegerter_eigenvalues ( n, lambda ) !*****************************************************************************80 ! !! aegerter_eigenvalues() returns the eigenvalues of the AEGERTER matrix. ! ! Licensing: ! ! This code is distributed under the MIT license. ! ! Modified: ! ! 16 October 2007 ! ! Author: ! ! John Burkardt ! ! Input: ! ! integer N, the order of the matrix. ! ! Output: ! ! real ( kind = rk ) LAMBDA(N), the eigenvalues. ! implicit none integer, parameter :: rk = kind ( 1.0D+00 ) integer n real ( kind = rk ) determ real ( kind = rk ) lambda(n) real ( kind = rk ) np1 determ = real ( n - ( ( n - 1 ) * n * ( 2 * n - 1 ) ) / 6, kind = rk ) np1 = real ( n + 1, kind = rk ) lambda(1) = 0.5D+00 * ( np1 - sqrt ( np1 * np1 - 4.0D+00 * determ ) ) lambda(2:n-1) = 1.0D+00 lambda(n) = 0.5D+00 * ( np1 + sqrt ( np1 * np1 - 4.0D+00 * determ ) ) return end subroutine aegerter_inverse ( n, a ) !*****************************************************************************80 ! !! aegerter_inverse() returns the inverse of the AEGERTER matrix. ! ! Example: ! ! N = 5 ! ! 0.9600 -0.0800 -0.1200 -0.1600 0.0400 ! -0.0800 0.8400 -0.2400 -0.3200 0.0800 ! -0.1200 -0.2400 0.6400 -0.4800 0.1200 ! -0.1600 -0.3200 -0.4800 0.3600 0.1600 ! 0.0400 0.0800 0.1200 0.1600 -0.0400 ! ! Licensing: ! ! This code is distributed under the MIT license. ! ! Modified: ! ! 20 October 2006 ! ! Author: ! ! John Burkardt ! ! Input: ! ! integer N, the order of the matrix. ! ! Output: ! ! real ( kind = rk ) A(N,N), the matrix. ! implicit none integer, parameter :: rk = kind ( 1.0D+00 ) integer n real ( kind = rk ) a(n,n) integer i integer j do i = 1, n - 1 do j = 1, n - 1 if ( i == j ) then a(i,j) = 1.0D+00 - real ( i * j, kind = rk ) / real ( n * n, kind = rk ) else a(i,j) = - real ( i * j, kind = rk ) / real ( n * n, kind = rk ) end if end do end do do i = 1, n - 1 a(i,n) = real ( i, kind = rk ) / real ( n * n, kind = rk ) end do do j = 1, n - 1 a(n,j) = real ( j, kind = rk ) / real ( n * n, kind = rk ) end do a(n,n) = - 1.0D+00 / real ( n * n, kind = rk ) return end subroutine anticirculant_matrix ( m, n, x, a ) !*****************************************************************************80 ! !! anticirculant_matrix() returns an ANTICIRCULANT matrix. ! ! Formula: ! ! K = 1 + mod ( J + I - 2, N ) ! A(I,J) = X(K) ! ! Example: ! ! M = 4, N = 5, X = ( 1, 2, 3, 4, 5 ) ! ! 1 2 3 4 5 ! 2 3 4 5 1 ! 3 4 5 1 2 ! 4 5 1 2 3 ! ! M = 5, N = 4, X = ( 1, 2, 3, 4 ) ! ! 1 2 3 4 ! 2 3 4 5 ! 3 4 5 1 ! 4 5 1 2 ! 1 2 3 4 ! ! Properties: ! ! A is a special Hankel matrix in which the diagonals "wrap around". ! ! A is symmetric: A' = A. ! ! A is integral, therefore det ( A ) is integral, and ! det ( A ) * inverse ( A ) is integral. ! ! Because A is symmetric, it is normal. ! ! Because A is normal, it is diagonalizable. ! ! Licensing: ! ! This code is distributed under the MIT license. ! ! Modified: ! ! 01 July 2000 ! ! Author: ! ! John Burkardt ! ! Input: ! ! integer M, N, the order of the matrix. ! ! real ( kind = rk ) X(N), the vector that defines A. ! ! Output: ! ! real ( kind = rk ) A(M,N), the matrix. ! implicit none integer, parameter :: rk = kind ( 1.0D+00 ) integer m integer n real ( kind = rk ) a(m,n) integer i integer j integer k real ( kind = rk ) 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, value ) !*****************************************************************************80 ! !! anticirculant_determinant(): the determinant of the ANTICIRCULANT matrix. ! ! Licensing: ! ! This code is distributed under the MIT license. ! ! Modified: ! ! 23 November 2007 ! ! Author: ! ! John Burkardt ! ! Input: ! ! integer N, the order of the matrix. ! ! real ( kind = rk ) X(N), the values in the first row of A. ! ! Output: ! ! real ( kind = rk ) VALUE, the determinant. ! implicit none integer, parameter :: rk = kind ( 1.0D+00 ) integer, parameter :: ck = kind ( ( 1.0D+00, 1.0D+00 ) ) integer n integer i complex ( kind = ck ) lambda(n) real ( kind = rk ) r8_mop real ( kind = rk ) value complex ( kind = ck ) w(n) real ( kind = rk ) x(n) call c8vec_unity ( n, w ) lambda(1:n) = cmplx ( x(n), 0.0D+00, kind = ck ) do i = n - 1, 1, -1 lambda(1:n) = lambda(1:n) * w(1:n) + cmplx ( x(i), 0.0D+00, kind = ck ) end do ! ! First eigenvalue is "special". ! value = real ( lambda(1), kind = rk ) ! ! Eigenvalues 2, 3 through ( N + 1 ) / 2 are paired with complex conjugates. ! do i = 2, ( n + 1 ) / 2 value = value * ( abs ( lambda(i) ) ) ** 2 end do ! ! If N is even, there is another unpaired eigenvalue. ! if ( mod ( n, 2 ) == 0 ) then value = value * real ( lambda((n/2)+1), kind = rk ) end if ! ! This is actually the determinant of the CIRCULANT matrix. ! We have to perform ( N - 1 ) / 2 row interchanges to get ! to the anticirculant matrix. ! value = r8_mop ( ( n - 1 ) / 2 ) * value return end subroutine antihadamard_matrix ( n, a ) !*****************************************************************************80 ! !! antihadamard_matrix() returns an approximate ANTIHADAMARD matrix. ! ! Discussion: ! ! An Anti-Hadamard matrix is one whose elements are all 0 or 1, ! and for which the Frobenius norm of the inverse is as large as ! possible. This routine returns a matrix for which the Frobenius norm ! of the inverse is large, though not necessarily maximal. ! ! Formula: ! ! if ( I = J ) ! A(I,J) = 1 ! else if ( I < J and mod ( I + J, 2 ) = 1 ) ! A(I,J) = 1 ! else ! A(I,J) = 0 ! ! Example: ! ! N = 5 ! ! 1 1 0 1 0 ! 0 1 1 0 1 ! 0 0 1 1 0 ! 0 0 0 1 1 ! 0 0 0 0 1 ! ! Properties: ! ! A is generally not symmetric: A' /= A. ! ! A is Toeplitz: constant along diagonals. ! ! A is upper triangular. ! ! A is integral, therefore det ( A ) is integral, and ! det ( A ) * inverse ( A ) is integral. ! ! A is a zero-one matrix. ! ! det ( A ) = 1. ! ! A is unimodular. ! ! LAMBDA(1:N) = 1. ! ! Licensing: ! ! This code is distributed under the MIT license. ! ! Modified: ! ! 15 April 1999 ! ! Author: ! ! John Burkardt ! ! Reference: ! ! Ronald Graham, Neal Sloane, ! Anti-Hadamard Matrices, ! Linear Algebra and Applications, ! Volume 62, November 1984, pages 113-137. ! ! Input: ! ! integer N, the order of the matrix. ! ! Output: ! ! real ( kind = rk ) A(N,N), the matrix. ! implicit none integer, parameter :: rk = kind ( 1.0D+00 ) integer n real ( kind = rk ) a(n,n) integer i integer j do j = 1, n do i = 1, n if ( j < i ) then a(i,j) = 0.0D+00 else if ( i == j ) then a(i,j) = 1.0D+00 else if ( mod ( i + j, 2 ) == 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, value ) !*****************************************************************************80 ! !! antihadamard_determinant() returns the determinant of the ANTIHADAMARD matrix. ! ! Licensing: ! ! This code is distributed under the MIT license. ! ! Modified: ! ! 11 October 2007 ! ! Author: ! ! John Burkardt ! ! Input: ! ! integer N, the order of the matrix. ! ! Output: ! ! real ( kind = rk ) VALUE, the determinant. ! implicit none integer, parameter :: rk = kind ( 1.0D+00 ) integer n real ( kind = rk ) value call i4_fake_use ( n ) value = 1.0D+00 return end subroutine antisummation_condition ( n, cond ) !*****************************************************************************80 ! !! antisummation_condition() returns the L1 condition of the ANTISUMMATION matrix. ! ! Licensing: ! ! This code is distributed under the MIT license. ! ! Modified: ! ! 13 October 2022 ! ! Author: ! ! John Burkardt ! ! Input: ! ! integer N, the order of the matrix. ! ! Output: ! ! real ( kind = rk ) COND, the L1 condition number. ! implicit none integer, parameter :: rk = kind ( 1.0D+00 ) integer i integer n real ( kind = rk ) cond real ( kind = rk ) norm_A real ( kind = rk ) norm_inv real ( kind = rk ) twoi norm_A = n norm_inv = 1.0D+00 twoi = 1.0 do i = 0, n - 2 norm_inv = norm_inv + twoi twoi = twoi * 2.0D+00 end do cond = norm_A * norm_inv return end subroutine antisummation_determinant ( n, determ ) !*****************************************************************************80 ! !! antisummation_determinant() returns the determinant of the ANTISUMMATION matrix. ! ! Licensing: ! ! This code is distributed under the MIT license. ! ! Modified: ! ! 13 October 2022 ! ! Author: ! ! John Burkardt ! ! Input: ! ! integer N, the order of the matrix. ! ! Output: ! ! real ( kind = rk ) DETERM, the determinant. ! implicit none integer, parameter :: rk = kind ( 1.0D+00 ) real ( kind = rk ) determ integer n call i4_fake_use ( n ) determ = 1.0D+00 return end subroutine antisummation_inverse ( n, a ) !*****************************************************************************80 ! !! antisummation_inverse() returns the inverse of the ANTISUMMATION matrix. ! ! Example: ! ! N = 5 ! ! 1 0 0 0 0 ! 1 1 0 0 0 ! 2 1 1 0 0 ! 4 2 1 1 0 ! 8 4 2 1 1 ! ! Properties: ! ! A is lower triangular. ! ! A is Toeplitz: constant along diagonals. ! ! A is nonsingular. ! ! det ( A ) = 1. ! ! A is the inverse of the antisummation matrix. ! ! Licensing: ! ! This code is distributed under the MIT license. ! ! Modified: ! ! 13 October 2022 ! ! Author: ! ! John Burkardt ! ! Input: ! ! integer N, the order of the matrix. ! ! Output: ! ! real ( kind = rk ) A(N,N), the matrix. ! implicit none integer, parameter :: rk = kind ( 1.0D+00 ) integer n real ( kind = rk ) a(n,n) integer i integer j do j = 1, n do i = 1, n if ( i == j ) then a(i,j) = 1.0D+00 else if ( j < i ) then a(i,j) = 2.0 ** ( i - j - 1 ) else a(i,j) = 0.0D+00 end if end do end do return end subroutine antisummation_matrix ( m, n, a ) !*****************************************************************************80 ! !! antisummation_matrix() returns the ANTISUMMATION matrix. ! ! Example: ! ! M = 5, N = 5 ! ! 1 0 0 0 0 ! -1 1 0 0 0 ! -1 -1 1 0 0 ! -1 -1 -1 1 0 ! -1 -1 -1 -1 1 ! ! Properties: ! ! A is generally not symmetric: A' /= A. ! ! A is lower triangular. ! ! A is Toeplitz: constant along diagonals. ! ! A is nonsingular. ! ! det ( A ) = 1. ! ! A is the Cholesky factor of the MOLER3 matrix. ! ! Licensing: ! ! This code is distributed under the MIT license. ! ! Modified: ! ! 13 October 2022 ! ! Author: ! ! John Burkardt ! ! Reference: ! ! Nick Higham, ! Seven Sins of Numerical Linear Algebra, ! https://nhigham.com/2022/10/11/seven-sins-of-numerical-linear-algebra/ ! ! Input: ! ! integer M, N, the order of the matrix. ! ! Output: ! ! real ( kind = rk ) A(M,N), the matrix. ! implicit none integer, parameter :: rk = kind ( 1.0D+00 ) integer m integer n real ( kind = rk ) a(m,n) integer i integer j do j = 1, n do i = 1, m if ( j == i ) then a(i,j) = 1.0D+00 else if ( j < i ) then a(i,j) = -1.0D+00 else a(i,j) = 0.0D+00 end if end do end do return end subroutine antisymmetric_random_matrix ( n, key, a ) !*****************************************************************************80 ! !! antisymmetric_random_matrix() returns a random ANTISYMMETRIC matrix. ! ! Example: ! ! N = 5 ! ! 0.0000 -0.1096 0.0813 0.9248 -0.0793 ! 0.1096 0.0000 0.1830 0.1502 0.8244 ! -0.0813 -0.1830 0.0000 0.0899 -0.2137 ! -0.9248 -0.1502 -0.0899 0.0000 -0.4804 ! 0.0793 -0.8244 0.2137 0.4804 0.0000 ! ! Properties: ! ! A is generally not symmetric: A' /= A. ! ! A is antisymmetric: A' = -A. ! ! Because A is antisymmetric, it is normal. ! ! Because A is normal, it is diagonalizable. ! ! The diagonal of A is zero. ! ! All the eigenvalues of A are imaginary. ! ! if N is odd, then det ( A ) = 0. ! ! Licensing: ! ! This code is distributed under the MIT license. ! ! Modified: ! ! 25 March 2015 ! ! Author: ! ! John Burkardt ! ! Input: ! ! integer N, the order of the matrix. ! ! integer KEY, a positive integer that selects the data. ! ! Output: ! ! real ( kind = rk ) A(N,N), the matrix. ! implicit none integer, parameter :: rk = kind ( 1.0D+00 ) integer n real ( kind = rk ) a(n,n) integer i integer j integer key real ( kind = rk ) r8_hi real ( kind = rk ) r8_lo real ( kind = rk ) r8_uniform_ab call random_seed_initialize ( key ) do i = 1, n a(i,i) = 0.0D+00 end do r8_lo = -1.0D+00 r8_hi = +1.0D+00 do i = 1, n do j = i + 1, n a(i,j) = r8_uniform_ab ( r8_lo, r8_hi ) a(j,i) = - a(i,j) end do end do return end subroutine archimedes_matrix ( a ) !*****************************************************************************80 ! !! archimedes_matrix() returns the ARCHIMEDES matrix. ! ! Example: ! ! 6 -5 0 -6 0 0 0 0 ! 0 20 -9 -20 0 0 0 0 ! -13 0 42 -42 0 0 0 0 ! 0 -7 0 0 12 -7 0 0 ! 0 0 -9 0 0 20 -9 0 ! 0 0 0 -11 0 0 30 -11 ! -13 0 0 0 -13 0 0 42 ! ! Discussion: ! ! "The sun god had a herd of cattle, consisting of bulls and cows, ! one part of which was white, a second black, a third spotted, and ! a fourth brown. Among the bulls, the number of white ones was ! one half plus one third the number of the black greater than ! the brown; the number of the black, one quarter plus one fifth ! the number of the spotted greater than the brown; the number of ! the spotted, one sixth and one seventh the number of the white ! greater than the brown. Among the cows, the number of white ones ! was one third plus one quarter of the total black cattle; the number ! of the black, one quarter plus one fifth the total of the spotted ! cattle; the number of spotted, one fifth plus one sixth the total ! of the brown cattle; the number of the brown, one sixth plus one ! seventh the total of the white cattle. What was the composition ! of the herd?" ! ! The 7 relations involving the 8 numbers W, X, Y, Z, w, x, y, z, ! have the form: ! ! W = ( 5/ 6) * X + Z ! X = ( 9/20) * Y + Z ! Y = (13/42) * W + Z ! w = ( 7/12) * ( X + x ) ! x = ( 9/20) * ( Y + y ) ! y = (11/30) * ( Z + z ) ! z = (13/42) * ( W + w ) ! ! These equations may be multiplied through to an integral form ! that is embodied in the above matrix. ! ! A more complicated second part of the problem imposes additional ! constraints (W+X must be square, Y+Z must be a triangular number). ! ! Properties: ! ! A is integral: int ( A ) = A. ! ! A has full row rank. ! ! It is desired to know a solution X in positive integers of ! ! A * X = 0. ! ! The null space of A is spanned by multiples of the null vector: ! ! [ 10,366,482 ] ! [ 7,460,514 ] ! [ 7,358,060 ] ! [ 4,149,387 ] ! [ 7,206,360 ] ! [ 4,893,246 ] ! [ 3,515,820 ] ! [ 5,439,213 ] ! ! and this is the smallest positive integer solution of the ! equation A * X = 0. ! ! Thus, for the "simple" part of Archimedes's problem, the total number ! of cattle of the Sun is 50,389,082. ! ! Licensing: ! ! This code is distributed under the MIT license. ! ! Modified: ! ! 14 August 2008 ! ! Author: ! ! John Burkardt ! ! Reference: ! ! Eric Weisstein, ! CRC Concise Encyclopedia of Mathematics, ! CRC Press, 2002, ! Second edition, ! ISBN: 1584883472, ! LC: QA5.W45 ! ! Output: ! ! real ( kind = rk ) A(7,8), the matrix. ! implicit none integer, parameter :: rk = kind ( 1.0D+00 ) real ( kind = rk ) a(7,8) ! ! Note that the matrix entries are listed by column. ! real ( kind = rk ), dimension ( 7, 8 ), save :: a_save = reshape ( (/ & 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 & /), (/ 7, 8 /) ) call r8mat_copy ( 7, 8, a_save, a ) return end subroutine archimedes_null_right ( x ) !*****************************************************************************80 ! !! archimedes_null_right() returns a right null vector for the ARCHIMEDES matrix. ! ! Licensing: ! ! This code is distributed under the MIT license. ! ! Modified: ! ! 04 November 2007 ! ! Author: ! ! John Burkardt ! ! Output: ! ! real ( kind = rk ) X(8), the null vector. ! implicit none integer, parameter :: rk = kind ( 1.0D+00 ) real ( kind = rk ) x(8) real ( kind = rk ), dimension ( 8 ), save :: 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_matrix ( n, alpha, beta, a ) !*****************************************************************************80 ! !! bab_matrix() returns the BAB matrix. ! ! Discussion: ! ! The name is meant to suggest the pattern "B A B" formed by ! the nonzero entries in a general row of the matrix. ! ! Example: ! ! N = 5, ALPHA = 5, BETA = 2 ! ! 5 2 . . . ! 2 5 2 . . ! . 2 5 2 . ! . . 2 5 2 ! . . . 2 5 ! ! Properties: ! ! A is banded, with bandwidth 3. ! ! A is tridiagonal. ! ! Because A is tridiagonal, it has property A (bipartite). ! ! A is Toeplitz: constant along diagonals. ! ! A is symmetric: A' = A. ! ! Because A is symmetric, it is normal. ! ! Because A is normal, it is diagonalizable. ! ! A is persymmetric: A(I,J) = A(N+1-J,N+1-I). ! ! The family of matrices is nested as a function of N. ! ! Licensing: ! ! This code is distributed under the MIT license. ! ! Modified: ! ! 05 November 2007 ! ! Author: ! ! John Burkardt ! ! Reference: ! ! CM da Fonseca, J Petronilho, ! Explicit Inverses of Some Tridiagonal Matrices, ! Linear Algebra and Its Applications, ! Volume 325, 2001, pages 7-21. ! ! Input: ! ! integer N, the order of the matrix. ! ! real ( kind = rk ) ALPHA, BETA, the parameters. ! ! Output: ! ! real ( kind = rk ) A(N,N), the matrix. ! implicit none integer, parameter :: rk = kind ( 1.0D+00 ) integer n real ( kind = rk ) a(n,n) real ( kind = rk ) alpha real ( kind = rk ) beta integer i a(1:n,1:n) = 0.0D+00 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 ) !*****************************************************************************80 ! !! bab_condition() returns the L1 condition of the BAB matrix. ! ! Licensing: ! ! This code is distributed under the MIT license. ! ! Modified: ! ! 08 April 2012 ! ! Author: ! ! John Burkardt ! ! Input: ! ! integer N, the order of the matrix. ! ! real ( kind = rk ) ALPHA, BETA, the parameters. ! ! Output: ! ! real ( kind = rk ) COND, the L1 condition number. ! implicit none integer, parameter :: rk = kind ( 1.0D+00 ) integer n real ( kind = rk ) a_norm real ( kind = rk ) alpha real ( kind = rk ) b(n,n) real ( kind = rk ) b_norm real ( kind = rk ) beta real ( kind = rk ) cond real ( kind = rk ) r8mat_norm_l1 if ( n == 1 ) then a_norm = abs ( alpha ) else if ( n == 2 ) then a_norm = abs ( alpha ) + abs ( beta ) else a_norm = abs ( alpha ) + 2.0D+00 * abs ( beta ) end if 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, value ) !*****************************************************************************80 ! !! bab_determinant() returns the determinant of the BAB matrix. ! ! Licensing: ! ! This code is distributed under the MIT license. ! ! Modified: ! ! 05 November 2007 ! ! Author: ! ! John Burkardt ! ! Input: ! ! integer N, the order of the matrix. ! ! real ( kind = rk ) ALPHA, BETA, the parameters. ! ! Output: ! ! real ( kind = rk ) VALUE, the determinant. ! implicit none integer, parameter :: rk = kind ( 1.0D+00 ) integer n real ( kind = rk ) alpha real ( kind = rk ) beta real ( kind = rk ) determ real ( kind = rk ) determ_nm1 real ( kind = rk ) determ_nm2 integer i real ( kind = rk ) value determ_nm1 = alpha if ( n == 1 ) then value = determ_nm1 return end if determ_nm2 = determ_nm1 determ_nm1 = alpha * alpha - beta * beta if ( n == 2 ) then value = 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 value = determ return end subroutine bab_eigen_right ( n, alpha, beta, a ) !*****************************************************************************80 ! !! bab_eigen_right() returns the right eigenvectors of the BAB matrix. ! ! Discussion: ! ! Note that all symmetric tridiagonal Toeplitz matrices have the ! same eigenvectors. ! ! Licensing: ! ! This code is distributed under the MIT license. ! ! Modified: ! ! 04 April 2015 ! ! Author: ! ! John Burkardt ! ! Input: ! ! integer N, the order of the matrix. ! ! real ( kind = rk ) ALPHA, BETA, the parameters. ! ! Output: ! ! real ( kind = rk ) A(N,N), the right eigenvector matrix. ! implicit none integer, parameter :: rk = kind ( 1.0D+00 ) integer n real ( kind = rk ) a(n,n) real ( kind = rk ) alpha real ( kind = rk ) angle real ( kind = rk ) beta integer i integer j real ( kind = rk ), parameter :: r8_pi = 3.141592653589793D+00 call r8_fake_use ( alpha ) call r8_fake_use ( beta ) do j = 1, n do i = 1, n angle = real ( i * j, kind = rk ) * r8_pi / real ( n + 1, kind = rk ) a(i,j) = sqrt ( 2.0D+00 / real ( n + 1, kind = rk ) ) * sin ( angle ) end do end do return end subroutine bab_eigenvalues ( n, alpha, beta, lambda ) !*****************************************************************************80 ! !! bab_eigenvalues() returns the eigenvalues of the BAB matrix. ! ! Licensing: ! ! This code is distributed under the MIT license. ! ! Modified: ! ! 29 May 2008 ! ! Author: ! ! John Burkardt ! ! Input: ! ! integer N, the order of the matrix. ! ! real ( kind = rk ) ALPHA, BETA, the parameters. ! ! Output: ! ! real ( kind = rk ) LAMBDA(N), the eigenvalues. ! implicit none integer, parameter :: rk = kind ( 1.0D+00 ) integer n real ( kind = rk ) alpha real ( kind = rk ) angle real ( kind = rk ) beta integer i real ( kind = rk ) lambda(n) real ( kind = rk ), parameter :: r8_pi = 3.141592653589793D+00 do i = 1, n angle = real ( i, kind = rk ) * r8_pi / real ( n + 1, kind = rk ) lambda(i) = alpha + 2.0D+00 * beta * cos ( angle ) end do return end subroutine bab_inverse ( n, alpha, beta, a ) !*****************************************************************************80 ! !! bab_inverse() returns the inverse of the BAB matrix. ! ! Example: ! ! N = 5, ALPHA = 5.0, BETA = 2.0 ! ! 0.2498 -0.1245 0.0615 -0.0293 0.0117 ! -0.1245 0.3114 -0.1538 0.0733 -0.0293 ! 0.0615 -0.1538 0.3231 -0.1538 0.0615 ! -0.0293 0.0733 -0.1538 0.3114 -0.1245 ! 0.0117 -0.0293 0.0615 -0.1245 0.2498 ! ! Licensing: ! ! This code is distributed under the MIT license. ! ! Modified: ! ! 08 November 2007 ! ! Author: ! ! John Burkardt ! ! Input: ! ! integer N, the order of the matrix. ! ! real ( kind = rk ) ALPHA, BETA, the parameters. ! ! Output: ! ! real ( kind = rk ) A(N,N), the matrix. ! implicit none integer, parameter :: rk = kind ( 1.0D+00 ) integer n real ( kind = rk ) a(n,n) real ( kind = rk ) alpha real ( kind = rk ) beta integer i integer j real ( kind = rk ) r8_mop real ( kind = rk ) u(0:n) real ( kind = rk ) x if ( beta == 0.0D+00 ) then if ( alpha == 0.0D+00 ) then write ( *, '(a)' ) ' ' write ( *, '(a)' ) 'BAB_INVERSE - Fatal error!' write ( *, '(a)' ) ' ALPHA = BETA = 0.' stop 1 end if a(1:n,1:n) = 0.0D+00 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 ) !*****************************************************************************80 ! !! balanc() balances a real matrix before eigenvalue calculations. ! ! Discussion: ! ! This subroutine balances a real matrix and isolates eigenvalues ! whenever possible. ! ! Suppose that the principal submatrix in rows LOW through IGH ! has been balanced, that P(J) denotes the index interchanged ! with J during the permutation step, and that the elements ! of the diagonal matrix used are denoted by D(I,J). Then ! ! SCALE(J) = P(J), J = 1,...,LOW-1, ! = D(J,J), J = LOW,...,IGH, ! = P(J) J = IGH+1,...,N. ! ! The order in which the interchanges are made is N to IGH+1, ! then 1 to LOW-1. ! ! Note that 1 is returned for LOW if IGH is zero formally. ! ! Licensing: ! ! This code is distributed under the MIT license. ! ! Modified: ! ! 20 March 2002 ! ! Author: ! ! FORTRAN90 version by John Burkardt. ! ! Reference: ! ! James Wilkinson, Christian Reinsch, ! Handbook for Automatic Computation, ! Volume II, Linear Algebra, Part 2, ! Springer, 1971, ! ISBN: 0387054146, ! LC: QA251.W67. ! ! Brian Smith, James Boyle, Jack Dongarra, Burton Garbow, ! Yasuhiko Ikebe, Virginia Klema, Cleve Moler, ! Matrix Eigensystem Routines, EISPACK Guide, ! Lecture Notes in Computer Science, Volume 6, ! Springer, 1976, ! ISBN13: 978-3540075462, ! LC: QA193.M37. ! ! Input: ! ! integer NM, the leading dimension of A, which must ! be at least N. ! ! integer N, the order of the matrix. ! ! real ( kind = rk ) A(NM,N), the matrix to be balanced. ! ! Output: ! ! real ( kind = rk ) A(NM,N), the balanced matrix. ! ! integer LOW, IGH, indicate that A(I,J) ! is equal to zero if ! (1) I is greater than J and ! (2) J=1,...,LOW-1 or I=IGH+1,...,N. ! ! real ( kind = rk ) SCALE(N), contains information determining the ! permutations and scaling factors used. ! implicit none integer, parameter :: rk = kind ( 1.0D+00 ) integer nm integer n real ( kind = rk ) a(nm,n) real ( kind = rk ) b2 real ( kind = rk ) c real ( kind = rk ) f real ( kind = rk ) g integer i integer iexc integer igh integer j integer k integer l integer low integer m logical noconv real ( kind = rk ) r real ( kind = rk ) radix real ( kind = rk ) s real ( kind = rk ) scale(n) real ( kind = rk ) t radix = 16.0D+00 iexc = 0 j = 0 m = 0 b2 = radix * radix k = 1 l = n go to 100 20 continue scale(m) = j if ( j /= m ) then do i = 1, l t = a(i,j) a(i,j) = a(i,m) a(i,m) = t end do do i = k, n t = a(j,i) a(j,i) = a(m,i) a(m,i) = t end do end if if ( iexc == 2 ) then go to 130 end if ! ! Search for rows isolating an eigenvalue and push them down. ! if ( l == 1 ) then low = k igh = l return end if l = l - 1 100 continue do j = l, 1, -1 do i = 1, l if ( i /= j ) then if ( a(j,i) /= 0.0D+00 ) then go to 120 end if end if end do m = l iexc = 1 go to 20 120 continue end do go to 140 ! ! Search for columns isolating an eigenvalue and push them left. ! 130 continue k = k + 1 140 continue do j = k, l do i = k, l if ( i /= j ) then if ( a(i,j) /= 0.0D+00 ) then go to 170 end if end if end do m = k iexc = 2 go to 20 170 continue end do ! ! Balance the submatrix in rows K to L. ! scale(k:l) = 1.0D+00 ! ! Iterative loop for norm reduction. ! noconv = .true. do while ( noconv ) noconv = .false. do i = k, l c = 0.0D+00 r = 0.0D+00 do j = k, l if ( j /= i ) then c = c + abs ( a(j,i) ) r = r + abs ( a(i,j) ) end if end do ! ! Guard against zero C or R due to underflow. ! if ( c /= 0.0D+00 .and. r /= 0.0D+00 ) then g = r / radix f = 1.0D+00 s = c + r do while ( c < g ) f = f * radix c = c * b2 end do g = r * radix do while ( g <= c ) f = f / radix c = c / b2 end do ! ! Balance. ! if ( ( c + r ) / f < 0.95D+00 * s ) then g = 1.0D+00 / f scale(i) = scale(i) * f noconv = .true. a(i,k:n) = a(i,k:n) * g a(1:l,i) = a(1:l,i) * f end if end if end do end do low = k igh = l return end subroutine bauer_matrix ( a ) !*****************************************************************************80 ! !! bauer_matrix() returns the BAUER matrix. ! ! Example: ! ! -74 80 18 -11 -4 -8 ! 14 -69 21 28 0 7 ! 66 -72 -5 7 1 4 ! -12 66 -30 -23 3 -3 ! 3 8 -7 -4 1 0 ! 4 -12 4 4 0 1 ! ! Properties: ! ! The matrix is integral. ! ! The inverse matrix is integral. ! ! The matrix is ill-conditioned. ! ! The determinant is 1. ! ! Licensing: ! ! This code is distributed under the MIT license. ! ! Modified: ! ! 26 March 2015 ! ! Author: ! ! John Burkardt ! ! Reference: ! ! Virginia Klema, Alan Laub, ! The Singular Value Decomposition: Its Computation and Some Applications, ! IEEE Transactions on Automatic Control, ! Volume 25, Number 2, April 1980. ! ! Output: ! ! real ( kind = rk ) A(6,6), the matrix. ! implicit none integer, parameter :: rk = kind ( 1.0D+00 ) integer, parameter :: n = 6 real ( kind = rk ) a(n,n) ! ! Note that the matrix entries are listed by column. ! real ( kind = rk ), dimension ( n, n ) :: a_save = reshape ( (/ & -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 /),& (/ n, n /) ) a(1:n,1:n) = a_save(1:n,1:n) return end subroutine bauer_condition ( value ) !*****************************************************************************80 ! !! bauer_condition() returns the L1 condition of the BAUER matrix. ! ! Licensing: ! ! This code is distributed under the MIT license. ! ! Modified: ! ! 26 March 2015 ! ! Author: ! ! John Burkardt ! ! Output: ! ! real ( kind = rk ) VALUE, the L1 condition. ! implicit none integer, parameter :: rk = kind ( 1.0D+00 ) real ( kind = rk ) a_norm real ( kind = rk ) b_norm real ( kind = rk ) value a_norm = 307.0D+00 b_norm = 27781.0D+00 value = a_norm * b_norm return end subroutine bauer_determinant ( value ) !*****************************************************************************80 ! !! bauer_determinant() returns the determinant of the BAUER matrix. ! ! Licensing: ! ! This code is distributed under the MIT license. ! ! Modified: ! ! 26 March 2015 ! ! Author: ! ! John Burkardt ! ! Output: ! ! real ( kind = rk ) VALUE, the determinant. ! implicit none integer, parameter :: rk = kind ( 1.0D+00 ) real ( kind = rk ) value value = 1.0D+00 return end subroutine bauer_inverse ( a ) !*****************************************************************************80 ! !! bauer_inverse() returns the inverse of the BAUER matrix. ! ! Licensing: ! ! This code is distributed under the MIT license. ! ! Modified: ! ! 26 March 2015 ! ! Author: ! ! John Burkardt ! ! Output: ! ! real ( kind = rk ) A(6,6), the matrix. ! implicit none integer, parameter :: rk = kind ( 1.0D+00 ) integer, parameter :: n = 6 real ( kind = rk ) a(n,n) ! ! Note that the matrix entries are listed by column. ! real ( kind = rk ), dimension ( n, n ) :: a_save = reshape ( (/ & 1.0D+00, 0.0D+00, -2.0D+00, & 15.0D+00, 43.0D+00, -56.0D+00, & 0.0D+00, 1.0D+00, 2.0D+00, & -12.0D+00, -42.0D+00, 52.0D+00, & -7.0D+00, 7.0D+00, 29.0D+00, & -192.0D+00, -600.0D+00, 764.0D+00, & -40.0D+00, 35.0D+00, 155.0D+00, & -1034.0D+00, -3211.0D+00, 4096.0D+00, & 131.0D+00, -112.0D+00, -502.0D+00, & 3354.0D+00, 10406.0D+00, -13276.0D+00, & -84.0D+00, 70.0D+00, 319.0D+00, & -2130.0D+00, -6595.0D+00, 8421.0D+00 /) , & (/ 6, 6 /) ) a(1:n,1:n) = a_save(1:n,1:n) return end subroutine bernstein_condition ( n, value ) !*****************************************************************************80 ! !! bernstein_condition() returns the L1 condition of the BERNSTEIN matrix. ! ! Licensing: ! ! This code is distributed under the MIT license. ! ! Modified: ! ! 04 November 2021 ! ! Author: ! ! John Burkardt ! ! Input: ! ! integer N, the order of the matrix. ! ! Output: ! ! real ( kind = rk ) VALUE, the L1 condition number. ! implicit none integer, parameter :: rk = kind ( 1.0D+00 ) integer n real ( kind = rk ) A(n,n) real ( kind = rk ) anorm real ( kind = rk ) B(n,n) real ( kind = rk ) bnorm real ( kind = rk ) r8mat_norm_l1 real ( kind = rk ) value call bernstein_matrix ( n, A ) anorm = r8mat_norm_l1 ( n, n, A ) call bernstein_inverse ( n, B ) bnorm = r8mat_norm_l1 ( n, n, B ) value = anorm * bnorm return end subroutine bernstein_determinant ( n, value ) !*****************************************************************************80 ! !! bernstein_determinant() returns the determinant of the BERNSTEIN matrix. ! ! Licensing: ! ! This code is distributed under the MIT license. ! ! Modified: ! ! 13 March 2015 ! ! Author: ! ! John Burkardt ! ! Input: ! ! integer N, the order of the matrix. ! ! Output: ! ! real ( kind = rk ) VALUE, the determinant. ! implicit none integer, parameter :: rk = kind ( 1.0D+00 ) integer i integer n real ( kind = rk ) r8_choose real ( kind = rk ) 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 ) !*****************************************************************************80 ! !! bernstein_inverse() returns the inverse BERNSTEIN matrix. ! ! Discussion: ! ! The inverse Bernstein matrix of order N is an NxN matrix A which can ! be used to transform a vector of Bernstein basis coefficients B ! representing a polynomial P(X) to a corresponding power basis ! coefficient vector C: ! ! C = A * B ! ! The N power basis vectors are ordered as (1,X,X^2,...X^(N-1)) and the N ! Bernstein basis vectors as ((1-X)^(N-1), X*(1-X)^(N-2),...,X^(N-1)). ! ! Example: ! ! N = 5 ! ! 1.0000 1.0000 1.0000 1.0000 1.0000 ! 0 0.2500 0.5000 0.7500 1.0000 ! 0 0 0.1667 0.5000 1.0000 ! 0 0 0 0.2500 1.0000 ! 0 0 0 0 1.0000 ! ! Licensing: ! ! This code is distributed under the MIT license. ! ! Modified: ! ! 10 July 2011 ! ! Author: ! ! John Burkardt ! ! Input: ! ! integer N, the order of the matrix. ! ! Output: ! ! real ( kind = rk ) A(N,N), the inverse matrix. ! implicit none integer, parameter :: rk = kind ( 1.0D+00 ) integer n real ( kind = rk ) a(n,n) integer i0 integer j0 integer n0 real ( kind = rk ) r8_choose a(1:n,1:n) = 0.0D+00 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 bernstein_matrix ( n, a ) !*****************************************************************************80 ! !! bernstein_matrix() returns the BERNSTEIN matrix. ! ! Discussion: ! ! The Bernstein matrix of order N is an NxN matrix A which can be used to ! transform a vector of power basis coefficients C representing a polynomial ! P(X) to a corresponding Bernstein basis coefficient vector B: ! ! B = A * C ! ! The N power basis vectors are ordered as (1,X,X^2,...X^(N-1)) and the N ! Bernstein basis vectors as ((1-X)^(N-1), X*(1_X)^(N-2),...,X^(N-1)). ! ! Example: ! ! N = 5 ! ! 1 -4 6 -4 1 ! 0 4 -12 12 -4 ! 0 0 6 -12 6 ! 0 0 0 4 -4 ! 0 0 0 0 1 ! ! Licensing: ! ! This code is distributed under the MIT license. ! ! Modified: ! ! 10 July 2011 ! ! Author: ! ! John Burkardt ! ! Input: ! ! integer N, the order of the matrix. ! ! Output: ! ! real ( kind = rk ) A(N,N), the Bernstein matrix. ! implicit none integer, parameter :: rk = kind ( 1.0D+00 ) integer n real ( kind = rk ) a(n,n) integer i0 integer j0 integer n0 real ( kind = rk ) r8_choose real ( kind = rk ) r8_mop a(1:n,1:n) = 0.0D+00 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_poly_01 ( n, x, bern ) !*****************************************************************************80 ! !! bernstein_poly_01() evaluates the Bernstein polynomials based in [0,1]. ! ! Discussion: ! ! The Bernstein polynomials are assumed to be based on [0,1]. ! ! The formula is: ! ! B(N,I)(X) = [N!/(I!*(N-I)!)] * (1-X)^(N-I) * X^I ! ! First values: ! ! B(0,0)(X) = 1 ! ! B(1,0)(X) = 1-X ! B(1,1)(X) = X ! ! B(2,0)(X) = (1-X)^2 ! B(2,1)(X) = 2 * (1-X) * X ! B(2,2)(X) = X^2 ! ! B(3,0)(X) = (1-X)^3 ! B(3,1)(X) = 3 * (1-X)^2 * X ! B(3,2)(X) = 3 * (1-X) * X^2 ! B(3,3)(X) = X^3 ! ! B(4,0)(X) = (1-X)^4 ! B(4,1)(X) = 4 * (1-X)^3 * X ! B(4,2)(X) = 6 * (1-X)^2 * X^2 ! B(4,3)(X) = 4 * (1-X) * X^3 ! B(4,4)(X) = X^4 ! ! Special values: ! ! B(N,I)(X) has a unique maximum value at X = I/N. ! ! B(N,I)(X) has an I-fold zero at 0 and and N-I fold zero at 1. ! ! B(N,I)(1/2) = C(N,K) / 2^N ! ! For a fixed X and N, the polynomials add up to 1: ! ! Sum ( 0 <= I <= N ) B(N,I)(X) = 1 ! ! Licensing: ! ! This code is distributed under the MIT license. ! ! Modified: ! ! 14 April 1999 ! ! Author: ! ! John Burkardt ! ! Input: ! ! integer N, the degree of the Bernstein polynomials ! to be used. For any N, there is a set of N+1 Bernstein polynomials, ! each of degree N, which form a basis for polynomials on [0,1]. ! ! real ( kind = rk ) X, the evaluation point. ! ! Output: ! ! real ( kind = rk ) BERN(0:N), the values of the N+1 ! Bernstein polynomials at X. ! implicit none integer, parameter :: rk = kind ( 1.0D+00 ) integer n real ( kind = rk ) bern(0:n) integer i integer j real ( kind = rk ) x if ( n == 0 ) then bern(0) = 1.0D+00 else if ( 0 < n ) then bern(0) = 1.0D+00 - x bern(1) = x do i = 2, n bern(i) = x * bern(i-1) do j = i - 1, 1, -1 bern(j) = x * bern(j-1) & + ( 1.0D+00 - x ) * bern(j) end do bern(0) = ( 1.0D+00 - x ) * bern(0) end do end if return end subroutine bernstein_vandermonde_matrix ( n, v ) !*****************************************************************************80 ! !! bernstein_vandermonde_matrix() returns the Bernstein Vandermonde matrix. ! ! Discussion: ! ! The Bernstein Vandermonde matrix of order N is constructed by ! evaluating the N Bernstein polynomials of degree N-1 at N equally ! spaced points between 0 and 1. ! ! Licensing: ! ! This code is distributed under the MIT license. ! ! Modified: ! ! 03 December 2015 ! ! Author: ! ! John Burkardt ! ! Input: ! ! integer N, the order of the matrix. ! ! Output: ! ! real ( kind = rk ) A(N,N), the Bernstein Vandermonde matrix. ! implicit none integer, parameter :: rk = kind ( 1.0D+00 ) integer n real ( kind = rk ) b(n) integer i real ( kind = rk ) v(n,n) real ( kind = rk ) x if ( n == 1 ) then v(1,1) = 1.0D+00 return end if do i = 1, n x = real ( i - 1, kind = rk ) / real ( n - 1, kind = rk ) call bernstein_poly_01 ( n - 1, x, b ); v(i,1:n) = b(1:n) end do return end subroutine bimarkov_random_matrix ( n, key, a ) !*****************************************************************************80 ! !! bimarkov_random_matrix() returns a random BIMARKOV matrix. ! ! Discussion: ! ! A Bimarkov matrix is also known as a doubly stochastic matrix. ! ! Example: ! ! N = 5 ! ! 1/5 1/5 1/5 1/5 1/5 ! 1/2 1/2 0 0 0 ! 1/6 1/6 2/3 0 0 ! 1/12 1/12 1/12 3/4 0 ! 1/20 1/20 1/20 1/20 4/5 ! ! Properties: ! ! A is generally not symmetric: A' /= A. ! ! 0 <= A(I,J) <= 1.0D+00 for every I and J. ! ! A has constant row sum 1. ! ! Because it has a constant row sum of 1, ! A has an eigenvalue of 1 ! and a right eigenvector of ( 1, 1, 1, ..., 1 ). ! ! A has constant column sum 1. ! ! Because it has a constant column sum of 1, ! A has an eigenvalue of 1 ! and a left eigenvector of ( 1, 1, 1, ..., 1 ). ! ! All the eigenvalues of A have modulus 1. ! ! The eigenvalue 1 lies on the boundary of all the Gershgorin ! row or column sum disks. ! ! Every doubly stochastic matrix is a combination ! A = w1 * P1 + w2 * P2 + ... + wk * Pk ! of permutation matrices, with positive weights w that sum to 1. ! (Birkhoff's theorem, see Horn and Johnson.) ! ! A is a Markov matrix. ! ! A is a transition matrix. ! ! Licensing: ! ! This code is distributed under the MIT license. ! ! Modified: ! ! 24 May 2006 ! ! Author: ! ! John Burkardt ! ! Reference: ! ! Roger Horn, Charles Johnson, ! Matrix Analysis, ! Cambridge, 1985, ! ISBN: 0-521-38632-2, ! LC: QA188.H66. ! ! Input: ! ! integer N, the order of the matrix. ! ! integer KEY, a positive integer that selects the data. ! ! Output: ! ! real ( kind = rk ) A(N,N), the matrix. ! implicit none integer, parameter :: rk = kind ( 1.0D+00 ) integer n real ( kind = rk ) a(n,n) integer key ! ! Get a random orthogonal matrix. ! call orthogonal_random_matrix ( n, key, a ) ! ! Square each entry. ! a(1:n,1:n) = a(1:n,1:n) ** 2 return end subroutine bis_condition ( alpha, beta, n, cond ) !*****************************************************************************80 ! !! bis_condition() returns the L1 condition of the BIS matrix. ! ! Licensing: ! ! This code is distributed under the MIT license. ! ! Modified: ! ! 19 January 2015 ! ! Author: ! ! John Burkardt ! ! Input: ! ! real ( kind = rk ) ALPHA, BETA, the scalars which define the ! diagonal and first superdiagonal of the matrix. ! ! integer N, the order of the matrix. ! ! Output: ! ! real ( kind = rk ) COND, the L1 condition of the matrix. ! implicit none integer, parameter :: rk = kind ( 1.0D+00 ) integer n real ( kind = rk ) a_norm real ( kind = rk ) alpha real ( kind = rk ) b_norm real ( kind = rk ) ba real ( kind = rk ) beta real ( kind = rk ) 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 ) !*****************************************************************************80 ! !! bis_determinant() returns the determinant of the BIS matrix. ! ! Licensing: ! ! This code is distributed under the MIT license. ! ! Modified: ! ! 21 May 2002 ! ! Author: ! ! John Burkardt ! ! Input: ! ! real ( kind = rk ) ALPHA, BETA, the scalars which define the ! diagonal and first superdiagonal of the matrix. ! ! integer N, the order of the matrix. ! ! Output: ! ! real ( kind = rk ) DETERM, the determinant of the matrix. ! implicit none integer, parameter :: rk = kind ( 1.0D+00 ) integer n real ( kind = rk ) alpha real ( kind = rk ) beta real ( kind = rk ) determ call r8_fake_use ( beta ) determ = alpha ** n return end subroutine bis_eigenvalues ( alpha, beta, n, lambda ) !*****************************************************************************80 ! !! bis_eigenvalues() returns the eigenvalues of the BIS matrix. ! ! Licensing: ! ! This code is distributed under the MIT license. ! ! Modified: ! ! 21 May 2002 ! ! Author: ! ! John Burkardt ! ! Input: ! ! real ( kind = rk ) ALPHA, BETA, the scalars which define the ! diagonal and first superdiagonal of the matrix. ! ! integer N, the order of the matrix. ! ! Output: ! ! real ( kind = rk ) LAMBDA(N), the eigenvalues of the matrix. ! implicit none integer, parameter :: rk = kind ( 1.0D+00 ) integer n real ( kind = rk ) alpha real ( kind = rk ) beta real ( kind = rk ) lambda(n) call r8_fake_use ( beta ) lambda(1:n) = alpha return end subroutine bis_inverse ( alpha, beta, n, a ) !*****************************************************************************80 ! !! bis_inverse() returns the inverse of the BIS matrix. ! ! Formula: ! ! if ( I <= J ) ! A(I,J) = (-BETA)^(J-I) / ALPHA^(J+1-I) ! else ! A(I,J) = 0 ! ! Example: ! ! N = 4, ALPHA = 7.0, BETA = 2.0 ! ! 0.1429 -0.0408 0.0117 -0.0033 ! 0 0.1429 -0.0408 0.0117 ! 0 0 0.1429 -0.0408 ! 0 0 0 0.1429 ! ! Properties: ! ! A is generally not symmetric: A' /= A. ! ! A is upper triangular ! ! A is Toeplitz: constant along diagonals. ! ! A is persymmetric: A(I,J) = A(N+1-J,N+1-I). ! ! det ( A ) = (1/ALPHA)^N. ! ! LAMBDA(1:N) = 1 / ALPHA. ! ! The family of matrices is nested as a function of N. ! ! Licensing: ! ! This code is distributed under the MIT license. ! ! Modified: ! ! 15 April 1999 ! ! Author: ! ! John Burkardt ! ! Input: ! ! real ( kind = rk ) ALPHA, BETA, the scalars which define the ! diagonal and first superdiagonal of the matrix. ! ! integer N, the order of the matrix. ! ! Output: ! ! real ( kind = rk ) A(N,N), the matrix. ! implicit none integer, parameter :: rk = kind ( 1.0D+00 ) integer n real ( kind = rk ) a(n,n) real ( kind = rk ) alpha real ( kind = rk ) beta integer i integer j if ( alpha == 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 <= 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 bis_matrix ( alpha, beta, m, n, a ) !*****************************************************************************80 ! !! bis_matrix() returns the BIS matrix. ! ! Discussion: ! ! The BIS matrix is a bidiagonal scalar matrix. ! ! Formula: ! ! if ( I = J ) ! A(I,J) = ALPHA ! else if ( J = I + 1 ) ! A(I,J) = BETA ! else ! A(I,J) = 0 ! ! Example: ! ! ALPHA = 7, BETA = 2, M = 5, N = 4 ! ! 7 2 0 0 ! 0 7 2 0 ! 0 0 7 2 ! 0 0 0 7 ! 0 0 0 0 ! ! Properties: ! ! A is bidiagonal. ! ! Because A is bidiagonal, it has property A (bipartite). ! ! A is upper triangular. ! ! A is banded with bandwidth 2. ! ! A is Toeplitz: constant along diagonals. ! ! A is generally not symmetric: A' /= A. ! ! A is nonsingular if and only if ALPHA is nonzero. ! ! det ( A ) = ALPHA^N. ! ! LAMBDA(1:N) = ALPHA. ! ! A is persymmetric: A(I,J) = A(N+1-J,N+1-I). ! ! The INTEGRATION matrix is a special case of the BIS matrix. ! The JORDAN matrix is a special case of the BIS matrix. ! ! The family of matrices is nested as a function of N. ! ! Licensing: ! ! This code is distributed under the MIT license. ! ! Modified: ! ! 01 July 2000 ! ! Author: ! ! John Burkardt ! ! Input: ! ! real ( kind = rk ) ALPHA, BETA, the scalars which define the ! diagonal and first superdiagonal of the matrix. ! ! integer M, N, the order of the matrix. ! ! Output: ! ! real ( kind = rk ) A(M,N), the matrix. ! implicit none integer, parameter :: rk = kind ( 1.0D+00 ) integer m integer n real ( kind = rk ) a(m,n) real ( kind = rk ) alpha real ( kind = rk ) beta integer i integer j do j = 1, n do i = 1, m if ( j == i ) then a(i,j) = alpha else if ( j == i + 1 ) then a(i,j) = beta else a(i,j) = 0.0D+00 end if end do end do return end subroutine biw_condition ( n, value ) !*****************************************************************************80 ! !! biw_condition() computes the L1 condition of the BIW matrix. ! ! Licensing: ! ! This code is distributed under the MIT license. ! ! Modified: ! ! 11 April 2015 ! ! Author: ! ! John Burkardt ! ! Input: ! ! integer N, the order of the matrix. ! ! Output: ! ! real ( kind = rk ) VALUE, the L1 condition. ! implicit none integer, parameter :: rk = kind ( 1.0D+00 ) real ( kind = rk ) a_norm real ( kind = rk ) aii real ( kind = rk ) b_norm real ( kind = rk ) bij integer i integer j integer n real ( kind = rk ) value if ( n == 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 + real ( i, kind = rk ) / real ( 10 * n, kind = rk ) if ( i == j ) then bij = 1.0D+00 / aii else if ( i < 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 ) !*****************************************************************************80 ! !! biw_determinant() computes the determinant of the BIW matrix. ! ! Licensing: ! ! This code is distributed under the MIT license. ! ! Modified: ! ! 29 March 2015 ! ! Author: ! ! John Burkardt ! ! Input: ! ! integer N, the order of the matrix. ! ! Output: ! ! real ( kind = rk ) VALUE, the determinant. ! implicit none integer, parameter :: rk = kind ( 1.0D+00 ) integer n integer i real ( kind = rk ) value value = 1.0D+00 do i = 1, n value = value & * ( 0.5D+00 + real ( i, kind = rk ) / real ( 10 * n, kind = rk ) ) end do return end subroutine biw_inverse ( n, b ) !*****************************************************************************80 ! !! biw_inverse() returns the inverse of the BIW matrix. ! ! Example: ! ! N = 5 ! ! 1.9231 3.5613 6.3594 10.9645 18.2741 ! 0 1.8519 3.3069 5.7015 9.5025 ! 0 0 1.7857 3.0788 5.1314 ! 0 0 0 1.7241 2.8736 ! 0 0 0 0 1.6667 ! ! Licensing: ! ! This code is distributed under the MIT license. ! ! Modified: ! ! 25 March 2015 ! ! Author: ! ! John Burkardt ! ! Input: ! ! integer N, the order of the matrix. ! ! Output: ! ! real ( kind = rk ) B(N,N), the matrix. ! implicit none integer, parameter :: rk = kind ( 1.0D+00 ) integer n real ( kind = rk ) aii real ( kind = rk ) aiip1 real ( kind = rk ) b(n,n) integer i integer j do j = n, 1, -1 do i = n, 1, -1 aii = 0.5D+00 + real ( i, kind = rk ) / real ( 10 * n, kind = rk ) aiip1 = -1.0D+00 if ( i == j ) then b(i,j) = 1.0D+00 / aii else if ( i < 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 biw_matrix ( n, a ) !*****************************************************************************80 ! !! biw_matrix() returns the BIW matrix. ! ! Discussion: ! ! BIW is a bidiagonal matrix of Wilkinson. Originally, this matrix ! was considered for N = 100. ! ! Formula: ! ! if ( I == J ) ! A(I,J) = 0.5 + I / ( 10 * N ) ! else if ( J == I+1 ) ! A(I,J) = -1.0 ! else ! A(I,J) = 0 ! ! Example: ! ! N = 5 ! ! 0.52 -1.00 0.00 0.00 0.00 ! 0.00 0.54 -1.00 0.00 0.00 ! 0.00 0.00 0.56 -1.00 0.00 ! 0.00 0.00 0.00 0.58 -1.00 ! 0.00 0.00 0.00 0.00 0.60 ! ! Licensing: ! ! This code is distributed under the MIT license. ! ! Modified: ! ! 29 March 2015 ! ! Author: ! ! John Burkardt ! ! Input: ! ! integer N, the order of the matrix. ! ! Output: ! ! real ( kind = rk ) A(N,N), the matrix. ! implicit none integer, parameter :: rk = kind ( 1.0D+00 ) integer n real ( kind = rk ) a(n,n) integer i a(1:n,1:n) = 0.0D+00 do i = 1, n a(i,i) = 0.5D+00 + real ( i, kind = rk ) / real ( 10 * n, kind = rk ) end do do i = 1, n - 1 a(i,i+1) = - 1.0D+00 end do return end subroutine bodewig_condition ( cond ) !*****************************************************************************80 ! !! bodewig_condition() returns the L1 condition of the BODEWIG matrix. ! ! Licensing: ! ! This code is distributed under the MIT license. ! ! Modified: ! ! 08 April 2012 ! ! Author: ! ! John Burkardt ! ! Output: ! ! real ( kind = rk ) COND, the L1 condition. ! implicit none integer, parameter :: rk = kind ( 1.0D+00 ) real ( kind = rk ) cond cond = 10.436619718309862D+00 return end subroutine bodewig_determinant ( determ ) !*****************************************************************************80 ! !! bodewig_determinant() returns the determinant of the BODEWIG matrix. ! ! Licensing: ! ! This code is distributed under the MIT license. ! ! Modified: ! ! 13 October 2007 ! ! Author: ! ! John Burkardt ! ! Output: ! ! real ( kind = rk ) DETERM, the determinant. ! implicit none integer, parameter :: rk = kind ( 1.0D+00 ) real ( kind = rk ) determ determ = 568.0D+00 return end subroutine bodewig_eigen_right ( a ) !*****************************************************************************80 ! !! bodewig_eigen_right() returns the right eigenvectors of the BODEWIG matrix. ! ! Licensing: ! ! This code is distributed under the MIT license. ! ! Modified: ! ! 01 June 2008 ! ! Author: ! ! John Burkardt ! ! Output: ! ! real ( kind = rk ) A(4,4), the right eigenvector matrix. ! implicit none integer, parameter :: rk = kind ( 1.0D+00 ) real ( kind = rk ) a(4,4) ! ! Note that the matrix entries are listed by column. ! real ( kind = rk ), dimension ( 4, 4 ), save :: a_save = reshape ( (/ & 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 & /), (/ 4, 4 /) ) call r8mat_copy ( 4, 4, a_save, a ) return end subroutine bodewig_eigenvalues ( lambda ) !*****************************************************************************80 ! !! bodewig_eigenvalues() returns the eigenvalues of the BODEWIG matrix. ! ! Licensing: ! ! This code is distributed under the MIT license. ! ! Modified: ! ! 25 November 2007 ! ! Author: ! ! John Burkardt ! ! Output: ! ! real ( kind = rk ) LAMBDA(4), the eigenvalues. ! implicit none integer, parameter :: rk = kind ( 1.0D+00 ) real ( kind = rk ) lambda(4) real ( kind = rk ), dimension ( 4 ), save :: 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 ) !*****************************************************************************80 ! !! bodewig_inverse() returns the inverse of the BODEWIG matrix. ! ! Example: ! ! -139 165 79 111 ! 165 -155 -57 -1 ! 79 -57 45 -59 ! 111 -1 -59 -11 ! ! Licensing: ! ! This code is distributed under the MIT license. ! ! Modified: ! ! 13 October 2007 ! ! Author: ! ! John Burkardt ! ! Output: ! ! real ( kind = rk ) A(4,4), the matrix. ! implicit none integer, parameter :: rk = kind ( 1.0D+00 ) real ( kind = rk ) a(4,4) ! ! Note that the matrix entries are listed by column. ! real ( kind = rk ), dimension ( 4, 4 ), save :: a_save = reshape ( (/ & -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 & /), (/ 4, 4 /) ) call r8mat_copy ( 4, 4, a_save, a ) a(1:4,1:4) = a(1:4,1:4) / 568.0D+00 return end subroutine bodewig_lu ( l, u ) !*****************************************************************************80 ! !! bodewig_lu() returns the LU factors of the BODEWIG matrix. ! ! Licensing: ! ! This code is distributed under the MIT license. ! ! Modified: ! ! 04 November 2021 ! ! Author: ! ! John Burkardt ! ! Output: ! ! real ( kind = rk ) L(4,4), U(4,4), the factors. ! implicit none integer, parameter :: rk = kind ( 1.0D+00 ) integer, parameter :: n = 4 real ( kind = rk ) l(n,n) real ( kind = rk ), dimension ( n, n ), save :: l_save = reshape ( (/ & 1.00D+00, 0.00D+00, 0.00D+00, 0.00D+00, & 0.50D+00, 1.00D+00, 0.00D+00, 0.00D+00, & 1.50D+00, 0.142857142857143D+00, 1.00D+00, 0.00D+00, & 2.00D+00, -0.857142857142857D+00, -5.363636363636364D+00, 1.00D+00 /), & (/ n, n /) ) real ( kind = rk ) u(n,n) real ( kind = rk ), dimension ( n, n ), save :: u_save = reshape ( (/ & 2.00D+00, 1.00D+00, 3.00D+00, 4.00D+00, & 0.00D+00, -3.50D+00, -0.50D+00, 3.00D+00, & 0.00D+00, 0.00D+00, 1.571428571428571D+00, -8.428571428571429D+00, & 0.00D+00, 0.00D+00, 0.00D+00, -51.6363636363636478D+00 /), & (/ n, n /) ) l = transpose ( l_save ) u = transpose ( u_save ) return end subroutine bodewig_matrix ( a ) !*****************************************************************************80 ! !! bodewig_matrix() returns the BODEWIG matrix. ! ! Example: ! ! 2 1 3 4 ! 1 -3 1 5 ! 3 1 6 -2 ! 4 5 -2 -1 ! ! Properties: ! ! A is integral, therefore det ( A ) is integral, and ! det ( A ) * inverse ( A ) is integral. ! ! A is symmetric: A' = A. ! ! det ( A ) = 568. ! ! Licensing: ! ! This code is distributed under the MIT license. ! ! Modified: ! ! 23 May 2002 ! ! Author: ! ! John Burkardt ! ! Reference: ! ! Joan Westlake, ! A Handbook of Numerical Matrix Inversion and Solution of ! Linear Equations, ! John Wiley, 1968, ! ISBN13: 978-0471936756, ! LC: QA263.W47. ! ! Output: ! ! real ( kind = rk ) A(4,4), the matrix. ! implicit none integer, parameter :: rk = kind ( 1.0D+00 ) real ( kind = rk ) a(4,4) ! ! Note that the matrix entries are listed by column. ! real ( kind = rk ), dimension ( 4, 4 ), save :: a_save = reshape ( (/ & 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 & /), (/ 4, 4 /) ) call r8mat_copy ( 4, 4, a_save, a ) return end subroutine bodewig_plu ( p, l, u ) !*****************************************************************************80 ! !! bodewig_plu() returns the PLU factors of the BODEWIG matrix. ! ! Licensing: ! ! This code is distributed under the MIT license. ! ! Modified: ! ! 26 June 2011 ! ! Author: ! ! John Burkardt ! ! Output: ! ! real ( kind = rk ) P(4,4), L(4,4), U(4,4), the PLU factors. ! implicit none integer, parameter :: rk = kind ( 1.0D+00 ) real ( kind = rk ) l(4,4) real ( kind = rk ), dimension ( 4, 4 ), save :: l_save = reshape ( (/ & 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 /), & (/ 4, 4 /) ) real ( kind = rk ) p(4,4) real ( kind = rk ), dimension ( 4, 4 ), save :: p_save = reshape ( (/ & 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 /), (/ 4, 4 /) ) real ( kind = rk ) u(4,4) real ( kind = rk ), dimension ( 4, 4 ), save :: u_save = reshape ( (/ & 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 /), & (/ 4, 4 /) ) 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 ) !*****************************************************************************80 ! !! bodewig_rhs() returns the BODEWIG right hand side. ! ! Licensing: ! ! This code is distributed under the MIT license. ! ! Modified: ! ! 27 November 2007 ! ! Author: ! ! John Burkardt ! ! Output: ! ! real ( kind = rk ) B(4), the right hand side vector. ! implicit none integer, parameter :: rk = kind ( 1.0D+00 ) real ( kind = rk ) b(4) real ( kind = rk ), dimension ( 4 ), save :: 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_solution ( x ) !*****************************************************************************80 ! !! bodewig_solution() returns the BODEWIG solution vector. ! ! Licensing: ! ! This code is distributed under the MIT license. ! ! Modified: ! ! 27 November 2007 ! ! Author: ! ! John Burkardt ! ! Output: ! ! real ( kind = rk ) X(4), the solution. ! implicit none integer, parameter :: rk = kind ( 1.0D+00 ) real ( kind = rk ) x(4) real ( kind = rk ), dimension ( 4 ), save :: 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_condition ( n, value ) !*****************************************************************************80 ! !! boothroyd_condition() returns the L1 condition of the BOOTHROYD matrix. ! ! Licensing: ! ! This code is distributed under the MIT license. ! ! Modified: ! ! 03 April 2015 ! ! Author: ! ! John Burkardt ! ! Input: ! ! integer N, the order of the matrix. ! ! Output: ! ! real ( kind = rk ) VALUE, the L1 condition. ! implicit none integer, parameter :: rk = kind ( 1.0D+00 ) real ( kind = rk ) a_norm real ( kind = rk ) b_norm integer i integer j integer n real ( kind = rk ) r8_choose real ( kind = rk ) s real ( kind = rk ) 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 ) & * real ( n, kind = rk ) / real ( i + j - 1, kind = rk ) 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 ) !*****************************************************************************80 ! !! boothroyd_determinant() returns the determinant of the BOOTHROYD matrix. ! ! Licensing: ! ! This code is distributed under the MIT license. ! ! Modified: ! ! 14 October 2007 ! ! Author: ! ! John Burkardt ! ! Input: ! ! integer N, the order of the matrix. ! ! Output: ! ! real ( kind = rk ) VALUE, the determinant. ! implicit none integer, parameter :: rk = kind ( 1.0D+00 ) integer n real ( kind = rk ) value call i4_fake_use ( n ) value = 1.0D+00 return end subroutine boothroyd_inverse ( n, a ) !*****************************************************************************80 ! !! boothroyd_inverse() returns the inverse of the BOOTHROYD matrix. ! ! Example: ! ! N = 5 ! ! 5 -10 10 -5 1 ! -15 40 -45 24 -5 ! 35 -105 126 -70 15 ! -70 224 -280 160 -35 ! 126 -420 540 -315 70 ! ! Licensing: ! ! This code is distributed under the MIT license. ! ! Modified: ! ! 02 June 2008 ! ! Author: ! ! John Burkardt ! ! Input: ! ! integer N, the order of the matrix. ! ! Output: ! ! real ( kind = rk ) A(N,N), the matrix. ! implicit none integer, parameter :: rk = kind ( 1.0D+00 ) integer n real ( kind = rk ) a(n,n) integer i integer j real ( kind = rk ) r8_choose real ( kind = rk ) 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 ) & * real ( n, kind = rk ) / real ( i + j - 1, kind = rk ) end do end do return end subroutine boothroyd_matrix ( n, a ) !*****************************************************************************80 ! !! boothroyd_matrix() returns the BOOTHROYD matrix. ! ! Formula: ! ! A(I,J) = C(N+I-1,I-1) * C(N-1,N-J) * N / ( I + J - 1 ) ! ! Example: ! ! N = 5 ! ! 5 10 10 5 1 ! 15 40 45 24 5 ! 35 105 126 70 15 ! 70 224 280 160 35 ! 126 420 540 315 70 ! ! Properties: ! ! A is not symmetric. ! ! A is positive definite. ! ! det ( A ) = 1. ! ! The eigenvalues are real, and come in pairs whose product is 1. ! When N is odd, there is one unpaired eigenvalue equal to 1. ! ! The inverse matrix has the same entries, but with alternating sign. ! ! Licensing: ! ! This code is distributed under the MIT license. ! ! Modified: ! ! 02 June 2008 ! ! Author: ! ! John Burkardt ! ! Reference: ! ! John Boothroyd, ! Algorithm 274: ! Generation of Hilbert Derived Test Matrix, ! Communications of the ACM, ! Volume 9, Number 1, January 1966, page 11. ! ! Input: ! ! integer N, the order of the matrix. ! ! Output: ! ! real ( kind = rk ) A(N,N), the matrix. ! implicit none integer, parameter :: rk = kind ( 1.0D+00 ) integer n real ( kind = rk ) a(n,n) integer i integer j real ( kind = rk ) 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 ) & * real ( n, kind = rk ) / real ( i + j - 1, kind = rk ) end do end do return end subroutine borderband_determinant ( n, determ ) !*****************************************************************************80 ! !! borderband_determinant() returns the determinant of the BORDERBAND matrix. ! ! Licensing: ! ! This code is distributed under the MIT license. ! ! Modified: ! ! 15 October 2007 ! ! Author: ! ! John Burkardt ! ! Input: ! ! integer N, the order of the matrix. ! ! Output: ! ! real ( kind = rk ) DETERM, the determinant. ! implicit none integer, parameter :: rk = kind ( 1.0D+00 ) real ( kind = rk ) 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 ) !*****************************************************************************80 ! !! borderband_inverse() returns the inverse of the BORDERBAND matrix. ! ! Example: ! ! N = 5 ! ! -2.0476 -1.5238 -0.7619 -0.3810 3.0476 ! -1.5238 0.2381 -0.3810 -0.1905 1.5238 ! -0.7619 -0.3810 0.8095 -0.0952 0.7619 ! -0.3810 -0.1905 -0.0952 0.9524 0.3810 ! 3.0476 1.5238 0.7619 0.3810 -3.0476 ! ! Licensing: ! ! This code is distributed under the MIT license. ! ! Modified: ! ! 17 August 2008 ! ! Author: ! ! John Burkardt ! ! Input: ! ! integer N, the order of the matrix. ! ! Output: ! ! real ( kind = rk ) A(N,N), the inverse matrix. ! implicit none integer, parameter :: rk = kind ( 1.0D+00 ) integer n real ( kind = rk ) a(n,n) real ( kind = rk ) l(n,n) real ( kind = rk ) l_inverse(n,n) real ( kind = rk ) p(n,n) real ( kind = rk ) p_inverse(n,n) real ( kind = rk ) u(n,n) real ( kind = rk ) 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 ) a(1:n,1:n) = matmul ( u_inverse, matmul ( l_inverse, p_inverse ) ) return end subroutine borderband_lu ( n, l, u ) !*****************************************************************************80 ! !! borderband_lu() returns the LU factors of the BORDERBAND matrix. ! ! Licensing: ! ! This code is distributed under the MIT license. ! ! Modified: ! ! 28 October 2021 ! ! Author: ! ! John Burkardt ! ! Input: ! ! integer N, the order of the matrix. ! ! Output: ! ! real ( kind = rk ) L(N,N), U(N,N), the factors. ! implicit none integer, parameter :: rk = kind ( 1.0D+00 ) integer n integer i integer j integer k real ( kind = rk ) l(n,n) real ( kind = rk ) u(n,n) do j = 1, n do i = 1, n if ( i == j ) then l(i,j) = 1.0D+00 else if ( i == 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 == n .and. j == 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 == j ) then u(i,j) = 1.0D+00 else if ( j == 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 borderband_matrix ( n, a ) !*****************************************************************************80 ! !! borderband_matrix() returns the BORDERBAND matrix. ! ! Formula: ! ! If ( I = J ) ! A(I,I) = 1 ! else if ( I = N ) ! A(N,J) = 2^(1-J) ! else if ( J = N ) ! A(I,N) = 2^(1-I) ! else ! A(I,J) = 0 ! ! Example: ! ! N = 5 ! ! 1 0 0 0 1 ! 0 1 0 0 1/2 ! 0 0 1 0 1/4 ! 0 0 0 1 1/8 ! 1 1/2 1/4 1/8 1 ! ! Properties: ! ! A is symmetric: A' = A. ! ! A is border-banded. ! ! A has N-2 eigenvalues of 1. ! ! det ( A ) = 1 - sum ( 1 <= I <= N-1 ) 2^(2-2*I) ! ! For N = 2, A is singular. ! ! Licensing: ! ! This code is distributed under the MIT license. ! ! Modified: ! ! 15 October 2007 ! ! Author: ! ! John Burkardt ! ! Input: ! ! integer N, the order of the matrix. ! ! Output: ! ! real ( kind = rk ) A(N,N), the matrix. ! implicit none integer, parameter :: rk = kind ( 1.0D+00 ) integer n real ( kind = rk ) a(n,n) integer i integer j do j = 1, n do i = 1, n if ( i == j ) then a(i,j) = 1.0D+00 else if ( j == n ) then a(i,j) = 2.0D+00 ** ( 1 - i ) else if ( i == 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_plu ( n, p, l, u ) !*****************************************************************************80 ! !! borderband_plu() returns the PLU factors of the BORDERBAND matrix. ! ! Licensing: ! ! This code is distributed under the MIT license. ! ! Modified: ! ! 16 August 2008 ! ! Author: ! ! John Burkardt ! ! Input: ! ! integer N, the order of the matrix. ! ! Output: ! ! real ( kind = rk ) P(N,N), L(N,N), U(N,N), the PLU factors. ! implicit none integer, parameter :: rk = kind ( 1.0D+00 ) integer n integer i integer j integer k real ( kind = rk ) l(n,n) real ( kind = rk ) p(n,n) real ( kind = rk ) u(n,n) do j = 1, n do i = 1, n if ( i == 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 == j ) then l(i,j) = 1.0D+00 else if ( i == 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 == n .and. j == 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 == j ) then u(i,j) = 1.0D+00 else if ( j == 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 ) !*****************************************************************************80 ! !! bvec_next_grlex() generates the next binary vector in GRLEX order. ! ! Discussion: ! ! N = 3 ! ! Input Output ! ----- ------ ! 0 0 0 => 0 0 1 ! 0 0 1 => 0 1 0 ! 0 1 0 => 1 0 0 ! 1 0 0 => 0 1 1 ! 0 1 1 => 1 0 1 ! 1 0 1 => 1 1 0 ! 1 1 0 => 1 1 1 ! 1 1 1 => 0 0 0 ! ! Licensing: ! ! This code is distributed under the MIT license. ! ! Modified: ! ! 13 March 2015 ! ! Author: ! ! John Burkardt ! ! Input: ! ! integer N, the dimension. ! ! integer BVEC(N), the binary vector whose ! successor is desired. ! ! Output: ! ! integer BVEC(N), the successor to the input vector. ! implicit none integer, parameter :: rk = kind ( 1.0D+00 ) integer n integer bvec(n) integer i integer o integer s integer z ! ! Initialize locations of 0 and 1. ! if ( bvec(1) == 0 ) then z = 1 o = 0 else z = 0 o = 1 end if ! ! Moving from right to left, search for a "1", preceded by a "0". ! do i = n, 2, -1 if ( bvec(i) == 1 ) then o = i if ( bvec(i-1) == 0 ) then z = i - 1 exit end if end if end do ! ! BVEC = 0 ! if ( o == 0 ) then bvec(n) = 1 ! ! 01 never occurs. So for sure, B(1) = 1. ! else if ( z == 0 ) then s = sum ( bvec(1:n) ) if ( s == n ) then bvec(1:n) = 0 else bvec(1:n-s-1) = 0 bvec(n-s:n) = 1 end if ! ! Found the rightmost "01" string. ! Replace it by "10". ! Shift following 1's to the right. ! 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 subroutine c8_fake_use ( x ) !*****************************************************************************80 ! !! c8_fake_use() pretends to use a variable. ! ! Discussion: ! ! Some compilers will issue a warning if a variable is unused. ! Sometimes there's a good reason to include a variable in a program, ! but not to use it. Calling this function with that variable as ! the argument will shut the compiler up. ! ! Licensing: ! ! This code is distributed under the MIT license. ! ! Modified: ! ! 21 April 2020 ! ! Author: ! ! John Burkardt ! ! Input: ! ! complex ( kind = ck ) X, the variable to be "used". ! implicit none integer, parameter :: rk = kind ( 1.0D+00 ) integer, parameter :: ck = kind ( ( 1.0D+00, 1.0D+00 ) ) complex ( kind = ck ) x if ( x /= x ) then write ( *, '(a)' ) ' c8_fake_use: variable is NAN.' end if return end function c8_i ( ) !*****************************************************************************80 ! !! c8_i() returns the value of the imaginary unit, i. ! ! Licensing: ! ! This code is distributed under the MIT license. ! ! Modified: ! ! 27 May 2002 ! ! Author: ! ! John Burkardt ! ! Output: ! ! complex ( kind = ck ) C8_I, the value of complex i. ! implicit none integer, parameter :: rk = kind ( 1.0D+00 ) integer, parameter :: ck = kind ( ( 1.0D+00, 1.0D+00 ) ) complex ( kind = ck ) c8_i c8_i = cmplx ( 0.0D+00, 1.0D+00, kind = ck ) return end function c8_le_l2 ( x, y ) !*****************************************************************************80 ! !! c8_le_l2() := X <= Y for complex values, and the L2 norm. ! ! Discussion: ! ! The L2 norm can be defined here as: ! ! value = sqrt ( ( real (X) )^2 + ( imag (X) )^2 ) ! ! Licensing: ! ! This code is distributed under the MIT license. ! ! Modified: ! ! 12 March 2001 ! ! Author: ! ! John Burkardt ! ! Input: ! ! complex ( kind = ck ) X, Y, the values to be compared. ! ! Output: ! ! logical C8_LE_L2, is TRUE if X <= Y. ! implicit none integer, parameter :: rk = kind ( 1.0D+00 ) integer, parameter :: ck = kind ( ( 1.0D+00, 1.0D+00 ) ) logical c8_le_l2 logical value complex ( kind = ck ) x complex ( kind = ck ) y if ( ( real ( x ) ) ** 2 + ( imag ( x ) ) ** 2 <= & ( real ( y ) ) ** 2 + ( imag ( y ) ) ** 2 ) then value = .true. else value = .false. end if c8_le_l2 = value return end function c8_normal_01 ( ) !*****************************************************************************80 ! !! c8_normal_01() returns a unit pseudonormal C8. ! ! Licensing: ! ! This code is distributed under the MIT license. ! ! Modified: ! ! 17 July 2006 ! ! Author: ! ! John Burkardt ! ! Output: ! ! complex ( kind = ck ) C8_NORMAL_01, a sample of the PDF. ! implicit none integer, parameter :: rk = kind ( 1.0D+00 ) integer, parameter :: ck = kind ( ( 1.0D+00, 1.0D+00 ) ) complex ( kind = ck ) c8_normal_01 real ( kind = rk ), parameter :: r8_pi = 3.141592653589793D+00 real ( kind = rk ) v1 real ( kind = rk ) v2 real ( kind = rk ) x_c real ( kind = rk ) x_r call random_number ( harvest = v1 ) call random_number ( harvest = v2 ) 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, kind = ck ) return end function c8_one ( ) !*****************************************************************************80 ! !! c8_one() returns the value of complex 1. ! ! Licensing: ! ! This code is distributed under the MIT license. ! ! Modified: ! ! 31 May 2002 ! ! Author: ! ! John Burkardt ! ! Output: ! ! complex ( kind = ck ) C8_ONE, the value of complex 1. ! implicit none integer, parameter :: rk = kind ( 1.0D+00 ) integer, parameter :: ck = kind ( ( 1.0D+00, 1.0D+00 ) ) complex ( kind = ck ) c8_one c8_one = cmplx ( 1.0D+00, 0.0D+00, kind = ck ) return end subroutine c8_swap ( x, y ) !*****************************************************************************80 ! !! c8_swap() swaps two C8's. ! ! Licensing: ! ! This code is distributed under the MIT license. ! ! Modified: ! ! 26 July 1999 ! ! Author: ! ! John Burkardt ! ! Input: ! ! complex ( kind = ck ) X, Y, two values to be interchanged. ! ! Output: ! ! complex ( kind = ck ) X, Y, the interchanged values. ! implicit none integer, parameter :: rk = kind ( 1.0D+00 ) integer, parameter :: ck = kind ( ( 1.0D+00, 1.0D+00 ) ) complex ( kind = ck ) x complex ( kind = ck ) y complex ( kind = ck ) z z = x x = y y = z return end function c8_uniform_01 ( seed ) !*****************************************************************************80 ! !! c8_uniform_01() returns a unit pseudorandom C8. ! ! Discussion: ! ! A C8 is a complex ( kind = ck ) value. ! ! For now, the input quantity SEED is an integer variable. ! ! The angle should be uniformly distributed between 0 and 2 * PI, ! the square root of the radius uniformly distributed between 0 and 1. ! ! This results in a uniform distribution of values in the unit circle. ! ! Licensing: ! ! This code is distributed under the MIT license. ! ! Modified: ! ! 15 March 2005 ! ! Author: ! ! John Burkardt ! ! Input: ! ! integer SEED, the "seed" value, which ! should NOT be 0. ! ! Output: ! ! complex ( kind = ck ) C8_UNIFORM_01, a pseudorandom complex value. ! ! integer SEED, the updated seed. ! implicit none integer, parameter :: rk = kind ( 1.0D+00 ) integer, parameter :: ck = kind ( ( 1.0D+00, 1.0D+00 ) ) complex ( kind = ck ) c8_uniform_01 integer k real ( kind = rk ), parameter :: r8_pi = 3.141592653589793D+00 real ( kind = rk ) r integer seed real ( kind = rk ) theta if ( seed == 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 < 0 ) then seed = seed + 2147483647 end if r = sqrt ( real ( seed, kind = rk ) * 4.656612875D-10 ) k = seed / 127773 seed = 16807 * ( seed - k * 127773 ) - k * 2836 if ( seed < 0 ) then seed = seed + 2147483647 end if theta = 2.0D+00 * r8_pi * ( real ( seed, kind = rk ) * 4.656612875D-10 ) c8_uniform_01 = r * cmplx ( cos ( theta ), sin ( theta ), kind = ck ) return end function c8_zero ( ) !*****************************************************************************80 ! !! c8_zero() returns the value of complex 0. ! ! Licensing: ! ! This code is distributed under the MIT license. ! ! Modified: ! ! 27 May 2002 ! ! Author: ! ! John Burkardt ! ! Output: ! ! complex ( kind = ck ) C8_ZERO, the value of complex 0. ! implicit none integer, parameter :: rk = kind ( 1.0D+00 ) integer, parameter :: ck = kind ( ( 1.0D+00, 1.0D+00 ) ) complex ( kind = ck ) c8_zero c8_zero = cmplx ( 0.0D+00, 0.0D+00, kind = ck ) return end subroutine c8mat_house_matrix ( n, x, a ) !*****************************************************************************80 ! !! c8mat_house_matrix() constructs a complex Householder elementary reflector matrix. ! ! Discussion: ! ! A = I - ( 2 * X * hermitian ( X ) ) / ( conjg ( X ) * X ) ! ! Example: ! ! N = 5, X = ( 1, 1, 1, 0, -1 ) ! ! 1/2 -1/2 -1/2 0 1/2 ! -1/2 1/2 -1/2 0 1/2 ! -1/2 -1/2 1/2 0 1/2 ! 0 0 0 1 0 ! 1/2 1/2 1/2 0 1/2 ! ! Properties: ! ! A is hermitian: hermitian ( A ) = A. ! ! Because A is hermitian, it is normal. ! ! Because A is normal, it is diagonalizable. ! ! A is unitary: hermitian ( A ) * A = A * hermitian ( A ) = I. ! ! inverse ( A ) = A. ! ! det ( A ) = -1. ! ! LAMBDA(1) = -1. ! ! If X is the vector used to define A, then X is an eigenvector ! of A associated with the eigenvalue of -1. ! ! Licensing: ! ! This code is distributed under the MIT license. ! ! Modified: ! ! 31 May 2002 ! ! Author: ! ! John Burkardt ! ! Input: ! ! integer N, the order of the matrix. ! ! complex ( kind = ck ) X(N), the vector that defines the ! Householder matrix. ! ! Output: ! ! complex ( kind = ck ) A(N,N), the matrix. ! implicit none integer, parameter :: rk = kind ( 1.0D+00 ) integer, parameter :: ck = kind ( ( 1.0D+00, 1.0D+00 ) ) integer n complex ( kind = ck ) a(n,n) integer i integer j complex ( kind = ck ) x(n) real ( kind = rk ) xdot call c8mat_identity_matrix ( n, a ) xdot = real ( dot_product ( x(1:n), x(1:n) ) ) if ( 0.0D+00 < 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 ) !*****************************************************************************80 ! !! c8mat_house_axh() computes A*H where H is a compact Householder matrix. ! ! Discussion: ! ! The Householder matrix H(V) is defined by ! ! H(V) = I - 2 * v * hermitian ( v ) / ( hermitian ( v ) * v ) ! ! This routine is not particularly efficient. ! ! Licensing: ! ! This code is distributed under the MIT license. ! ! Modified: ! ! 01 June 2002 ! ! Author: ! ! John Burkardt ! ! Input: ! ! integer N, the order of the matrix. ! ! complex ( kind = ck ) A(N,N), the matrix. ! ! complex ( kind = ck ) V(N), a vector defining a Householder matrix. ! ! Output: ! ! complex ( kind = ck ) AH(N,N), the product A*H. ! implicit none integer, parameter :: rk = kind ( 1.0D+00 ) integer, parameter :: ck = kind ( ( 1.0D+00, 1.0D+00 ) ) integer n complex ( kind = ck ) a(n,n) complex ( kind = ck ) ah(n,n) complex ( kind = ck ) ah_temp(n,n) integer i integer j integer k complex ( kind = ck ) v(n) real ( kind = rk ) v_normsq v_normsq = 0.0D+00 do j = 1, n v_normsq = v_normsq + abs ( v(j) )**2 end do ! ! Compute A * hermitian ( H ) = A * H ! 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) * conjg ( v(j) ) / v_normsq end do end do end do ! ! Copy the temporary result into AH. ! Doing it this way means the user can identify the input arguments A and AH. ! ah(1:n,1:n) = ah_temp(1:n,1:n) return end subroutine c8mat_house_form ( n, v, h ) !*****************************************************************************80 ! !! c8mat_house_form() constructs a Householder matrix from its compact form. ! ! Discussion: ! ! H(v) = I - 2 * v * hermitian ( v ) / ( hermitian ( v ) * v ) ! ! Licensing: ! ! This code is distributed under the MIT license. ! ! Modified: ! ! 31 May 2002 ! ! Author: ! ! John Burkardt ! ! Input: ! ! integer N, the order of the matrix. ! ! complex ( kind = ck ) V(N), the vector defining the ! Householder matrix. ! ! Output: ! ! complex ( kind = ck ) H(N,N), the Householder matrix. ! implicit none integer, parameter :: rk = kind ( 1.0D+00 ) integer, parameter :: ck = kind ( ( 1.0D+00, 1.0D+00 ) ) integer n real ( kind = rk ) beta complex ( kind = ck ) h(n,n) integer i integer j complex ( kind = ck ) v(n) beta = real ( dot_product ( v(1:n), v(1:n) ) ) call c8mat_identity_matrix ( n, h ) do j = 1, n do i = 1, n h(i,j) = h(i,j) - 2.0D+00 * v(i) * conjg ( v(j) ) / beta end do end do return end subroutine c8mat_identity_matrix ( n, a ) !*****************************************************************************80 ! !! c8mat_identity_matrix() sets a C8MAT to the identity. ! ! Licensing: ! ! This code is distributed under the MIT license. ! ! Modified: ! ! 08 June 2008 ! ! Author: ! ! John Burkardt ! ! Input: ! ! integer N, the order of the matrix. ! ! Output: ! ! complex ( kind = ck ) A(N,N), the matrix. ! implicit none integer, parameter :: rk = kind ( 1.0D+00 ) integer, parameter :: ck = kind ( ( 1.0D+00, 1.0D+00 ) ) integer n complex ( kind = ck ) a(n,n) integer i a(1:n,1:n) = cmplx ( 0.0D+00, 0.0D+00, kind = ck ) do i = 1, n a(i,i) = cmplx ( 1.0D+00, 0.0D+00, kind = ck ) end do return end subroutine c8mat_is_eigen_right ( n, k, a, x, lambda, error_frobenius ) !*****************************************************************************80 ! !! c8mat_is_eigen_right(): the error in a complex right eigensystem. ! ! Discussion: ! ! An R8MAT is a matrix of real ( kind = rk ) values. ! ! This routine computes the Frobenius norm of ! ! A * X - X * LAMBDA ! ! where ! ! A is an N by N matrix, ! X is an N by K matrix (each of K columns is an eigenvector) ! LAMBDA is a K by K diagonal matrix of eigenvalues. ! ! This routine assumes that A, X and LAMBDA are all complex! ! ! Licensing: ! ! This code is distributed under the MIT license. ! ! Modified: ! ! 15 May 2021 ! ! Author: ! ! John Burkardt ! ! Input: ! ! integer N, the order of the matrix. ! ! integer K, the number of eigenvectors. ! K is usually 1 or N. ! ! complex ( kind = ck ) A(N,N), the matrix. ! ! complex ( kind = ck ) X(N,K), the K eigenvectors. ! ! complex ( kind = ck ) LAMBDA(K), the K eigenvalues. ! ! Output: ! ! real ( kind = rk ) ERROR_FROBENIUS, the Frobenius norm ! of the difference matrix A * X - X * LAMBDA, which would be exactly zero ! if X and LAMBDA were exact eigenvectors and eigenvalues of A. ! implicit none integer, parameter :: rk = kind ( 1.0D+00 ) integer, parameter :: ck = kind ( ( 1.0D+00, 1.0D+00 ) ) integer k integer n complex ( kind = ck ) a(n,n) complex ( kind = ck ) c(n,k) real ( kind = rk ) error_frobenius integer j complex ( kind = ck ) lambda(k) real ( kind = rk ) c8mat_norm_fro complex ( kind = ck ) x(n,k) c(1:n,1:k) = matmul ( a(1:n,1:n), x(1:n,1:k) ) do j = 1, k c(1:n,j) = c(1:n,j) - lambda(j) * x(1:n,j) end do error_frobenius = c8mat_norm_fro ( n, k, c ) return end subroutine c8mat_is_hermitian ( m, n, a, ival ) !*****************************************************************************80 ! !! c8mat_is_hermitian() checks if a C8MAT is hermitian. ! ! Licensing: ! ! This code is distributed under the MIT license. ! ! Modified: ! ! 31 May 2002 ! ! Author: ! ! John Burkardt ! ! Input: ! ! integer M, N, the order of the matrix. ! ! complex ( kind = ck ) A(M,N), the matrix. ! ! Output: ! ! integer IVAL: ! -1, the matrix is not symmetric because M /= N. ! -2, the matrix is not symmetric because A(I,J) = conjg ( A(J,I) ) fails. ! 1, the matrix is symmetric. ! implicit none integer, parameter :: rk = kind ( 1.0D+00 ) integer, parameter :: ck = kind ( ( 1.0D+00, 1.0D+00 ) ) integer m integer n complex ( kind = ck ) a(m,n) integer i integer ival integer j if ( m /= n ) then ival = -1 return end if do i = 1, n do j = 1, i - 1 if ( a(i,j) /= conjg ( a(j,i) ) ) then ival = -2 end if end do end do ival = 1 return end subroutine c8mat_is_inverse ( n, a, b, error_frobenius ) !*****************************************************************************80 ! !! c8mat_is_inverse() determines if one C8MAT is the inverse of another. ! ! Discussion: ! ! Actually, this routine simply returns the sum of the Frobenius norms of ! A * B - I and B * A - I. ! ! Licensing: ! ! This code is distributed under the MIT license. ! ! Modified: ! ! 09 July 2008 ! ! Author: ! ! John Burkardt ! ! Input: ! ! integer N, the order of the matrix. ! ! complex ( kind = ck ) A(N,N), B(N,N), the matrices. ! ! Output: ! ! real ( kind = rk ) ERROR_FROBENIUS, the Frobenius norm ! of the difference matrix A * B - I, which would be exactly zero ! if B was the exact inverse of A and computer arithmetic were exact. ! implicit none integer, parameter :: rk = kind ( 1.0D+00 ) integer, parameter :: ck = kind ( ( 1.0D+00, 1.0D+00 ) ) integer n complex ( kind = ck ) a(n,n) complex ( kind = ck ) b(n,n) real ( kind = rk ) error_frobenius real ( kind = rk ) error_left real ( kind = rk ) error_right call c8mat_is_inverse_left ( n, n, a, b, error_left ) call c8mat_is_inverse_right ( n, n, a, b, error_right ) error_frobenius = error_left + error_right return end subroutine c8mat_is_inverse_left ( m, n, a, b, error_frobenius ) !*****************************************************************************80 ! !! c8mat_is_inverse_left() determines if one C8MAT is the left inverse of another. ! ! Discussion: ! ! This routine returns the Frobenius norm of B * A - I. ! ! Licensing: ! ! This code is distributed under the MIT license. ! ! Modified: ! ! 09 July 2008 ! ! Author: ! ! John Burkardt ! ! Input: ! ! integer M, N, the order of the matrix. ! ! complex ( kind = ck ) A(M,N), the matrix. ! ! complex ( kind = ck ) B(N,M), the matrix to be checked as the ! left inverse of A. ! ! Output: ! ! real ( kind = rk ) ERROR_FROBENIUS, the Frobenius norm ! of the difference matrix B * A - I, which would be exactly zero ! if B was the exact left inverse of A and computer arithmetic were exact. ! implicit none integer, parameter :: rk = kind ( 1.0D+00 ) integer, parameter :: ck = kind ( ( 1.0D+00, 1.0D+00 ) ) integer m integer n complex ( kind = ck ) a(m,n) complex ( kind = ck ) b(n,m) complex ( kind = ck ) c(n,n) real ( kind = rk ) error_frobenius integer i real ( kind = rk ) c8mat_norm_fro c(1:n,1:n) = matmul ( b(1:n,1:m), a(1:m,1:n) ) do i = 1, n c(i,i) = c(i,i) - cmplx ( 1.0D+00, 0.0D+00, kind = ck ) end do error_frobenius = c8mat_norm_fro ( n, n, c ) return end subroutine c8mat_is_inverse_right ( m, n, a, b, error_frobenius ) !*****************************************************************************80 ! !! c8mat_is_inverse_right() determines if a C8MAT is the right inverse of another. ! ! Discussion: ! ! This routine returns the Frobenius norm of A * B - I. ! ! Licensing: ! ! This code is distributed under the MIT license. ! ! Modified: ! ! 09 July 2008 ! ! Author: ! ! John Burkardt ! ! Input: ! ! integer M, N, the order of the matrix. ! ! complex ( kind = ck ) A(M,N), the matrix. ! ! complex ( kind = ck ) B(N,M), the matrix to be checked as the ! left inverse of A. ! ! Output: ! ! real ( kind = rk ) ERROR_FROBENIUS, the Frobenius norm ! of the difference matrix A * B - I, which would be exactly zero ! if B was the exact right inverse of A and computer arithmetic were exact. ! implicit none integer, parameter :: rk = kind ( 1.0D+00 ) integer, parameter :: ck = kind ( ( 1.0D+00, 1.0D+00 ) ) integer m integer n complex ( kind = ck ) a(m,n) complex ( kind = ck ) b(n,m) complex ( kind = ck ) c(m,m) real ( kind = rk ) error_frobenius integer i real ( kind = rk ) c8mat_norm_fro c(1:m,1:m) = matmul ( a(1:m,1:n), b(1:n,1:m) ) do i = 1, m c(i,i) = c(i,i) - cmplx ( 1.0D+00, 0.0D+00, kind = ck ) end do error_frobenius = c8mat_norm_fro ( m, m, c ) return end subroutine c8mat_is_orthogonal_column ( m, n, a, ival ) !*****************************************************************************80 ! !! c8mat_is_orthogonal_column() checks if a C8MAT is column orthogonal. ! ! Licensing: ! ! This code is distributed under the MIT license. ! ! Modified: ! ! 08 October 2007 ! ! Author: ! ! John Burkardt ! ! Input: ! ! integer M, N, the row and column dimensions ! of the matrix. M and N must be positive. ! ! complex ( kind = ck ) A(M,N), the matrix. ! ! Output: ! ! integer IVAL: ! -1, the matrix is not column orthogonal. ! 1, the matrix is column orthogonal. ! implicit none integer, parameter :: rk = kind ( 1.0D+00 ) integer, parameter :: ck = kind ( ( 1.0D+00, 1.0D+00 ) ) integer m integer n complex ( kind = ck ) a(m,n) real ( kind = rk ) deviation real ( kind = rk ) deviation_max integer ival integer j1 integer j2 real ( kind = rk ), parameter :: tol = 0.0001D+00 deviation_max = 0.0D+00 do j1 = 1, n do j2 = j1+1, n deviation = abs ( dot_product ( a(1:m,j1), a(1:m,j2) ) ) deviation_max = max ( deviation_max, deviation ) end do end do if ( deviation_max < tol ) then ival = +1 else ival = -1 end if return end subroutine c8mat_is_orthogonal_row ( m, n, a, ival ) !*****************************************************************************80 ! !! c8mat_is_orthogonal_row() checks if a C8MAT is row orthogonal. ! ! Licensing: ! ! This code is distributed under the MIT license. ! ! Modified: ! ! 31 May 2002 ! ! Author: ! ! John Burkardt ! ! Input: ! ! integer M, N, the row and column dimensions ! of the matrix. M and N must be positive. ! ! complex ( kind = ck ) A(M,N), the matrix. ! ! Output: ! ! integer IVAL: ! -1, the matrix is not row orthogonal. ! 1, the matrix is row orthogonal. ! implicit none integer, parameter :: rk = kind ( 1.0D+00 ) integer, parameter :: ck = kind ( ( 1.0D+00, 1.0D+00 ) ) integer m integer n complex ( kind = ck ) a(m,n) integer i1 integer i2 integer ival complex ( kind = ck ) test real ( kind = rk ), parameter :: tol = 0.0001D+00 do i1 = 1, m do i2 = i1+1, m test = dot_product ( a(i1,1:n), a(i2,1:n) ) if ( tol < abs ( test ) ) then ival = -1 return end if end do end do ival = 1 return end function c8mat_is_square ( m, n, a ) !*****************************************************************************80 ! !! c8mat_is_square() checks whether an R8MAT is square. ! ! Discussion: ! ! A C8MAT is a matrix of complex ( kind = ck ) values. ! ! Licensing: ! ! This code is distributed under the MIT license. ! ! Modified: ! ! 13 April 2017 ! ! Author: ! ! John Burkardt ! ! Input: ! ! integer M, N, the order of the matrix. ! M and N must be positive. ! ! complex ( kind = ck ) A(M,N), the matrix. ! ! Output: ! ! logical C8MAT_IS_SQUARE, is TRUE if the matrix ! is square. ! implicit none integer, parameter :: rk = kind ( 1.0D+00 ) integer, parameter :: ck = kind ( ( 1.0D+00, 1.0D+00 ) ) integer m integer n complex ( kind = ck ) a(m,n) logical c8mat_is_square logical value call c8_fake_use ( a(1,1) ) value = ( m == n ) c8mat_is_square = value return end subroutine c8mat_is_symmetric ( m, n, a, error_frobenius ) !*****************************************************************************80 ! !! c8mat_is_symmetric() checks a C8MAT for symmetry. ! ! Licensing: ! ! This code is distributed under the MIT license. ! ! Modified: ! ! 20 October 2007 ! ! Author: ! ! John Burkardt ! ! Input: ! ! integer M, N, the order of the matrix. ! ! complex ( kind = ck ) A(M,N), the matrix. ! ! Output: ! ! real ( kind = rk ) ERROR_FROBENIUS, measures the ! Frobenius norm of ( A - A' ), which would be zero if the matrix were ! exactly symmetric. ! implicit none integer, parameter :: rk = kind ( 1.0D+00 ) integer, parameter :: ck = kind ( ( 1.0D+00, 1.0D+00 ) ) integer m integer n complex ( kind = ck ) a(m,n) logical c8mat_is_square real ( kind = rk ) error_frobenius real ( kind = rk ) r8_huge if ( .not. c8mat_is_square ( m, n, a ) ) then error_frobenius = r8_huge ( ) return end if error_frobenius = sqrt ( & sum ( & ( & abs ( a(1:m,1:n) - transpose ( a(1:m,1:n) ) ) & ) ** 2 & ) & ) return end subroutine c8mat_is_unit_column ( m, n, a, ival ) !*****************************************************************************80 ! !! c8mat_is_unit_column() checks whether a C8MAT has columns of unit norm. ! ! Licensing: ! ! This code is distributed under the MIT license. ! ! Modified: ! ! 31 May 2002 ! ! Author: ! ! John Burkardt ! ! Input: ! ! integer M, N, the row and column dimensions ! of the matrix. M and N must be positive. ! ! complex ( kind = ck ) A(M,N), the matrix. ! ! Output: ! ! integer IVAL: ! -1, the matrix is not column normalized. ! 1, the matrix is column normalized. ! implicit none integer, parameter :: rk = kind ( 1.0D+00 ) integer, parameter :: ck = kind ( ( 1.0D+00, 1.0D+00 ) ) integer m integer n complex ( kind = ck ) a(m,n) real ( kind = rk ) c8vec_norm_l2 integer ival integer j real ( kind = rk ), parameter :: tol = 0.0001D+00 do j = 1, n if ( tol < abs ( 1.0D+00 - c8vec_norm_l2 ( m, a(1:m,j) ) ) ) then ival = -1 return end if end do ival = 1 return end subroutine c8mat_is_unit_row ( m, n, a, ival ) !*****************************************************************************80 ! !! c8mat_is_unit_row() checks whether a C8MAT has rows of unit norm. ! ! Licensing: ! ! This code is distributed under the MIT license. ! ! Modified: ! ! 31 May 2002 ! ! Author: ! ! John Burkardt ! ! Input: ! ! integer M, N, the row and column dimensions ! of the matrix. M and N must be positive. ! ! complex ( kind = ck ) A(M,N), the matrix. ! ! Output: ! ! integer IVAL: ! -1, the matrix is not row normalized. ! 1, the matrix is row normalized. ! implicit none integer, parameter :: rk = kind ( 1.0D+00 ) integer, parameter :: ck = kind ( ( 1.0D+00, 1.0D+00 ) ) integer m integer n complex ( kind = ck ) a(m,n) real ( kind = rk ) c8vec_norm_l2 integer i integer ival real ( kind = rk ), parameter :: tol = 0.0001D+00 do i = 1, m if ( tol < abs ( 1.0D+00 - c8vec_norm_l2 ( n, a(i,1:n) ) ) ) then ival = -1 return end if end do ival = 1 return end subroutine c8mat_is_unitary ( m, n, a, ival ) !*****************************************************************************80 ! !! c8mat_is_unitary() checks whether a C8MAT is unitary. ! ! Licensing: ! ! This code is distributed under the MIT license. ! ! Modified: ! ! 31 May 2002 ! ! Author: ! ! John Burkardt ! ! Input: ! ! integer M, N, the row and column dimensions ! of the matrix. M and N must be positive. ! ! complex ( kind = ck ) A(M,N), the matrix. ! ! Output: ! ! integer IVAL: ! -1, the matrix is not unitary; M /= N. ! -2, the matrix is not unitary; row I * column I /= 1; ! -3, the matrix is not unitary; row I * column J /= 0; ! 1, the matrix is unitary. ! implicit none integer, parameter :: rk = kind ( 1.0D+00 ) integer, parameter :: ck = kind ( ( 1.0D+00, 1.0D+00 ) ) integer m integer n complex ( kind = ck ) a(m,n) logical c8mat_is_square integer i integer ival integer j complex ( kind = ck ) test real ( kind = rk ), parameter :: tol = 0.0001D+00 if ( .not. c8mat_is_square ( m, n, a ) ) then ival = -1 return end if do i = 1, n test = dot_product ( a(i,1:n), a(1:n,i) ) & - cmplx ( 1.0D+00, 0.0D+00, kind = ck ) if ( tol < abs ( test ) ) then ival = -2 return end if do j = i + 1, n test = dot_product ( a(i,1:n), a(1:n,j) ) if ( tol < abs ( test ) ) then ival = -3 return end if end do end do ival = 1 return end function c8mat_norm_fro ( m, n, a ) !*****************************************************************************80 ! !! c8mat_norm_fro() returns the Frobenius norm of a C8MAT. ! ! Discussion: ! ! The Frobenius norm is defined as ! ! C8MAT_NORM_FRO = sqrt ( ! sum ( 1 <= I <= M ) Sum ( 1 <= J <= N ) |A(I,J)|^2 ) ! ! The matrix Frobenius-norm is not derived from a vector norm, but ! is compatible with the vector L2 norm, so that: ! ! c8vec_norm_l2 ( A*x ) <= c8mat_norm_fro ( A ) * c8vec_norm_l2 ( x ). ! ! Licensing: ! ! This code is distributed under the MIT license. ! ! Modified: ! ! 07 October 2007 ! ! Author: ! ! John Burkardt ! ! Input: ! ! integer M, N, the order of the matrix. ! ! complex ( kind = ck ) A(M,N), the matrix. ! ! Output: ! ! real ( kind = rk ) C8MAT_NORM_FRO, the Frobenius norm of A. ! implicit none integer, parameter :: rk = kind ( 1.0D+00 ) integer, parameter :: ck = kind ( ( 1.0D+00, 1.0D+00 ) ) integer m integer n complex ( kind = ck ) a(m,n) real ( kind = rk ) c8mat_norm_fro c8mat_norm_fro = sqrt ( sum ( ( abs ( a(1:m,1:n) ) )**2 ) ) return end subroutine c8mat_print ( m, n, a, title ) !*****************************************************************************80 ! !! c8mat_print() prints a C8MAT. ! ! Discussion: ! ! A C8MAT is a matrix of complex ( kind = ck ) values. ! ! Licensing: ! ! This code is distributed under the MIT license. ! ! Modified: ! ! 23 March 2005 ! ! Author: ! ! John Burkardt ! ! Input: ! ! integer M, N, the number of rows and columns ! in the matrix. ! ! complex ( kind = ck ) A(M,N), the matrix. ! ! character ( len = * ) TITLE, a title. ! implicit none integer, parameter :: rk = kind ( 1.0D+00 ) integer, parameter :: ck = kind ( ( 1.0D+00, 1.0D+00 ) ) integer m integer n complex ( kind = ck ) a(m,n) character ( len = * ) 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 ) !*****************************************************************************80 ! !! c8mat_print_some() prints some of a C8MAT. ! ! Discussion: ! ! A C8MAT is a matrix of complex ( kind = ck ) values. ! ! Licensing: ! ! This code is distributed under the MIT license. ! ! Modified: ! ! 23 March 2005 ! ! Author: ! ! John Burkardt ! ! Input: ! ! integer M, N, the number of rows and columns ! in the matrix. ! ! complex ( kind = ck ) A(M,N), the matrix. ! ! integer ILO, JLO, IHI, JHI, the first row and ! column, and the last row and column to be printed. ! ! character ( len = * ) TITLE, a title. ! implicit none integer, parameter :: rk = kind ( 1.0D+00 ) integer, parameter :: ck = kind ( ( 1.0D+00, 1.0D+00 ) ) integer, parameter :: incx = 4 integer m integer n complex ( kind = ck ) a(m,n) character ( len = 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 ( len = * ) title complex ( kind = ck ) zero zero = cmplx ( 0.0D+00, 0.0D+00, kind = ck ) write ( *, '(a)' ) ' ' write ( *, '(a)' ) trim ( title ) ! ! Print the columns of the matrix, in strips of INCX. ! do j2lo = jlo, jhi, 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)' ) ' ---' ! ! Determine the range of the rows in this strip. ! i2lo = max ( ilo, 1 ) i2hi = min ( ihi, m ) do i = i2lo, i2hi ! ! Print out (up to) INCX entries in row I, that lie in the current strip. ! do j2 = 1, inc j = j2lo - 1 + j2 if ( a(i,j) == zero ) then ctemp(j2) = ' 0.0 ' else if ( imag ( a(i,j) ) == 0.0D+00 ) then write ( ctemp(j2), '(g10.3,10x)' ) real ( a(i,j), kind = rk ) else write ( ctemp(j2), '(2g10.3)' ) a(i,j) end if end do write ( *, '(i5,1x,4a20)' ) i, ( ctemp(j2), j2 = 1, inc ) end do end do write ( *, '(a)' ) ' ' return end subroutine c8mat_uniform_01_matrix ( m, n, seed, c ) !*****************************************************************************80 ! !! c8mat_uniform_01_matrix() returns a unit pseudorandom C8MAT. ! ! Discussion: ! ! A C8MAT is a matrix of complex ( kind = ck ) values. ! ! For now, the input quantity SEED is an integer variable. ! ! The angles should be uniformly distributed between 0 and 2 * PI, ! the square roots of the radius uniformly distributed between 0 and 1. ! ! This results in a uniform distribution of values in the unit circle. ! ! Licensing: ! ! This code is distributed under the MIT license. ! ! Modified: ! ! 15 March 2005 ! ! Author: ! ! John Burkardt ! ! Input: ! ! integer M, N, the order of the matrix. ! ! integer SEED, the "seed" value, which should NOT be 0. ! ! Output: ! ! complex ( kind = ck ) C(M,N), the pseudorandom complex matrix. ! ! integer SEED, the updated seed. ! implicit none integer, parameter :: rk = kind ( 1.0D+00 ) integer, parameter :: ck = kind ( ( 1.0D+00, 1.0D+00 ) ) integer m integer n complex ( kind = ck ) c(m,n) integer i integer j real ( kind = rk ) r integer k real ( kind = rk ), parameter :: r8_pi = 3.141592653589793D+00 integer seed real ( kind = rk ) theta if ( seed == 0 ) then write ( *, '(a)' ) ' ' write ( *, '(a)' ) 'C8MAT_UNIFORM_01_MATRIX - 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 < 0 ) then seed = seed + 2147483647 end if r = sqrt ( real ( seed, kind = rk ) * 4.656612875D-10 ) k = seed / 127773 seed = 16807 * ( seed - k * 127773 ) - k * 2836 if ( seed < 0 ) then seed = seed + 2147483647 end if theta = 2.0D+00 * r8_pi * ( real ( seed, kind = rk ) * 4.656612875D-10 ) c(i,j) = r * cmplx ( cos ( theta ), sin ( theta ), kind = ck ) end do end do return end subroutine c8vec_house_column ( n, a, k, v ) !*****************************************************************************80 ! !! c8vec_house_column() defines a Householder premultiplier that "packs" a column. ! ! Discussion: ! ! The routine returns a vector V that defines a Householder ! premultiplier matrix H(V) that zeros out the subdiagonal entries of ! column K of the matrix A. ! ! H(V) = I - 2 * v * conjg ( v ) ! ! Licensing: ! ! This code is distributed under the MIT license. ! ! Modified: ! ! 01 June 2002 ! ! Author: ! ! John Burkardt ! ! Input: ! ! integer N, the order of the matrix A. ! ! complex ( kind = ck ) A(N), column K of the matrix A. ! ! integer K, the column of the matrix to be modified. ! ! Output: ! ! complex ( kind = ck ) V(N), a vector of unit L2 norm which defines a ! unitary Householder premultiplier matrix H with the property ! that the K-th column of H * A is zero below the diagonal. ! implicit none integer, parameter :: rk = kind ( 1.0D+00 ) integer, parameter :: ck = kind ( ( 1.0D+00, 1.0D+00 ) ) integer n complex ( kind = ck ) a(n) integer k real ( kind = rk ) s complex ( kind = ck ) v(n) v(1:n) = cmplx ( 0.0D+00, 0.0D+00, kind = ck ) if ( k < 1 .or. n <= k ) then return end if s = sqrt ( real ( dot_product ( a(k:n), a(k:n) ) ) ) if ( s == 0.0D+00 ) then return end if v(k) = a(k) + s * a(k) / abs ( a(k) ) v(k+1:n) = a(k+1:n) v(k:n) = v(k:n) / sqrt ( real ( dot_product ( v(k:n), v(k:n) ) ) ) return end function c8vec_norm_l2 ( n, a ) !*****************************************************************************80 ! !! c8vec_norm_l2() returns the L2 norm of a C8VEC. ! ! Discussion: ! ! The vector L2 norm is defined as: ! ! value = sqrt ( sum ( 1 <= I <= N ) conjg ( A(I) ) * A(I) ). ! ! Licensing: ! ! This code is distributed under the MIT license. ! ! Modified: ! ! 30 May 2002 ! ! Author: ! ! John Burkardt ! ! Input: ! ! integer N, the number of entries in A. ! ! complex ( kind = ck ) A(N), the vector whose L2 norm is desired. ! ! Output: ! ! real ( kind = rk ) C8VEC_NORM_L2, the L2 norm of A. ! implicit none integer, parameter :: rk = kind ( 1.0D+00 ) integer, parameter :: ck = kind ( ( 1.0D+00, 1.0D+00 ) ) integer n complex ( kind = ck ) a(n) real ( kind = rk ) c8vec_norm_l2 c8vec_norm_l2 = sqrt ( sum ( ( abs ( a(1:n) ) )**2 ) ) return end function c8vec_norm_squared ( n, a ) !*****************************************************************************80 ! !! c8vec_norm_squared() returns the square of the L2 norm of a C8VEC. ! ! Discussion: ! ! A C8VEC is a vector of C8's. ! ! The square of the vector L2 norm is defined as: ! ! C8VEC_NORM_SQUARED = sum ( 1 <= I <= N ) conjg ( A(I) ) * A(I). ! ! Licensing: ! ! This code is distributed under the MIT license. ! ! Modified: ! ! 22 June 2011 ! ! Author: ! ! John Burkardt ! ! Input: ! ! integer N, the number of entries in A. ! ! complex ( kind = ck ) A(N), the vector whose L2 norm is desired. ! ! Output: ! ! real ( kind = rk ) C8VEC_NORM_SQUARED, the L2 norm of A. ! implicit none integer, parameter :: rk = kind ( 1.0D+00 ) integer, parameter :: ck = kind ( ( 1.0D+00, 1.0D+00 ) ) integer n complex ( kind = ck ) a(n) real ( kind = rk ) c8vec_norm_squared c8vec_norm_squared = sum ( ( abs ( a(1:n) ) )**2 ) return end subroutine c8vec_print ( n, a, title ) !*****************************************************************************80 ! !! c8vec_print() prints a C8VEC, with an optional title. ! ! Licensing: ! ! This code is distributed under the MIT license. ! ! Modified: ! ! 08 March 2001 ! ! Author: ! ! John Burkardt ! ! Input: ! ! integer N, the number of components of the vector. ! ! complex ( kind = ck ) A(N), the vector to be printed. ! ! character ( len = * ) TITLE, a title to be printed first. ! TITLE may be blank. ! implicit none integer, parameter :: rk = kind ( 1.0D+00 ) integer, parameter :: ck = kind ( ( 1.0D+00, 1.0D+00 ) ) integer n complex ( kind = ck ) a(n) integer i character ( len = * ) title if ( 0 < len_trim ( title ) ) then write ( *, '(a)' ) ' ' write ( *, '(a)' ) trim ( title ) end if write ( *, '(a)' ) ' ' do i = 1, n write ( *, '(i8,2g14.6)' ) i, a(i) end do return end subroutine c8vec_print_some ( n, x, max_print ) !*****************************************************************************80 ! !! c8vec_print_some() prints some of a C8VEC. ! ! Discussion: ! ! The user specifies MAX_PRINT, the maximum number of lines to print. ! ! If N, the size of the vector, is no more than MAX_PRINT, then ! the entire vector is printed, one entry per line. ! ! Otherwise, if possible, the first MAX_PRINT-2 entries are printed, ! followed by a line of periods suggesting an omission, ! and the last entry. ! ! Licensing: ! ! This code is distributed under the MIT license. ! ! Modified: ! ! 14 September 1999 ! ! Author: ! ! John Burkardt ! ! Input: ! ! integer N, the number of entries of the vector. ! ! complex ( kind = ck ) X(N), the vector to be printed. ! ! integer MAX_PRINT, the maximum number of lines ! to print. ! implicit none integer, parameter :: rk = kind ( 1.0D+00 ) integer, parameter :: ck = kind ( ( 1.0D+00, 1.0D+00 ) ) integer n integer i integer max_print complex ( kind = ck ) x(n) if ( max_print <= 0 ) then return end if if ( n <= 0 ) then return end if if ( n <= max_print ) then do i = 1, n write ( *, '(i8,2x,2g14.6)' ) i, x(i) end do else if ( 3 <= max_print ) then do i = 1, max_print-2 write ( *, '(i8,2x,2g14.6)' ) i, x(i) end do write ( *, '(a)' ) '...... ..............' i = n write ( *, '(i8,2x,2g14.6)' ) i, x(i) else do i = 1, max_print - 1 write ( *, '(i8,2x,2g14.6)' ) i, x(i) end do i = max_print write ( *, '(i8,2x,2g14.6,2x,a)' ) i, x(i), '...more entries...' end if return end subroutine c8vec_sort_a_l2 ( n, x ) !*****************************************************************************80 ! !! c8vec_sort_a_l2() ascending sorts a C8VEC by L2 norm. ! ! Discussion: ! ! The L2 norm of A+Bi is sqrt ( A*A + B*B ). ! ! Licensing: ! ! This code is distributed under the MIT license. ! ! Modified: ! ! 12 March 2001 ! ! Author: ! ! John Burkardt ! ! Input: ! ! integer N, length of input array. ! ! complex ( kind = ck ) X(N), an unsorted array. ! ! Output: ! ! complex ( kind = ck ) X(N), the sorted array. ! implicit none integer, parameter :: rk = kind ( 1.0D+00 ) integer, parameter :: ck = kind ( ( 1.0D+00, 1.0D+00 ) ) integer n logical c8_le_l2 integer i integer indx integer isgn integer j complex ( kind = ck ) x(n) i = 0 indx = 0 isgn = 0 j = 0 do call sort_heap_external ( n, indx, i, j, isgn ) if ( 0 < indx ) then call c8_swap ( x(i), x(j) ) else if ( indx < 0 ) then if ( c8_le_l2 ( x(i), x(j) ) ) then isgn = - 1 else isgn = + 1 end if else if ( indx == 0 ) then exit end if end do return end subroutine c8vec_uniform_01 ( n, seed, c ) !*****************************************************************************80 ! !! c8vec_uniform_01() returns a unit pseudorandom C8VEC. ! ! Discussion: ! ! A C8VEC is a vector of complex ( kind = ck ) values. ! ! For now, the input quantity SEED is an integer variable. ! ! The angles should be uniformly distributed between 0 and 2 * PI, ! the square roots of the radius uniformly distributed between 0 and 1. ! ! This results in a uniform distribution of values in the unit circle. ! ! Licensing: ! ! This code is distributed under the MIT license. ! ! Modified: ! ! 15 March 2005 ! ! Author: ! ! John Burkardt ! ! Input: ! ! integer N, the number of values to compute. ! ! integer SEED, the "seed" value, which should NOT be 0. ! ! Output: ! ! complex ( kind = ck ) C(N), the pseudorandom complex vector. ! ! integer SEED, the updated seed. ! implicit none integer, parameter :: rk = kind ( 1.0D+00 ) integer, parameter :: ck = kind ( ( 1.0D+00, 1.0D+00 ) ) integer n complex ( kind = ck ) c(n) integer i real ( kind = rk ) r integer k real ( kind = rk ), parameter :: r8_pi = 3.141592653589793D+00 integer seed real ( kind = rk ) theta if ( seed == 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 < 0 ) then seed = seed + 2147483647 end if r = sqrt ( real ( seed, kind = rk ) * 4.656612875D-10 ) k = seed / 127773 seed = 16807 * ( seed - k * 127773 ) - k * 2836 if ( seed < 0 ) then seed = seed + 2147483647 end if theta = 2.0D+00 * r8_pi * ( real ( seed, kind = rk ) * 4.656612875D-10 ) c(i) = r * cmplx ( cos ( theta ), sin ( theta ), kind = ck ) end do return end subroutine c8vec_unity ( n, a ) !*****************************************************************************80 ! !! c8vec_unity() returns the N roots of unity. ! ! Discussion: ! ! X(1:N) = exp ( 2 * PI * (0:N-1) / N ) ! ! X(1:N)^N = ( (1,0), (1,0), ..., (1,0) ). ! ! Licensing: ! ! This code is distributed under the MIT license. ! ! Modified: ! ! 12 March 2001 ! ! Author: ! ! John Burkardt ! ! Input: ! ! integer N, the number of elements of A. ! ! Output: ! ! complex ( kind = ck ) A(N), the N roots of unity. ! implicit none integer, parameter :: rk = kind ( 1.0D+00 ) integer, parameter :: ck = kind ( ( 1.0D+00, 1.0D+00 ) ) integer n complex ( kind = ck ) a(n) real ( kind = rk ) angle integer i real ( kind = rk ), parameter :: r8_pi = 3.141592653589793D+00 do i = 1, n angle = r8_pi * real ( 2 * ( i - 1 ), kind = rk ) / real ( n, kind = rk ) a(i) = cmplx ( cos ( angle ), sin ( angle ), kind = ck ) end do return end subroutine carry_matrix ( n, alpha, a ) !*****************************************************************************80 ! !! carry_matrix() returns the CARRY matrix. ! ! Discussion: ! ! We assume that arithmetic is being done in base ALPHA. We are adding ! a column of N digits base ALPHA, as part of adding N random numbers. ! We know the carry digit, between 0 and N-1, that is being carried into the ! column sum (the incarry digit), and we want to know the probability of ! the various carry digits 0 through N-1 (the outcarry digit) that could ! be carried out of the column sum. ! ! The carry matrix summarizes this data. The entry A(I,J) represents ! the probability that, given that the incarry digit is I-1, the ! outcarry digit will be J-1. ! ! Formula: ! ! A(I,J) = ( 1 / ALPHA )^N * sum ( 0 <= K <= J-1 - floor ( I-1 / ALPHA ) ) ! (-1)^K * C(N+1,K) * C(N-I+(J-K)*ALPHA, N ) ! ! Example: ! ! N = 4, ALPHA = 10 ! ! 0.0715 0.5280 0.3795 0.0210 ! 0.0495 0.4840 0.4335 0.0330 ! 0.0330 0.4335 0.4840 0.0495 ! 0.0210 0.3795 0.5280 0.0715 ! ! Properties: ! ! A is generally not symmetric: A' /= A. ! ! A is a Markov matrix. ! ! A is centrosymmetric: A(I,J) = A(N+1-I,N+1-J). ! ! LAMBDA(I) = 1 / ALPHA^(I-1) ! ! det ( A ) = 1 / ALPHA^((N*(N-1))/2) ! ! The eigenvectors do not depend on ALPHA. ! ! A is generally not normal: A' * A /= A * A'. ! ! Licensing: ! ! This code is distributed under the MIT license. ! ! Modified: ! ! 02 June 2008 ! ! Author: ! ! John Burkardt ! ! Reference: ! ! John Holte, ! Carries, Combinatorics, and an Amazing Matrix, ! The American Mathematical Monthly, ! Volume 104, Number 2, February 1997, pages 138-149. ! ! Input: ! ! integer N, the order of the matrix. ! ! integer ALPHA, the numeric base being used ! in the addition. ! ! Output: ! ! real ( kind = rk ) A(N,N), the matrix. ! implicit none integer, parameter :: rk = kind ( 1.0D+00 ) integer n real ( kind = rk ) a(n,n) integer alpha real ( kind = rk ) c1 real ( kind = rk ) c2 integer i integer j integer k real ( kind = rk ) r8_choose real ( kind = rk ) r8_mop real ( kind = rk ) 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 / real ( alpha**n, kind = rk ) end do end do return end subroutine carry_determinant ( n, alpha, determ ) !*****************************************************************************80 ! !! carry_determinant() returns the determinant of the CARRY matrix. ! ! Licensing: ! ! This code is distributed under the MIT license. ! ! Modified: ! ! 21 May 2002 ! ! Author: ! ! John Burkardt ! ! Input: ! ! integer N, the order of the matrix. ! ! integer ALPHA, the numeric base being used ! in the addition. ! ! Output: ! ! real ( kind = rk ) DETERM, the determinant. ! implicit none integer, parameter :: rk = kind ( 1.0D+00 ) integer n integer alpha real ( kind = rk ) determ integer power power = ( n * ( n - 1 ) ) / 2 determ = 1.0D+00 / real ( alpha ** power, kind = rk ) return end subroutine carry_eigen_left ( n, alpha, a ) !*****************************************************************************80 ! !! carry_eigen_left() returns the left eigenvectors of the CARRY matrix. ! ! Formula: ! ! A(I,J) = sum ( 0 <= K <= J-1 ) ! (-1)^K * C(N+1,K) * ( J - K )^(N+1-I) ! ! Example: ! ! N = 4, ALPHA = 10 ! ! 1 11 11 1 ! 1 3 -3 -1 ! 1 -1 -1 1 ! 1 -3 3 -1 ! ! Properties: ! ! A is generally not symmetric: A' /= A. ! ! Column 1 is all 1's, and column N is (-1)^(I+1). ! ! The top row is proportional to a row of Eulerian numbers, and ! can be normalized to represent the stationary probablities ! for the carrying process when adding N random numbers. ! ! The bottom row is proportional to a row of Pascal's triangle, ! with alternating signs. ! ! The product of the left and right eigenvector matrices of ! order N is N! times the identity. ! ! Licensing: ! ! This code is distributed under the MIT license. ! ! Modified: ! ! 02 June 2008 ! ! Author: ! ! John Burkardt ! ! Reference: ! ! John Holte, ! Carries, Combinatorics, and an Amazing Matrix, ! The American Mathematical Monthly, ! Volume 104, Number 2, February 1997, pages 138-149. ! ! Input: ! ! integer N, the order of the matrix. ! ! integer ALPHA, the numeric base being used ! in the addition. ! ! Output: ! ! real ( kind = rk ) A(N,N), the matrix. ! implicit none integer, parameter :: rk = kind ( 1.0D+00 ) integer n real ( kind = rk ) a(n,n) integer alpha integer i integer j integer k real ( kind = rk ) r8_choose real ( kind = rk ) r8_mop call i4_fake_use ( alpha ) a(1:n,1:n) = 0.0D+00 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 ) !*****************************************************************************80 ! !! carry_eigen_right() returns the right eigenvectors of the CARRY matrix. ! ! Discussion: ! ! A(I,J) = sum ( N+1-J) <= K <= N ) ! S1(N,K) * C(K,N+1-J) ( N - I )^(K-N+J-1) ! ! where S1(N,K) is a signed Sterling number of the first kind. ! ! Example: ! ! N = 4, ALPHA = 10 ! ! 1 6 11 6 ! 1 2 -1 -2 ! 1 -2 -1 2 ! 1 -6 11 -6 ! ! Properties: ! ! A is generally not symmetric: A' /= A. ! ! The first column is all 1's. ! ! The last column is reciprocals of binomial coefficients with ! alternating sign multiplied by (N-1)!. ! ! The top and bottom rows are the unsigned and signed Stirling numbers ! of the first kind. ! ! The entries in the J-th column are a degree (J-1) polynomial ! in the row index I. (Column 1 is constant, the first difference ! in column 2 is constant, the second difference in column 3 is ! constant, and so on.) ! ! Licensing: ! ! This code is distributed under the MIT license. ! ! Modified: ! ! 02 June 2008 ! ! Author: ! ! John Burkardt ! ! Reference: ! ! John Holte, ! Carries, Combinatorics, and an Amazing Matrix, ! The American Mathematical Monthly, ! Volume 104, Number 2, February 1997, pages 138-149. ! ! Input: ! ! integer N, the order of the matrix. ! ! integer ALPHA, the numeric base being used ! in the addition. ! ! Output: ! ! real ( kind = rk ) A(N,N), the matrix. ! implicit none integer, parameter :: rk = kind ( 1.0D+00 ) integer n real ( kind = rk ) a(n,n) integer alpha integer i integer j integer k real ( kind = rk ) r8_choose real ( kind = rk ) s1(n,n) call i4_fake_use ( alpha ) call stirling_matrix ( n, n, s1 ) a(1:n,1:n) = 0.0D+00 do j = 1, n do i = 1, n do k = n + 1 - j, n if ( n - i == 0 .and. k - n + j - 1 == 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 ) !*****************************************************************************80 ! !! carry_eigenvalues() returns the eigenvalues of the CARRY matrix. ! ! Licensing: ! ! This code is distributed under the MIT license. ! ! Modified: ! ! 19 May 2002 ! ! Author: ! ! John Burkardt ! ! Input: ! ! integer N, the order of the matrix. ! ! integer ALPHA, the numeric base being used ! in the addition. ! ! Output: ! ! real ( kind = rk ) LAMBDA(N), the eigenvalues. ! implicit none integer, parameter :: rk = kind ( 1.0D+00 ) integer n integer alpha integer i real ( kind = rk ) lambda(n) do i = 1, n lambda(i) = 1.0D+00 / real ( alpha ** ( i - 1 ), kind = rk ) end do return end subroutine carry_inverse ( n, alpha, a ) !*****************************************************************************80 ! !! carry_inverse() returns the inverse of the CARRY matrix. ! ! Example: ! ! N = 4, ALPHA = 10 ! ! 298.3750 -787.8750 697.1250 -206.6250 ! -86.6250 257.1250 -247.8750 78.3750 ! 78.3750 -247.8750 257.1250 -86.6250 ! -206.6250 697.1250 -787.8750 298.3750 ! ! Licensing: ! ! This code is distributed under the MIT license. ! ! Modified: ! ! 26 October 2007 ! ! Author: ! ! John Burkardt ! ! Input: ! ! integer N, the order of the matrix. ! ! integer ALPHA, the numeric base being used ! in the addition. ! ! Output: ! ! real ( kind = rk ) A(N,N), the matrix. ! implicit none integer, parameter :: rk = kind ( 1.0D+00 ) integer n real ( kind = rk ) a(n,n) integer alpha real ( kind = rk ) d(n) integer i integer j real ( kind = rk ) r8_factorial real ( kind = rk ) t real ( kind = rk ) u(n,n) real ( kind = rk ) v(n,n) call carry_eigen_left ( n, alpha, v ) call carry_eigenvalues ( n, alpha, d ) call carry_eigen_right ( n, alpha, u ) do j = 1, n do i = 1, n v(i,j) = v(i,j) / d(i) end do end do a = matmul ( u, v ) t = r8_factorial ( n ) a(1:n,1:n) = a(1:n,1:n) / t return end subroutine cauchy_matrix ( n, x, y, a ) !*****************************************************************************80 ! !! cauchy_matrix() returns the CAUCHY matrix. ! ! Formula: ! ! A(I,J) = 1.0 / ( X(I) + Y(J) ) ! ! Example: ! ! N = 5, X = ( 1, 3, 5, 8, 7 ), Y = ( 2, 4, 6, 10, 9 ) ! ! 1/3 1/5 1/7 1/11 1/10 ! 1/5 1/7 1/9 1/13 1/12 ! 1/7 1/9 1/11 1/15 1/14 ! 1/10 1/12 1/14 1/18 1/17 ! 1/9 1/11 1/13 1/17 1/16 ! ! or, in decimal form, ! ! 0.333333 0.200000 0.142857 0.0909091 0.100000 ! 0.200000 0.142857 0.111111 0.0769231 0.0833333 ! 0.142857 0.111111 0.0909091 0.0666667 0.0714286 ! 0.100000 0.0833333 0.0714286 0.0555556 0.0588235 ! 0.111111 0.0909091 0.0769231 0.0588235 0.0625000 ! ! Properties: ! ! A is generally not symmetric: A' /= A. ! ! A is totally positive if 0 < X(1) < ... < X(N) and 0 < Y1 < ... < Y(N). ! ! A will be singular if any X(I) equals X(J), or ! any Y(I) equals Y(J), or if any X(I)+Y(J) equals zero. ! ! A is generally not normal: A' * A /= A * A'. ! ! The HILBERT matrix is a special case of the CAUCHY matrix. ! ! The PARTER matrix is a special case of the CAUCHY matrix. ! ! The RIS or "ding-dong" matrix is a special case of the CAUCHY matrix. ! ! det ( A ) = product ( 1 <= I < J <= N ) ( X(J) - X(I) )* ( Y(J) - Y(I) ) ! / product ( 1 <= I <= N, 1 <= J <= N ) ( X(I) + Y(J) ) ! ! The inverse of A is ! ! INVERSE(A)(I,J) = product ( 1 <= K <= N ) [ (X(J)+Y(K)) * (X(K)+Y(I)) ] / ! [ (X(J)+Y(I)) * product ( 1 <= K <= N, K /= J ) (X(J)-X(K)) ! * product ( 1 <= K <= N, K /= I ) (Y(I)-Y(K)) ] ! ! The family of matrices is nested as a function of N. ! ! Licensing: ! ! This code is distributed under the MIT license. ! ! Modified: ! ! 15 April 1999 ! ! Author: ! ! John Burkardt ! ! Reference: ! ! Robert Gregory, David Karney, ! A Collection of Matrices for Testing Computational Algorithms, ! Wiley, 1969, ! ISBN: 0882756494, ! LC: QA263.68 ! ! Nicholas Higham, ! Accuracy and Stability of Numerical Algorithms, ! SIAM, 1996. ! ! Donald Knuth, ! The Art of Computer Programming, ! Volume 1, Fundamental Algorithms, Second Edition ! Addison-Wesley, Reading, Massachusetts, 1973, page 36. ! ! Olga Taussky, Marvin Marcus, ! Eigenvalues of finite matrices, ! in Survey of Numerical Analysis, ! Edited by John Todd, ! McGraw-Hill, pages 279-313, 1962. ! ! Evgeny Tyrtyshnikov, ! Cauchy-Toeplitz matrices and some applications, ! Linear Algebra and Applications, ! Volume 149, 1991, pages 1-18. ! ! Input: ! ! integer N, the order of the matrix. ! ! real ( kind = rk ) X(N), Y(N), vectors that determine A. ! ! Output: ! ! real ( kind = rk ) A(N,N), the matrix. ! implicit none integer, parameter :: rk = kind ( 1.0D+00 ) integer n real ( kind = rk ) a(n,n) integer i integer j real ( kind = rk ) x(n) real ( kind = rk ) y(n) do j = 1, n do i = 1, n if ( x(i) + y(j) == 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 ) !*****************************************************************************80 ! !! cauchy_determinant() returns the determinant of the CAUCHY matrix. ! ! Licensing: ! ! This code is distributed under the MIT license. ! ! Modified: ! ! 21 May 2002 ! ! Author: ! ! John Burkardt ! ! Input: ! ! integer N, the order of the matrix. ! ! real ( kind = rk ) X(N), Y(N), vectors that determine A. ! ! Output: ! ! real ( kind = rk ) DETERM, the determinant. ! implicit none integer, parameter :: rk = kind ( 1.0D+00 ) integer n real ( kind = rk ) bottom real ( kind = rk ) determ integer i integer j real ( kind = rk ) top real ( kind = rk ) x(n) real ( kind = rk ) 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 ) !*****************************************************************************80 ! !! cauchy_inverse() returns the inverse of the CAUCHY matrix. ! ! Discussion: ! ! The following conditions on X and Y must hold: ! ! X(I)+Y(J) must not be zero for any I and J; ! X(I) must never equal X(J); ! Y(I) must never equal Y(J). ! ! Formula: ! ! A(I,J) = product ( 1 <= K <= N ) [(X(J)+Y(K))*(X(K)+Y(I))] / ! [ (X(J)+Y(I)) * product ( 1 <= K <= N, K /= J ) (X(J)-X(K)) ! * product ( 1 <= K <= N, K /= I ) (Y(I)-Y(K)) ] ! ! Example: ! ! N = 5, X = ( 1, 3, 5, 8, 7 ), Y = ( 2, 4, 6, 10, 9 ) ! ! 241.70 -2591.37 9136.23 10327.50 -17092.97 ! -2382.19 30405.38 -116727.19 -141372.00 229729.52 ! 6451.76 -89667.70 362119.56 459459.00 -737048.81 ! 10683.11 -161528.55 690983.38 929857.44 -1466576.75 ! -14960.00 222767.98 -942480.06 -1253376.00 1983696.00 ! ! Properties: ! ! A is generally not symmetric: A' /= A. ! ! The sum of the entries of A equals the sum of the entries of X and Y. ! ! Licensing: ! ! This code is distributed under the MIT license. ! ! Modified: ! ! 15 April 1999 ! ! Author: ! ! John Burkardt ! ! Reference: ! ! Donald Knuth, ! The Art of Computer Programming, ! Volume 1, Fundamental Algorithms, Second Edition, ! Addison-Wesley, Reading, Massachusetts, 1973, page 36. ! ! Input: ! ! integer N, the order of the matrix. ! ! real ( kind = rk ) X(N), Y(N), vectors that determine A. ! ! Output: ! ! real ( kind = rk ) A(N,N), the matrix. ! implicit none integer, parameter :: rk = kind ( 1.0D+00 ) integer n real ( kind = rk ) a(n,n) real ( kind = rk ) bot1 real ( kind = rk ) bot2 integer i integer j integer k real ( kind = rk ) top real ( kind = rk ) x(n) real ( kind = rk ) y(n) ! ! Check the data. ! do j = 1, n do i = 1, n if ( x(i) + y(j) == 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 /= j .and. x(i) == 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 /= j .and. y(i) == 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 /= j ) then bot1 = bot1 * ( x(j) - x(k) ) end if if ( k /= 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_matrix ( n, a ) !*****************************************************************************80 ! !! cheby_diff1_matrix() returns the CHEBY_DIFF1 matrix. ! ! Example: ! ! N = 6 ! ! 8.5000 -10.4721 2.8944 -1.5279 1.1056 -0.5000 ! 2.6180 -1.1708 -2.0000 0.8944 -0.6810 0.2764 ! -0.7236 2.0000 -0.1708 1.6180 0.8944 -0.3820 ! 0.3820 -0.8944 1.6180 0.1708 -2.0000 0.7236 ! -0.2764 0.6180 -0.8944 2.0000 1.1708 -2.6180 ! 0.5000 -1.1056 1.5279 -2.8944 10.4721 -8.5000 ! ! Properties: ! ! If N is odd, then det ( A ) = 0. ! ! Licensing: ! ! This code is distributed under the MIT license. ! ! Modified: ! ! 02 June 2008 ! ! Author: ! ! John Burkardt ! ! Reference: ! ! Lloyd Trefethen, ! Spectral Methods in MATLAB, ! SIAM, 2000, page 54. ! ! Input: ! ! integer N, the order of the matrix. ! ! Output: ! ! real ( kind = rk ) A(N,N), the matrix. ! implicit none integer, parameter :: rk = kind ( 1.0D+00 ) integer n real ( kind = rk ) a(n,n) real ( kind = rk ) c(n) integer i integer j real ( kind = rk ), parameter :: r8_pi = 3.141592653589793D+00 real ( kind = rk ) r8_mop real ( kind = rk ) x(n) if ( n <= 0 ) then return end if if ( n == 1 ) then a(1,1) = 1.0D+00 return end if c(1) = 2.0D+00 c(2:n-1) = 1.0D+00 c(n) = 2.0D+00 ! ! Get the Chebyshev points. ! do i = 1, n x(i) = cos ( r8_pi * real ( i - 1, kind = rk ) / real ( n - 1, kind = rk ) ) end do do j = 1, n do i = 1, n if ( i /= j ) then a(i,j) = r8_mop ( i + j ) * c(i) / ( c(j) * ( x(i) - x(j) ) ) else if ( i == 1 ) then a(i,i) = real ( 2 * ( n - 1 ) * ( n - 1 ) + 1, kind = rk ) / 6.0D+00 else if ( i == n ) then a(i,i) = - real ( 2 * ( n - 1 ) * ( n - 1 ) + 1, kind = rk ) / 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_determinant ( n, determ ) !*****************************************************************************80 ! !! cheby_diff1_determinant() returns the determinant of the CHEBY_DIFF1 matrix. ! ! Licensing: ! ! This code is distributed under the MIT license. ! ! Modified: ! ! 08 May 2020 ! ! Author: ! ! John Burkardt ! ! Input: ! ! integer N, the order of the matrix. ! ! Output: ! ! real ( kind = rk ) DETERM, the determinant. ! implicit none integer, parameter :: rk = kind ( 1.0D+00 ) real ( kind = rk ) determ integer n if ( n == 1 ) then determ = 1.0D+00 else determ = 0.0D+00 end if return end subroutine cheby_diff1_null_left ( m, n, x ) !*****************************************************************************80 ! !! cheby_diff1_null_left() returns a left null vector of the CHEBY_DIFF1 matrix. ! ! Discussion: ! ! The matrix only has a (nonzero) null vector when N is odd. ! ! Licensing: ! ! This code is distributed under the MIT license. ! ! Modified: ! ! 13 March 2015 ! ! Author: ! ! John Burkardt ! ! Input: ! ! integer M, N, the order of the matrix. ! ! Output: ! ! real ( kind = rk ) X(M), the null vector. ! implicit none integer, parameter :: rk = kind ( 1.0D+00 ) integer m integer n integer i real ( kind = rk ) t real ( kind = rk ) x(m) call i4_fake_use ( n ) if ( mod ( m, 2 ) == 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 x(1:m) = 0.0D+00 end if return end subroutine cheby_diff1_null_right ( m, n, x ) !*****************************************************************************80 ! !! cheby_diff1_null_right() returns a right null vector of the CHEBY_DIFF1 matrix. ! ! Discussion: ! ! The matrix only has a (nonzero) null vector when N is odd. ! ! Licensing: ! ! This code is distributed under the MIT license. ! ! Modified: ! ! 03 November 2007 ! ! Author: ! ! John Burkardt ! ! Input: ! ! integer M, N, the order of the matrix. ! ! Output: ! ! real ( kind = rk ) X(N), the null vector. ! implicit none integer, parameter :: rk = kind ( 1.0D+00 ) integer m integer n real ( kind = rk ) x(n) call i4_fake_use ( m ) if ( mod ( n, 2 ) == 1 ) then x(1:n) = 1.0D+00 else x(1:n) = 0.0D+00 end if return end subroutine cheby_t_matrix ( n, A ) !*****************************************************************************80 ! !! cheby_t_matrix() returns the CHEBY_T matrix. ! ! Discussion ! ! This is the Chebyshev T matrix, associated with the Chebyshev ! "T" polynomials, or Chebyshev polynomials of the first kind. ! ! Example: ! ! N = 11 ! ! 1 . -1 . 1 . -1 . 1 . -1 ! . 1 . -3 . 5 . -7 . 9 . ! . . 2 . -8 . 18 . -32 . 50 ! . . . 4 . -20 . 56 . -120 . ! . . . . 8 . -48 . 160 . -400 ! . . . . . 16 . -112 . 432 . ! . . . . . . 32 . -256 . 1120 ! . . . . . . . 64 . -576 . ! . . . . . . . . 128 . -1280 ! . . . . . . . . . 256 . ! . . . . . . . . . . 512 ! ! Properties: ! ! A is generally not symmetric: A' /= A. ! ! A is integral, therefore det ( A ) is integral, and ! det ( A ) * inverse ( A ) is integral. ! ! A is reducible. ! ! A is lower triangular. ! ! Each row of A sums to 1. ! ! det ( A ) = 2^( (N-1) * (N-2) / 2 ) ! ! A is not normal: A' * A /= A * A'. ! ! For I = 1: ! ! LAMBDA(1) = 1 ! ! For 1 < I ! ! LAMBDA(I) = 2^(I-2) ! ! The family of matrices is nested as a function of N. ! ! Licensing: ! ! This code is distributed under the MIT license. ! ! Modified: ! ! 04 April 2024 ! ! Author: ! ! John Burkardt ! ! Input: ! ! integer N: the order of the matrix. ! ! Output: ! ! real ( kind = rk ) A(N,N): the matrix. ! implicit none integer, parameter :: rk = kind ( 1.0D+00 ) integer n real ( kind = rk ) A(n,n) integer i integer j if ( n <= 0 ) then return end if A(1:n,1:n) = 0.0D+00 A(1,1) = 1.0D+00 if ( n == 1 ) then return end if A(2,2) = 1.0D+00 do j = 3, n do i = 1, n if ( i == 1 ) then A(i,j) = - A(i,j-2) else A(i,j) = 2.0D+00 * A(i-1,j-1) - A(i,j-2) end if end do end do return end subroutine cheby_t_determinant ( n, determ ) !*****************************************************************************80 ! !! cheby_t_determinant() returns the determinant of the CHEBY_T matrix. ! ! Licensing: ! ! This code is distributed under the MIT license. ! ! Modified: ! ! 21 May 2002 ! ! Author: ! ! John Burkardt ! ! Input: ! ! integer N, the order of the matrix. ! ! Output: ! ! real ( kind = rk ) DETERM, the determinant. ! implicit none integer, parameter :: rk = kind ( 1.0D+00 ) real ( kind = rk ) determ integer n integer power power = ( ( n - 1 ) * ( n - 2 ) ) / 2 determ = real ( 2 ** power, kind = rk ) return end subroutine cheby_t_eigenvalues ( n, lambda ) !*****************************************************************************80 ! !! cheby_t_eigenvalues() returns the eigenvalues of the CHEBY_T matrix. ! ! Licensing: ! ! This code is distributed under the MIT license. ! ! Modified: ! ! 19 August 2008 ! ! Author: ! ! John Burkardt ! ! Input: ! ! integer N, the order of the matrix. ! ! Output: ! ! real ( kind = rk ) LAMBDA(N), the eigenvalues. ! implicit none integer, parameter :: rk = kind ( 1.0D+00 ) integer n integer i real ( kind = rk ) 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 ) !*****************************************************************************80 ! !! cheby_t_inverse() returns the inverse of the CHEBY_T matrix. ! ! Example: ! ! N = 11 ! ! Each column must be divided by the divisor below it. ! ! 1 . 1 . 3 . 10 . 35 . 126 ! . 1 . 3 . 10 . 35 . 126 . ! . . 1 . 4 . 15 . 56 . 210 ! . . . 1 . 5 . 21 . 84 . ! . . . . 1 . 6 . 28 . 120 ! . . . . . 1 . 7 . 36 . ! . . . . . . 1 . 8 . 45 ! . . . . . . . 1 . 9 . ! . . . . . . . . 1 . 10 ! . . . . . . . . . 1 . ! . . . . . . . . . . 1 ! /1 /1 /2 /4 /8 /16 /32 /64 /128 /256 /512 ! ! Licensing: ! ! This code is distributed under the MIT license. ! ! Modified: ! ! 04 April 2024 ! ! Author: ! ! John Burkardt ! ! Input: ! ! integer N: the order of the matrix. ! ! Output: ! ! real ( kind = rk ) A(N,N): the matrix. ! implicit none integer, parameter :: rk = kind ( 1.0D+00 ) integer n real ( kind = rk ) A(n,n) integer i integer j if ( n <= 0 ) then return end if A(1:n,1:n) = 0.0D+00 A(1,1) = 1.0D+00 if ( n == 1 ) then return end if A(2,2) = 1.0D+00 do j = 3, n do i = 1, n if ( i == 1 ) then A(i,j) = A(i+1,j-1) / 2.0D+00 else if ( i == 2 ) then A(i,j) = ( 2.0D+00 * A(i-1,j-1) + A(i+1,j-1) ) / 2.0D+00 else if ( i < 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_matrix ( n, a ) !*****************************************************************************80 ! !! cheby_u_matrix() returns the CHEBY_U matrix. ! ! Discussion ! ! CHEBY_T is the Chebyshev T matrix, associated with the Chebyshev ! "T" polynomials, or Chebyshev polynomials of the first kind. ! ! Example: ! ! N = 11 ! ! 1 . . . . . . . . . . ! . 2 . . . . . . . . . ! -1 . 4 . . . . . . . . ! . -4 . 8 . . . . . . . ! 1 . -12 . 16 . . . . . . ! . 6 . -32 . 32 . . . . . ! -1 . 24 . -80 . 64 . . . . ! . -8 . 80 . -192 . 128 . . . ! 1 . -40 . 240 . -448 . 256 . . ! . 10 . -160 . 672 . -1024 . 512 . ! -1 . 60 . -560 . 1792 . -2304 . 1024 ! ! Properties: ! ! A is generally not symmetric: A' /= A. ! ! A is integral, therefore det ( A ) is integral, and ! det ( A ) * inverse ( A ) is integral. ! ! A is generally not normal: A' * A /= A * A'. ! ! A is lower triangular. ! ! A is reducible. ! ! The entries of row N sum to N. ! ! det ( A ) = 2^((N*(N-1))/2). ! ! LAMBDA(I) = 2^(I-1) ! ! The family of matrices is nested as a function of N. ! ! Licensing: ! ! This code is distributed under the MIT license. ! ! Modified: ! ! 11 July 2000 ! ! Author: ! ! John Burkardt ! ! Input: ! ! integer N, the order of the matrix. ! ! Output: ! ! real ( kind = rk ) A(N,N), the matrix. ! implicit none integer, parameter :: rk = kind ( 1.0D+00 ) integer n real ( kind = rk ) a(n,n) integer i integer j if ( n <= 0 ) then return end if a(1:n,1:n) = 0.0D+00 a(1,1) = 1.0D+00 if ( n == 1 ) then return end if a(2,2) = 2.0D+00 if ( n == 2 ) then return end if do i = 3, n do j = 1, n if ( j == 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 ) !*****************************************************************************80 ! !! cheby_u_determinant() returns the determinant of the CHEBY_U matrix. ! ! Licensing: ! ! This code is distributed under the MIT license. ! ! Modified: ! ! 21 May 2002 ! ! Author: ! ! John Burkardt ! ! Input: ! ! integer N, the order of the matrix. ! ! Output: ! ! real ( kind = rk ) DETERM, the determinant. ! implicit none integer, parameter :: rk = kind ( 1.0D+00 ) real ( kind = rk ) determ integer n integer power power = ( n * ( n - 1 ) ) / 2 determ = real ( 2 ** power, kind = rk ) return end subroutine cheby_u_eigenvalues ( n, lambda ) !*****************************************************************************80 ! !! cheby_u_eigenvalues() returns the eigenvalues of the CHEBY_U matrix. ! ! Licensing: ! ! This code is distributed under the MIT license. ! ! Modified: ! ! 19 August 2008 ! ! Author: ! ! John Burkardt ! ! Input: ! ! integer N, the order of the matrix. ! ! Output: ! ! real ( kind = rk ) LAMBDA(N), the eigenvalues. ! implicit none integer, parameter :: rk = kind ( 1.0D+00 ) integer n integer i real ( kind = rk ) lambda(n) do i = 1, n lambda(i) = 2.0D+00 ** ( i - 1 ) end do return end subroutine cheby_u_inverse ( n, a ) !*****************************************************************************80 ! !! cheby_u_inverse() returns the inverse of the CHEBY_U matrix. ! ! Example: ! ! N = 11 ! ! 1 . . . . . . . . . . ! . 1 . . . . . . . . . / 2 ! 1 . 1 . . . . . . . . / 4 ! . 2 . 1 . . . . . . . / 8 ! 2 . 3 . 1 . . . . . . / 16 ! . 5 . 4 . 1 . . . . . / 32 ! 5 . 9 . 5 . 1 . . . . / 64 ! . 14 . 14 . 6 . 1 . . . / 128 ! 14 . 28 . 20 . 7 . 1 . . / 256 ! . 42 . 48 . 27 . 8 . 1 . / 512 ! 42 . 90 . 75 . 35 . 9 . 1 / 1024 ! ! Licensing: ! ! This code is distributed under the MIT license. ! ! Modified: ! ! 12 July 2000 ! ! Author: ! ! John Burkardt ! ! Input: ! ! integer N, the order of the matrix. ! ! Output: ! ! real ( kind = rk ) A(N,N), the matrix. ! implicit none integer, parameter :: rk = kind ( 1.0D+00 ) integer n real ( kind = rk ) a(n,n) integer i integer j if ( n <= 0 ) then return end if a(1:n,1:n) = 0.0D+00 a(1,1) = 1.0D+00 if ( n == 1 ) then return end if a(2,2) = 0.5D+00 if ( n == 2 ) then return end if do i = 3, n do j = 1, n if ( j == 1 ) then a(i,j) = a(i-1,j+1) / 2.0D+00 else if ( j < 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 ) !*****************************************************************************80 ! !! cheby_u_polynomial() evaluates the Chebyshev polynomials of the second kind. ! ! Differential equation: ! ! (1-X*X) Y'' - 3 X Y' + N (N+2) Y = 0 ! ! Formula: ! ! If |X| <= 1, then ! ! U(N)(X) = sin ( (N+1) * arccos(X) ) / sqrt ( 1 - X^2 ) ! = sin ( (N+1) * arccos(X) ) / sin ( arccos(X) ) ! ! else ! ! U(N)(X) = sinh ( (N+1) * arccosh(X) ) / sinh ( arccosh(X) ) ! ! First terms: ! ! U(0)(X) = 1 ! U(1)(X) = 2 X ! U(2)(X) = 4 X^2 - 1 ! U(3)(X) = 8 X^3 - 4 X ! U(4)(X) = 16 X^4 - 12 X^2 + 1 ! U(5)(X) = 32 X^5 - 32 X^3 + 6 X ! U(6)(X) = 64 X^6 - 80 X^4 + 24 X^2 - 1 ! U(7)(X) = 128 X^7 - 192 X^5 + 80 X^3 - 8X ! ! Orthogonality: ! ! For integration over [-1,1] with weight ! ! W(X) = sqrt(1-X*X), ! ! we have ! ! < U(I)(X), U(J)(X) > = integral ( -1 <= X <= 1 ) W(X) U(I)(X) U(J)(X) dX ! ! then the result is: ! ! < U(I)(X), U(J)(X) > = 0 if I /= J ! < U(I)(X), U(J)(X) > = PI/2 if I == J ! ! Recursion: ! ! U(0)(X) = 1, ! U(1)(X) = 2 * X, ! U(N)(X) = 2 * X * U(N-1)(X) - U(N-2)(X) ! ! Special values: ! ! U(N)(1) = N + 1 ! U(2N)(0) = (-1)^N ! U(2N+1)(0) = 0 ! U(N)(X) = (-1)^N * U(N)(-X) ! ! Zeroes: ! ! M-th zero of U(N)(X) is X = cos( M*PI/(N+1)), M = 1 to N ! ! Extrema: ! ! M-th extremum of U(N)(X) is X = cos( M*PI/N), M = 0 to N ! ! Norm: ! ! Integral ( -1 <= X <= 1 ) ( 1 - X^2 ) * U(N)(X)^2 dX = PI/2 ! ! Licensing: ! ! This code is distributed under the MIT license. ! ! Modified: ! ! 01 October 2002 ! ! Author: ! ! John Burkardt ! ! Reference: ! ! Milton Abramowitz, Irene Stegun, ! Handbook of Mathematical Functions, ! National Bureau of Standards, 1964, ! ISBN: 0-486-61272-4, ! LC: QA47.A34. ! ! Input: ! ! integer N, the highest polynomial to compute. ! ! real ( kind = rk ) X, the point at which the polynomials ! are to be computed. ! ! Output: ! ! real ( kind = rk ) CX(0:N), the values of the N+1 Chebyshev ! polynomials. ! implicit none integer, parameter :: rk = kind ( 1.0D+00 ) integer n real ( kind = rk ) cx(0:n) integer i real ( kind = rk ) x if ( n < 0 ) then return end if cx(0) = 1.0D+00 if ( n < 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_matrix ( m, a, b, n, x, v ) !*****************************************************************************80 ! !! cheby_van1_matrix() returns the Chebyshev Vandermonde-like matrix for [A,B]. ! ! Discussion: ! ! Normally, the Chebyshev polynomials are defined on -1 <= XI <= +1. ! Here, we assume the Chebyshev polynomials have been defined on the ! interval A <= X <= B, using the mapping ! XI = ( - ( B - X ) + ( X - A ) ) / ( B - A ) ! so that ! ChebyAB(A,B;X) = Cheby(XI). ! ! if ( I == 1 ) then ! V(1,1:N) = 1; ! elseif ( I == 2 ) then ! V(2,1:N) = XI(1:N); ! else ! V(I,1:N) = 2.0 * XI(1:N) * V(I-1,1:N) - V(I-2,1:N); ! ! Example: ! ! M = 5, A = -1, B = +1, N = 5, X = ( 1, 2, 3, 4, 5 ) ! ! 1 1 1 1 1 ! 1 2 3 4 5 ! 1 7 17 31 49 ! 1 26 99 244 485 ! 1 97 577 1921 4801 ! ! Licensing: ! ! This code is distributed under the MIT license. ! ! Modified: ! ! 10 April 2014 ! ! Author: ! ! John Burkardt ! ! Reference: ! ! Nicholas Higham, ! Stability analysis of algorithms for solving confluent ! Vandermonde-like systems, ! SIAM Journal on Matrix Analysis and Applications, ! Volume 11, 1990, pages 23-41. ! ! Input: ! ! integer M, the number of rows of the matrix. ! ! real ( kind = rk ) A, B, the interval. ! ! integer N, the number of values in X, and the number ! of columns in the matrix. ! ! real ( kind = rk ) X(N), the vector that defines A. ! ! Output: ! ! real ( kind = rk ) V(M,N), the matrix. ! implicit none integer, parameter :: rk = kind ( 1.0D+00 ) integer m integer n real ( kind = rk ) a real ( kind = rk ) b integer i real ( kind = rk ) x(n) real ( kind = rk ) xi(n) real ( kind = rk ) v(m,n) ! ! Compute the normalized abscissas in [-1,+1]. ! xi(1:n) = ( - 1.0D+00 * ( b - x(1:n) ) & + 1.0D+00 * ( x(1:n) - a ) ) & / ( b - a ) if ( 1 <= m ) then v(1,1:n) = 1.0D+00 end if if ( 2 <= m ) then v(2,1:n) = xi(1:n) end if do i = 3, m v(i,1:n) = 2.0D+00 * xi(1:n) * v(i-1,1:n) - v(i-2,1:n) end do return end subroutine cheby_van2_matrix ( n, a ) !*****************************************************************************80 ! !! cheby_van2_matrix() returns the CHEBY_VAN2 matrix. ! ! Discussion: ! ! The formula for this matrix has been slightly modified, by a scaling ! factor, in order to make it closer to its inverse. ! ! A(I,J) = ( 1 / sqrt ( N - 1 ) ) * cos ( (I-1) * (J-1) * PI / (N-1) ) ! ! Example: ! ! N = 4 ! ! 0.5774 0.5774 0.5774 0.5774 ! 0.5774 0.2887 -0.2887 -0.5774 ! 0.5774 -0.2887 -0.2887 0.5774 ! 0.5774 -0.5774 0.5774 -0.5774 ! ! Properties: ! ! A is symmetric: A' = A. ! ! Because A is symmetric, it is normal. ! ! Because A is normal, it is diagonalizable. ! ! The entries of A are based on the extrema of the Chebyshev ! polynomial T(n-1). ! ! Licensing: ! ! This code is distributed under the MIT license. ! ! Modified: ! ! 15 April 1999 ! ! Author: ! ! John Burkardt ! ! Input: ! ! integer N, the order of the matrix. ! ! Output: ! ! real ( kind = rk ) A(N,N), the matrix. ! implicit none integer, parameter :: rk = kind ( 1.0D+00 ) integer n real ( kind = rk ) a(n,n) real ( kind = rk ) angle integer i integer j real ( kind = rk ), parameter :: r8_pi = 3.141592653589793D+00 if ( n == 1 ) then a(1,1) = 1.0D+00 return end if do j = 1, n do i = 1, n angle = real ( ( i - 1 ) * ( j - 1 ), kind = rk ) * r8_pi & / real ( n - 1, kind = rk ) a(i,j) = cos ( angle ) end do end do a(1:n,1:n) = a(1:n,1:n) / sqrt ( real ( n - 1, kind = rk ) ) return end subroutine cheby_van2_determinant ( n, determ ) !*****************************************************************************80 ! !! cheby_van2_determinant() returns the determinant of the CHEBY_VAN2 matrix. ! ! Licensing: ! ! This code is distributed under the MIT license. ! ! Modified: ! ! 23 November 2007 ! ! Author: ! ! John Burkardt ! ! Input: ! ! integer N, the order of the matrix. ! ! Output: ! ! real ( kind = rk ) DETERM, the determinant. ! implicit none integer, parameter :: rk = kind ( 1.0D+00 ) real ( kind = rk ) determ integer n real ( kind = rk ) r8_mop if ( n <= 0 ) then determ = 0.0D+00 else if ( n == 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 ) !*****************************************************************************80 ! !! cheby_van2_inverse() returns the inverse of the CHEBY_VAN2 matrix. ! ! Discussion: ! ! if ( I == 1 or N ) .and. ( J == 1 or N ) then ! A(I,J) = ( 1 / (2*sqrt(N-1)) ) * cos ( (I-1) * (J-1) * PI / (N-1) ) ! else if ( I == 1 or N ) .or. ( J == 1 or N ) then ! A(I,J) = ( 1 / ( sqrt(N-1)) ) * cos ( (I-1) * (J-1) * PI / (N-1) ) ! else ! A(I,J) = ( 2 / sqrt(N-1) ) * cos ( (I-1) * (J-1) * PI / (N-1) ) ! ! ! Example: ! ! N = 4 ! ! 1/2 1 1 1/2 ! 1/sqrt(3) * 1 2*COS(PI/3) 2*COS(2*PI/3) COS(3*PI/3) ! 1 2*COS(2*PI/3) 2*COS(4*PI/3) COS(6*PI/3) ! 1/2 COS(3*PI/3) COS(6*PI/3) 1/2 * COS(9*PI/3) ! ! Properties: ! ! A is symmetric: A' = A. ! ! Because A is symmetric, it is normal. ! ! Because A is normal, it is diagonalizable. ! ! The entries of A are based on the extrema of the Chebyshev ! polynomial T(n-1). ! ! Licensing: ! ! This code is distributed under the MIT license. ! ! Modified: ! ! 21 December 2001 ! ! Author: ! ! John Burkardt ! ! Input: ! ! integer N, the order of the matrix. ! ! Output: ! ! real ( kind = rk ) A(N,N), the matrix. ! implicit none integer, parameter :: rk = kind ( 1.0D+00 ) integer n real ( kind = rk ) a(n,n) real ( kind = rk ) angle integer i integer j real ( kind = rk ), parameter :: r8_pi = 3.141592653589793D+00 if ( n == 1 ) then a(1,1) = 1.0D+00 return end if do j = 1, n do i = 1, n angle = real ( ( i - 1 ) * ( j - 1 ), kind = rk ) * r8_pi & / real ( n - 1, kind = rk ) a(i,j) = cos ( angle ) end do end do a(1:n,1:n) = 2.0D+00 * a(1:n,1:n) / sqrt ( real ( n - 1, kind = rk ) ) a(1,1:n) = 0.5D+00 * a(1,1:n) a(n,1:n) = 0.5D+00 * a(n,1:n) a(1:n,1) = 0.5D+00 * a(1:n,1) a(1:n,n) = 0.5D+00 * a(1:n,n) return end subroutine cheby_van3_matrix ( n, a ) !*****************************************************************************80 ! !! cheby_van3_matrix() returns the CHEBY_VAN3 matrix. ! ! Discussion: ! ! A(I,J) = cos ( (I-1) * (J-1/2) * PI / N ) ! ! Example: ! ! N = 5 ! ! 1.0000 1.0000 1.0000 1.0000 1.0000 ! 0.9511 0.5878 0.0000 -0.5878 -0.9511 ! 0.8090 -0.3090 -1.0000 -0.3090 0.8090 ! 0.5878 -0.9511 -0.0000 0.9511 -0.5878 ! 0.3090 -0.8090 1.0000 -0.8090 0.3090 ! ! Properties: ! ! A is generally not symmetric: A' /= A. ! ! A is "almost" orthogonal. A * A' = a diagonal matrix. ! ! The entries of A are based on the zeros of the Chebyshev polynomial T(n). ! ! Licensing: ! ! This code is distributed under the MIT license. ! ! Modified: ! ! 15 April 1999 ! ! Author: ! ! John Burkardt ! ! Input: ! ! integer N, the order of the matrix. ! ! Output: ! ! real ( kind = rk ) A(N,N), the matrix. ! implicit none integer, parameter :: rk = kind ( 1.0D+00 ) integer n real ( kind = rk ) a(n,n) real ( kind = rk ) angle integer i integer j real ( kind = rk ), parameter :: r8_pi = 3.141592653589793D+00 do j = 1, n do i = 1, n angle = real ( ( i - 1 ) * ( 2 * j - 1 ), kind = rk ) * r8_pi & / real ( 2 * n, kind = rk ) a(i,j) = cos ( angle ) end do end do return end subroutine cheby_van3_determinant ( n, determ ) !*****************************************************************************80 ! !! cheby_van3_determinant() returns the determinant of the CHEBY_VAN3 matrix. ! ! Licensing: ! ! This code is distributed under the MIT license. ! ! Modified: ! ! 22 November 2007 ! ! Author: ! ! John Burkardt ! ! Input: ! ! integer N, the order of the matrix. ! ! Output: ! ! real ( kind = rk ) DETERM, the determinant. ! implicit none integer, parameter :: rk = kind ( 1.0D+00 ) integer n real ( kind = rk ) determ real ( kind = rk ) r8_mop determ = r8_mop ( n + 1 ) * sqrt ( real ( n ** n, kind = rk ) ) & / sqrt ( 2.0D+00 ** ( n - 1 ) ) return end subroutine cheby_van3_inverse ( n, a ) !*****************************************************************************80 ! !! cheby_van3_inverse() returns the inverse of the CHEBY_VAN3 matrix. ! ! Discussion: ! ! if J == 1 then ! A(I,J) = (1/N) * cos ( (I-1/2) * (J-1) * PI / N ) ! else if 1 < J then ! A(I,J) = (2/N) * cos ( (I-1/2) * (J-1) * PI / N ) ! ! Example: ! ! N = 5 ! ! 0.2000 0.3804 0.3236 0.2351 0.1236 ! 0.2000 0.2351 -0.1236 -0.3804 -0.3236 ! 0.2000 0.0000 -0.4000 -0.0000 0.4000 ! 0.2000 -0.2351 -0.1236 0.3804 -0.3236 ! 0.2000 -0.3804 0.3236 -0.2351 0.1236 ! ! Licensing: ! ! This code is distributed under the MIT license. ! ! Modified: ! ! 21 December 2001 ! ! Author: ! ! John Burkardt ! ! Input: ! ! integer N, the order of the matrix. ! ! Output: ! ! real ( kind = rk ) A(N,N), the matrix. ! implicit none integer, parameter :: rk = kind ( 1.0D+00 ) integer n real ( kind = rk ) a(n,n) real ( kind = rk ) angle integer i integer j real ( kind = rk ), parameter :: r8_pi = 3.141592653589793D+00 do j = 1, n do i = 1, n angle = real ( ( 2 * i - 1 ) * ( j - 1 ), kind = rk ) * r8_pi & / real ( 2 * n, kind = rk ) a(i,j) = cos ( angle ) / real ( n, kind = rk ) end do end do a(1:n,2:n) = 2.0D+00 * a(1:n,2:n) return end subroutine chow_matrix ( alpha, beta, m, n, a ) !*****************************************************************************80 ! !! chow_matrix() returns the CHOW matrix. ! ! Discussion: ! ! By making ALPHA small compared with BETA, the eigenvalues can ! all be made very close to BETA, and this is useful as a test ! of eigenvalue computing routines. ! ! Formula: ! ! if ( I = J ) ! A(I,J) = ALPHA + BETA ! else if ( J <= I + 1 ) then ! A(I,J) = ALPHA^(I+1-J) ! else ! A(I,J) = 0 ! ! Example: ! ! ALPHA = 2, BETA = 3, M = 5, N = 5 ! ! 5 1 0 0 0 ! 4 5 1 0 0 ! 8 4 5 1 0 ! 16 8 4 5 1 ! 32 16 8 4 5 ! ! Properties: ! ! A is Toeplitz: constant along diagonals. ! ! A is lower Hessenberg. ! ! A is generally not symmetric: A' /= A. ! ! If ALPHA is 0.0, then A is singular if and only if BETA is 0.0. ! ! If BETA is 0.0, then A will be singular if 1 < N. ! ! If BETA is 0.0 and N = 1, then A will be singular if ALPHA is 0.0. ! ! A is persymmetric: A(I,J) = A(N+1-J,N+1-I). ! ! For 1 <= I < N-(N+1)/2, ! ! LAMBDA(I) = BETA + 4 * ALPHA * cos ( i * pi / ( N+2 ) )^2, ! ! For N-(N+1)/2+1 <= I <= N ! ! LAMBDA(I) = BETA ! ! The family of matrices is nested as a function of N. ! ! Licensing: ! ! This code is distributed under the MIT license. ! ! Modified: ! ! 15 April 1999 ! ! Author: ! ! John Burkardt ! ! Reference: ! ! TS Chow, ! A class of Hessenberg matrices with known eigenvalues and inverses, ! SIAM Review, ! Volume 11, Number 3, 1969, pages 391-395. ! ! Graeme Fairweather, ! On the eigenvalues and eigenvectors of a class of Hessenberg matrices, ! SIAM Review, ! Volume 13, Number 2, 1971, pages 220-221. ! ! Input: ! ! real ( kind = rk ) ALPHA, the ALPHA value. A typical value is 1.0. ! ! real ( kind = rk ) BETA, the BETA value. A typical value is 0.0. ! ! integer M, N, the order of the matrix. ! ! Output: ! ! real ( kind = rk ) A(M,N), the matrix. ! implicit none integer, parameter :: rk = kind ( 1.0D+00 ) integer m integer n real ( kind = rk ) a(m,n) real ( kind = rk ) alpha real ( kind = rk ) beta integer i integer j do j = 1, n do i = 1, m if ( i == j - 1 ) then a(i,j) = 1.0D+00 else if ( i == j ) then a(i,j) = alpha + beta else if ( j + 1 <= 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 ) !*****************************************************************************80 ! !! chow_determinant() returns the determinant of the CHOW matrix. ! ! Licensing: ! ! This code is distributed under the MIT license. ! ! Modified: ! ! 14 October 2007 ! ! Author: ! ! John Burkardt ! ! Input: ! ! real ( kind = rk ) ALPHA, the ALPHA value. A typical value is 1.0. ! ! real ( kind = rk ) BETA, the BETA value. A typical value is 0.0. ! ! integer N, the order of the matrix. ! ! Output: ! ! real ( kind = rk ) DETERM, the determinant. ! implicit none integer, parameter :: rk = kind ( 1.0D+00 ) integer n real ( kind = rk ) alpha real ( kind = rk ) angle real ( kind = rk ) beta real ( kind = rk ) determ integer i integer k real ( kind = rk ), parameter :: r8_pi = 3.141592653589793D+00 determ = 1.0D+00 k = n - ( n / 2 ) do i = 1, k angle = real ( i, kind = rk ) * r8_pi / real ( n + 2, kind = rk ) determ = determ * ( beta + 4.0D+00 * alpha * ( cos ( angle ) ) ** 2 ) end do determ = determ * beta ** ( n - k ) return end subroutine chow_eigen_left ( alpha, beta, n, v ) !*****************************************************************************80 ! !! chow_eigen_left() returns the left eigenvectors for the CHOW matrix. ! ! Licensing: ! ! This code is distributed under the MIT license. ! ! Modified: ! ! 20 May 2002 ! ! Author: ! ! John Burkardt ! ! Input: ! ! real ( kind = rk ) ALPHA, the ALPHA value. A typical value is 1.0. ! ! real ( kind = rk ) BETA, the BETA value. A typical value is 0.0. ! ! integer N, the order of the matrix. ! ! Output: ! ! real ( kind = rk ) V(N,N), the left eigenvector matrix. ! implicit none integer, parameter :: rk = kind ( 1.0D+00 ) integer n real ( kind = rk ) alpha real ( kind = rk ) angle real ( kind = rk ) beta integer i integer j integer k real ( kind = rk ), parameter :: r8_pi = 3.141592653589793D+00 real ( kind = rk ) v(n,n) call r8_fake_use ( beta ) k = n - ( n + 1 ) / 2 do i = 1, k angle = real ( i, kind = rk ) * r8_pi / real ( n + 2, kind = rk ) do j = 1, n v(i,j) = alpha ** ( n - j ) * 2.0D+00 ** ( n - j - 1 ) & * ( cos ( angle ) ) ** ( n - j + 1 ) & * sin ( real ( n - j + 2, kind = rk ) * angle ) / sin ( angle ) end do end do do i = k + 1, n v(i,1:n-2) = 0.0D+00 v(i,n-1) = -alpha v(i,n) = 1.0D+00 end do return end subroutine chow_eigen_right ( alpha, beta, n, u ) !*****************************************************************************80 ! !! chow_eigen_right() returns the right eigenvectors for the CHOW matrix. ! ! Licensing: ! ! This code is distributed under the MIT license. ! ! Modified: ! ! 20 May 2002 ! ! Author: ! ! John Burkardt ! ! Input: ! ! real ( kind = rk ) ALPHA, the ALPHA value. A typical value is 1.0. ! ! real ( kind = rk ) BETA, the BETA value. A typical value is 0.0. ! ! integer N, the order of the matrix. ! ! Output: ! ! real ( kind = rk ) U(N,N), the right eigenvector matrix. ! implicit none integer, parameter :: rk = kind ( 1.0D+00 ) integer n real ( kind = rk ) alpha real ( kind = rk ) angle real ( kind = rk ) beta integer i integer j integer k real ( kind = rk ), parameter :: r8_pi = 3.141592653589793D+00 real ( kind = rk ) u(n,n) call r8_fake_use ( beta ) k = n - ( n + 1 ) / 2 do j = 1, k angle = real ( j, kind = rk ) * r8_pi / real ( n + 2, kind = rk ) do i = 1, n u(i,j) = alpha ** ( i - 1 ) * 2.0D+00 ** ( i - 2 ) & * ( cos ( angle ) ) ** ( i - 2 ) & * sin ( real ( i + 1, kind = rk ) * angle ) / sin ( angle ) end do end do do j = k + 1, n u(1,j) = 1.0D+00 u(2,j) = -alpha u(3:n,j) = 0.0D+00 end do return end subroutine chow_eigenvalues ( alpha, beta, n, lambda ) !*****************************************************************************80 ! !! chow_eigenvalues() returns the eigenvalues of the CHOW matrix. ! ! Example: ! ! ALPHA = 2, BETA = 3, N = 5 ! ! 9.49395943 ! 6.10991621 ! 3.0 ! 3.0 ! 3.0 ! ! Licensing: ! ! This code is distributed under the MIT license. ! ! Modified: ! ! 20 May 2002 ! ! Author: ! ! John Burkardt ! ! Input: ! ! real ( kind = rk ) ALPHA, the ALPHA value. A typical value is 1.0. ! ! real ( kind = rk ) BETA, the BETA value. A typical value is 0.0. ! ! integer N, the order of the matrix. ! ! Output: ! ! real ( kind = rk ) LAMBDA(N), the eigenvalues. ! implicit none integer, parameter :: rk = kind ( 1.0D+00 ) integer n real ( kind = rk ) alpha real ( kind = rk ) angle real ( kind = rk ) beta integer i integer k real ( kind = rk ) lambda(n) real ( kind = rk ), parameter :: r8_pi = 3.141592653589793D+00 k = n - ( n + 1 ) / 2 do i = 1, k angle = real ( i, kind = rk ) * r8_pi / real ( n + 2, kind = rk ) lambda(i) = beta + 4.0D+00 * alpha * ( cos ( angle ) ) ** 2 end do lambda(k+1:n) = beta return end subroutine chow_inverse ( alpha, beta, n, a ) !*****************************************************************************80 ! !! chow_inverse() returns the inverse of the CHOW matrix. ! ! Example: ! ! N = 5, ALPHA = 2.0, BETA = 3.0 ! ! 0.2284 -0.0525 0.0118 -0.0028 0.0006 ! -0.1421 0.2623 -0.0592 0.0141 -0.0028 ! -0.2030 -0.1015 0.2487 -0.0592 0.0118 ! -0.2437 -0.1218 -0.1015 0.2623 -0.0525 ! -0.4873 -0.2437 -0.2030 -0.1421 0.2284 ! ! Licensing: ! ! This code is distributed under the MIT license. ! ! Modified: ! ! 22 May 2002 ! ! Author: ! ! John Burkardt ! ! Input: ! ! real ( kind = rk ) ALPHA, the ALPHA value. A typical value is 1.0. ! ! real ( kind = rk ) BETA, the BETA value. A typical value is 0.0. ! ! integer N, the order of the matrix. ! ! Output: ! ! real ( kind = rk ) A(N,N), the matrix. ! implicit none integer, parameter :: rk = kind ( 1.0D+00 ) integer n real ( kind = rk ) a(n,n) real ( kind = rk ) alpha real ( kind = rk ) beta real ( kind = rk ) d(0:n) real ( kind = rk ) dp(-1:n) integer i integer j real ( kind = rk ) r8_mop a(1:n,1:n) = 0.0D+00 if ( 0.0D+00 == alpha .and. beta == 0.0D+00 ) then write ( *, '(a)' ) ' ' write ( *, '(a)' ) 'CHOW_INVERSE - Fatal error!' write ( *, '(a)' ) ' The Chow matrix is not invertible, because' write ( *, '(a)' ) ' ALPHA = 0 and BETA = 0.' stop 1 else if ( 0.0D+00 == alpha .and. beta /= 0.0D+00 ) then do j = 1, n do i = 1, n if ( i <= j ) then a(i,j) = r8_mop ( j - i ) / beta ** ( j - i + 1 ) else a(i,j) = 0.0D+00 end if end do end do return else if ( 0.0D+00 /= alpha .and. beta == 0.0D+00 ) then if ( 1 < n ) then write ( *, '(a)' ) ' ' write ( *, '(a)' ) 'CHOW_INVERSE - Fatal error!' write ( *, '(a)' ) ' The Chow matrix is not invertible, because' write ( *, '(a)' ) ' BETA = 0 and 1 < 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 circulant_matrix ( m, n, x, a ) !*****************************************************************************80 ! !! circulant_matrix() returns the CIRCULANT matrix. ! ! Formula: ! ! K = 1 + mod ( J-I, N ) ! A(I,J) = X(K) ! ! Example: ! ! M = 4, N = 4, X = ( 1, 2, 3, 4 ) ! ! 1 2 3 4 ! 4 1 2 3 ! 3 4 1 2 ! 2 3 4 1 ! ! M = 4, N = 5, X = ( 1, 2, 3, 4, 5 ) ! ! 1 2 3 4 5 ! 5 1 2 3 4 ! 4 5 1 2 3 ! 3 4 5 1 2 ! ! M = 5, N = 4, X = ( 1, 2, 3, 4 ) ! ! 1 2 3 4 ! 5 1 2 3 ! 4 5 1 2 ! 3 4 5 1 ! 1 2 3 4 ! ! Discussion: ! ! Westlake lists the following "special" circulants: ! ! B2, X = ( T^2, 1, 2, ..., T, T+1, T, T-1, ..., 1 ), ! with T = ( N - 2 ) / 2; ! ! B3, X = ( N+1, 1, 1, ..., 1 ); ! ! B5, X = ( 1, 2, 3, ..., N ). ! ! Properties: ! ! The product of two circulant matrices is a circulant matrix. ! ! The transpose of a circulant matrix is a circulant matrix. ! ! A circulant matrix C, whose first row is (c1, c2, ..., cn), can be ! written as a polynomial in the upshift matrix U: ! ! C = c1 * I + c2 * U + c3 * U^2 + ... + cn * U^n-1. ! ! A is a circulant: each row is shifted once to get the next row. ! ! A is generally not symmetric: A' /= A. ! ! A is Toeplitz: constant along diagonals. ! ! A is persymmetric: A(I,J) = A(N+1-J,N+1-I). ! ! A commutes with any other circulant matrix. ! ! A is normal. ! ! The transpose of A is also a circulant matrix. ! ! A has constant row sums. ! ! Because A has constant row sums, ! it has an eigenvalue with this value, ! and a right eigenvector of ( 1, 1, 1, ..., 1 ). ! ! A has constant column sums. ! ! Because A has constant column sums, ! it has an eigenvalue with this value, ! and a left eigenvector of ( 1, 1, 1, ..., 1 ). ! ! The inverse of A is also a circulant matrix. ! ! The Fourier matrix is the eigenvector matrix for every circulant matrix. ! ! Because the Fourier matrix F diagonalizes A, the inverse (or ! pseudoinverse, if any LAMBDA is zero) can be written ! ! inverse ( A ) = (F*) * 1/LAMBDA * F ! ! A is symmetric if, for all I, X(I+1) = X(N-I+1). ! ! If R is an N-th root of unity, that is, R is a complex number such ! that R^N = 1, then ! ! Y = X(1) + X(2)*R + X(3)*R^2 + ... + X(N)*R^(N-1) ! ! is an eigenvalue of A, with eigenvector ! ! ( 1, R, R^2, ..., R^(N-1) ) ! ! and left eigenvector ! ! ( R^(N-1), R^(N-2), ..., R^2, R, 1 ). ! ! Although there are exactly N distinct roots of unity, the circulant ! may have repeated eigenvalues, because of the behavior of the polynomial. ! However, the matrix is guaranteed to have N linearly independent ! eigenvectors. ! ! Licensing: ! ! This code is distributed under the MIT license. ! ! Modified: ! ! 01 July 2000 ! ! Author: ! ! John Burkardt ! ! Reference: ! ! Philip Davis, ! Circulant Matrices, ! Second Edition, ! Chelsea, 1994, ! ISBN13: 978-0828403384, ! LC: QA188.D37. ! ! Robert Gregory, David Karney, ! A Collection of Matrices for Testing Computational Algorithms, ! Wiley, 1969, ! ISBN: 0882756494, ! LC: QA263.68 ! ! Joan Westlake, ! A Handbook of Numerical Matrix Inversion and Solution of ! Linear Equations, ! John Wiley, 1968, ! ISBN13: 978-0471936756, ! LC: QA263.W47. ! ! Input: ! ! integer M, N, the order of the matrix. ! ! real ( kind = rk ) X(N), the values in the first row of A. ! ! Output: ! ! real ( kind = rk ) A(M,N), the matrix. ! implicit none integer, parameter :: rk = kind ( 1.0D+00 ) integer m integer n real ( kind = rk ) a(m,n) integer i integer i4_modp integer j integer k real ( kind = rk ) 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 ) !*****************************************************************************80 ! !! circulant_determinant() returns the determinant of the CIRCULANT matrix. ! ! Licensing: ! ! This code is distributed under the MIT license. ! ! Modified: ! ! 23 November 2007 ! ! Author: ! ! John Burkardt ! ! Input: ! ! integer N, the order of the matrix. ! ! real ( kind = rk ) X(N), the values in the first row of A. ! ! Output: ! ! real ( kind = rk ) DETERM, the determinant. ! implicit none integer, parameter :: rk = kind ( 1.0D+00 ) integer, parameter :: ck = kind ( ( 1.0D+00, 1.0D+00 ) ) integer n real ( kind = rk ) determ integer i complex ( kind = ck ) lambda(n) complex ( kind = ck ) w(n) real ( kind = rk ) x(n) call c8vec_unity ( n, w ) lambda(1:n) = cmplx ( x(n), 0.0D+00, kind = ck ) do i = n-1, 1, -1 lambda(1:n) = lambda(1:n) * w(1:n) + cmplx ( x(i), 0.0D+00, kind = ck ) end do ! ! First eigenvalue is "special". ! determ = real ( lambda(1), kind = rk ) ! ! Eigenvalues 2, 3, through ( N + 1 ) / 2 are paired with complex conjugates. ! do i = 2, ( n + 1 ) / 2 determ = determ * ( abs ( lambda(i) ) ) ** 2 end do ! ! If N is even, there is another unpaired eigenvalue. ! if ( mod ( n, 2 ) == 0 ) then determ = determ * real ( lambda((n/2)+1), kind = rk ) end if return end subroutine circulant_eigenvalues ( n, x, lambda ) !*****************************************************************************80 ! !! circulant_eigenvalues() returns the eigenvalues of the CIRCULANT matrix. ! ! Licensing: ! ! This code is distributed under the MIT license. ! ! Modified: ! ! 12 March 2001 ! ! Author: ! ! John Burkardt ! ! Input: ! ! integer N, the order of the matrix. ! ! real ( kind = rk ) X(N), the values in the first row of A. ! ! Output: ! ! complex ( kind = ck ) LAMBDA(N), the eigenvalues. ! implicit none integer, parameter :: rk = kind ( 1.0D+00 ) integer, parameter :: ck = kind ( ( 1.0D+00, 1.0D+00 ) ) integer n integer i complex ( kind = ck ) lambda(n) complex ( kind = ck ) w(n) real ( kind = rk ) x(n) call c8vec_unity ( n, w ) lambda(1:n) = cmplx ( x(n), 0.0D+00, kind = ck ) do i = n-1, 1, -1 lambda(1:n) = lambda(1:n) * w(1:n) + cmplx ( x(i), 0.0D+00, kind = ck ) end do return end subroutine circulant_inverse ( n, x, a ) !*****************************************************************************80 ! !! circulant_inverse() returns the inverse of the CIRCULANT matrix. ! ! Discussion: ! ! The Moore Penrose generalized inverse is computed, so even if ! the circulant is singular, this routine returns a usable result. ! ! Licensing: ! ! This code is distributed under the MIT license. ! ! Modified: ! ! 28 May 2002 ! ! Author: ! ! John Burkardt ! ! Input: ! ! integer N, the order of the matrix. ! ! real ( kind = rk ) X(N), the values that define the circulant matrix. ! ! Output: ! ! real ( kind = rk ) A(N,N), the matrix. ! implicit none integer, parameter :: rk = kind ( 1.0D+00 ) integer, parameter :: ck = kind ( ( 1.0D+00, 1.0D+00 ) ) integer n real ( kind = rk ) a(n,n) complex ( kind = ck ) b(n,n) complex ( kind = ck ) c8_zero complex ( kind = ck ) f(n,n) integer i complex ( kind = ck ) lambda(n) real ( kind = rk ) x(n) call circulant_eigenvalues ( n, x, lambda ) b(1:n,1:n) = c8_zero ( ) do i = 1, n if ( lambda(i) /= c8_zero ( ) ) then b(i,i) = 1.0D+00 / conjg ( lambda(i) ) end if end do call fourier_matrix ( n, f ) a(1:n,1:n) = real ( matmul ( conjg ( transpose ( f(1:n,1:n) ) ), & matmul ( b(1:n,1:n), f(1:n,1:n) ) ) ) return end subroutine circulant2_matrix ( n, a ) !*****************************************************************************80 ! !! circulant2_matrix() returns the CIRCULANT2 matrix. ! ! Formula: ! ! K = 1 + mod ( J-I, N ) ! A(I,J) = K ! ! Example: ! ! N = 5 ! ! 1 2 3 4 5 ! 5 1 2 3 4 ! 4 5 1 2 3 ! 3 4 5 1 2 ! 2 3 4 5 1 ! ! Properties: ! ! A is generally not symmetric: A' /= A. ! ! A is a circulant: each row is shifted once to get the next row. ! ! A is Toeplitz: constant along diagonals. ! ! A is persymmetric: A(I,J) = A(N+1-J,N+1-I). ! ! A commutes with any other circulant. ! ! A is normal. ! ! The inverse of A is a circulant matrix. ! ! The eigenvector matrix is the Fourier matrix. ! ! A has constant row sums. ! ! Because A has constant row sums, ! it has an eigenvalue with this value, ! and a right eigenvector of ( 1, 1, 1, ..., 1 ). ! ! A has constant column sums. ! ! Because A has constant column sums, ! it has an eigenvalue with this value, ! and a left eigenvector of ( 1, 1, 1, ..., 1 ). ! ! If R is an N-th root of unity, that is, R is a complex number such ! that R^N = 1, then ! ! Y = 1 + 2*R + 3*R^2 + ... + N*R^(N-1) ! ! is an eigenvalue of A, with eigenvector ! ! ( 1, R, R^2, ..., R^(N-1) ) ! ! and left eigenvector ! ! ( R^(N-1), R^(N-2), ..., R^2, R, 1 ). ! ! Although there are exactly N distinct roots of unity, the circulant ! may have repeated eigenvalues, because of the behavior of the polynomial. ! However, the matrix is guaranteed to have N linearly independent ! eigenvectors. ! ! Licensing: ! ! This code is distributed under the MIT license. ! ! Modified: ! ! 27 May 2002 ! ! Author: ! ! John Burkardt ! ! Reference: ! ! Philip Davis, ! Circulant Matrices, ! Second Edition, ! Chelsea, 1994, ! ISBN13: 978-0828403384, ! LC: QA188.D37. ! ! Robert Gregory, David Karney, ! A Collection of Matrices for Testing Computational Algorithms, ! Wiley, 1969, ! ISBN: 0882756494, ! LC: QA263.68 ! ! Morris Newman, John Todd, ! The evaluation of matrix inversion programs, ! Journal of the Society for Industrial and Applied Mathematics, ! Volume 6, Number 4, pages 466-476, 1958. ! ! Joan Westlake, ! A Handbook of Numerical Matrix Inversion and Solution of ! Linear Equations, ! John Wiley, 1968, ! ISBN13: 978-0471936756, ! LC: QA263.W47. ! ! Input: ! ! integer N, the order of the matrix. ! ! Output: ! ! real ( kind = rk ) A(N,N), the matrix. ! implicit none integer, parameter :: rk = kind ( 1.0D+00 ) integer n real ( kind = rk ) 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) = real ( k, kind = rk ) end do end do return end subroutine circulant2_determinant ( n, determ ) !*****************************************************************************80 ! !! circulant2_determinant() returns the determinant of the CIRCULANT2 matrix. ! ! Licensing: ! ! This code is distributed under the MIT license. ! ! Modified: ! ! 23 November 2007 ! ! Author: ! ! John Burkardt ! ! Input: ! ! integer N, the order of the matrix. ! ! Output: ! ! real ( kind = rk ) DETERM, the determinant. ! implicit none integer, parameter :: rk = kind ( 1.0D+00 ) integer, parameter :: ck = kind ( ( 1.0D+00, 1.0D+00 ) ) integer n real ( kind = rk ) determ integer i complex ( kind = ck ) lambda(n) complex ( kind = ck ) w(n) call c8vec_unity ( n, w ) lambda(1:n) = cmplx ( n, 0.0D+00, kind = ck ) do i = n-1, 1, -1 lambda(1:n) = lambda(1:n) * w(1:n) + cmplx ( i, 0.0D+00, kind = ck ) end do ! ! First eigenvalue is "special". ! determ = real ( lambda(1), kind = rk ) ! ! Eigenvalues 2, 3 through ( N + 1 ) / 2 are paired with complex conjugates. ! do i = 2, ( n + 1 ) / 2 determ = determ * ( abs ( lambda(i) ) ) ** 2 end do ! ! If N is even, there is another unpaired eigenvalue. ! if ( mod ( n, 2 ) == 0 ) then determ = determ * real ( lambda((n/2)+1), kind = rk ) end if return end subroutine circulant2_eigenvalues ( n, lambda ) !*****************************************************************************80 ! !! circulant2_eigenvalues() returns the eigenvalues of the CIRCULANT2 matrix. ! ! Licensing: ! ! This code is distributed under the MIT license. ! ! Modified: ! ! 23 November 2007 ! ! Author: ! ! John Burkardt ! ! Input: ! ! integer N, the order of the matrix. ! ! Output: ! ! complex ( kind = ck ) LAMBDA(N), the eigenvalues. ! implicit none integer, parameter :: rk = kind ( 1.0D+00 ) integer, parameter :: ck = kind ( ( 1.0D+00, 1.0D+00 ) ) integer n integer i complex ( kind = ck ) lambda(n) complex ( kind = ck ) w(n) call c8vec_unity ( n, w ) lambda(1:n) = cmplx ( n, 0.0D+00, kind = ck ) do i = n-1, 1, -1 lambda(1:n) = lambda(1:n) * w(1:n) + cmplx ( i, 0.0D+00, kind = ck ) end do return end subroutine circulant2_inverse ( n, a ) !*****************************************************************************80 ! !! circulant2_inverse() returns the inverse of the CIRCULANT2 matrix. ! ! Discussion: ! ! The Moore Penrose generalized inverse is computed, so even if ! the circulant is singular, this routine returns a usable result. ! ! Licensing: ! ! This code is distributed under the MIT license. ! ! Modified: ! ! 17 October 2007 ! ! Author: ! ! John Burkardt ! ! Input: ! ! integer N, the order of the matrix. ! ! Output: ! ! real ( kind = rk ) A(N,N), the matrix. ! implicit none integer, parameter :: rk = kind ( 1.0D+00 ) integer, parameter :: ck = kind ( ( 1.0D+00, 1.0D+00 ) ) integer n real ( kind = rk ) a(n,n) complex ( kind = ck ) b(n,n) complex ( kind = ck ) c8_zero complex ( kind = ck ) f(n,n) integer i complex ( kind = ck ) lambda(n) call circulant2_eigenvalues ( n, lambda ) b(1:n,1:n) = c8_zero ( ) do i = 1, n if ( lambda(i) /= c8_zero ( ) ) then b(i,i) = 1.0D+00 / conjg ( lambda(i) ) end if end do call fourier_matrix ( n, f ) a(1:n,1:n) = real ( matmul ( conjg ( transpose ( f(1:n,1:n) ) ), & matmul ( b(1:n,1:n), f(1:n,1:n) ) ) ) return end subroutine clement1_matrix ( n, a ) !*****************************************************************************80 ! !! clement1_matrix() returns the CLEMENT1 matrix. ! ! Formula: ! ! if ( J = I + 1 ) ! A(I,J) = sqrt(I*(N-I)) ! else if ( I = J + 1 ) ! A(I,J) = sqrt(J*(N-J)) ! else ! A(I,J) = 0 ! ! Example: ! ! N = 6 ! ! 0 2.2361 0 0 0 0 ! 2.2361 0 2.8284 0 0 0 ! 0 2.8284 0 3.0000 0 0 ! 0 0 3.0000 0 2.8284 0 ! 0 0 0 2.8284 0 2.2361 ! 0 0 0 0 2.2361 0 . ! ! Properties: ! ! A is tridiagonal. ! ! A is banded, with bandwidth 3. ! ! Because A is tridiagonal, it has property A (bipartite). ! ! A is symmetric: A' = A. ! ! Because A is symmetric, it is normal. ! ! Because A is normal, it is diagonalizable. ! ! A is persymmetric: A(I,J) = A(N+1-J,N+1-I). ! ! The diagonal of A is zero. ! ! A is singular if N is odd. ! ! About 64 percent of the entries of the inverse of A are zero. ! ! The eigenvalues are plus and minus the numbers ! N-1, N-3, N-5, ..., (1 or 0). ! ! If N is even, ! det ( A ) = (-1)^(N/2) * (N-1) * (N+1)^(N/2) ! and if N is odd, ! det ( A ) = 0 ! ! Licensing: ! ! This code is distributed under the MIT license. ! ! Modified: ! ! 15 April 1999 ! ! Author: ! ! John Burkardt ! ! Reference: ! ! Paul Clement, ! A class of triple-diagonal matrices for test purposes, ! SIAM Review, ! Volume 1, 1959, pages 50-52. ! ! Input: ! ! integer N, the order of the matrix. ! ! Output: ! ! real ( kind = rk ) A(N,N), the matrix. ! implicit none integer, parameter :: rk = kind ( 1.0D+00 ) integer n real ( kind = rk ) a(n,n) integer i integer j do j = 1, n do i = 1, n if ( j == i + 1 ) then a(i,j) = sqrt ( real ( i * ( n - i ), kind = rk ) ) else if ( i == j + 1 ) then a(i,j) = sqrt ( real ( j * ( n - j ), kind = rk ) ) else a(i,j) = 0.0D+00 end if end do end do return end subroutine clement1_determinant ( n, determ ) !*****************************************************************************80 ! !! clement1_determinant() returns the determinant of the CLEMENT1 matrix. ! ! Licensing: ! ! This code is distributed under the MIT license. ! ! Modified: ! ! 21 May 2002 ! ! Author: ! ! John Burkardt ! ! Input: ! ! integer N, the order of the matrix. ! ! Output: ! ! real ( kind = rk ) DETERM, the determinant. ! implicit none integer, parameter :: rk = kind ( 1.0D+00 ) real ( kind = rk ) determ integer i integer n if ( mod ( n, 2 ) == 1 ) then determ = 0.0D+00 else determ = 1.0D+00 do i = 1, n - 1, 2 determ = determ * real ( i * ( n - i ), kind = rk ) end do if ( mod ( n / 2, 2 ) == 1 ) then determ = - determ end if end if return end subroutine clement1_eigenvalues ( n, lambda ) !*****************************************************************************80 ! !! clement1_eigenvalues() returns the eigenvalues of the CLEMENT1 matrix. ! ! Licensing: ! ! This code is distributed under the MIT license. ! ! Modified: ! ! 06 June 2008 ! ! Author: ! ! John Burkardt ! ! Input: ! ! integer N, the order of the matrix. ! ! Output: ! ! real ( kind = rk ) LAMBDA(N), the eigenvalues. ! implicit none integer, parameter :: rk = kind ( 1.0D+00 ) integer n integer i real ( kind = rk ) lambda(n) do i = 1, n lambda(i) = real ( - n - 1 + 2 * i, kind = rk ) end do return end subroutine clement1_inverse ( n, a ) !*****************************************************************************80 ! !! clement1_inverse() returns the inverse of the CLEMENT1 matrix. ! ! Example: ! ! N = 6 ! ! 0 0.4472 0 -0.4216 0 0.5333 ! 0.4472 0 0 0 0 0 ! 0 0 0 0.3333 0 -0.4216 ! -0.4216 0 0.3333 0 0 0 ! 0 0 0 0 0 0.4472 ! 0.5333 0 -0.4216 0 0.4472 0 ! ! Licensing: ! ! This code is distributed under the MIT license. ! ! Modified: ! ! 22 May 2002 ! ! Author: ! ! John Burkardt ! ! Input: ! ! integer N, the order of the matrix. N must not be odd! ! ! Output: ! ! real ( kind = rk ) A(N,N), the matrix. ! implicit none integer, parameter :: rk = kind ( 1.0D+00 ) integer n real ( kind = rk ) a(n,n) integer i integer j real ( kind = rk ) prod if ( mod ( n, 2 ) == 1 ) then write ( *, '(a)' ) ' ' write ( *, '(a)' ) 'CLEMENT1_INVERSE - Fatal error!' write ( *, '(a)' ) ' The matrix is singular for odd N.' stop 1 end if a(1:n,1:n) = 0.0D+00 do i = 1, n if ( mod ( i, 2 ) == 1 ) then prod = 1.0D+00 do j = i, n - 1, 2 if ( j == i ) then prod = prod / sqrt ( real ( j * ( n - j ), kind = rk ) ) else prod = - prod & * sqrt ( real ( ( j - 1 ) * ( n + 1 - j ), kind = rk ) ) & / sqrt ( real ( j * ( n - j ), kind = rk ) ) end if a(i,j+1) = prod a(j+1,i) = prod end do end if end do return end subroutine clement2_matrix ( n, x, y, a ) !*****************************************************************************80 ! !! clement2_matrix() returns the CLEMENT2 matrix. ! ! Formula: ! ! if ( J = I + 1 ) then ! A(I,J) = X(I) ! else if ( I = J + 1 ) then ! A(I,J) = Y(J) ! else ! A(I,J) = 0 ! ! Example: ! ! N = 5, X and Y arbitrary: ! ! . X(1) . . . ! Y(1) . X(2) . . ! . Y(2) . X(3) . ! . . Y(3) . X(4) ! . . . Y(4) . ! ! N = 5, X=(1,2,3,4), Y=(5,6,7,8): ! ! . 1 . . . ! 5 . 2 . . ! . 6 . 3 . ! . . 7 . 4 ! . . . 8 . ! ! Properties: ! ! A is generally not symmetric: A' /= A. ! ! A is tridiagonal. ! ! Because A is tridiagonal, it has property A (bipartite). ! ! A is banded, with bandwidth 3. ! ! The diagonal of A is zero. ! ! A is singular if N is odd. ! ! About 64 percent of the entries of the inverse of A are zero. ! ! If N is even, ! ! det ( A ) = (-1)^(N/2) * product ( 1 <= I <= N/2 ) ! ( X(2*I-1) * Y(2*I-1) ) ! ! and if N is odd, ! ! det ( A ) = 0. ! ! The family of matrices is nested as a function of N. ! ! Licensing: ! ! This code is distributed under the MIT license. ! ! Modified: ! ! 15 April 1999 ! ! Author: ! ! John Burkardt ! ! Reference: ! ! Paul Clement, ! A class of triple-diagonal matrices for test purposes, ! SIAM Review, ! Volume 1, 1959, pages 50-52. ! ! Alan Edelman, Eric Kostlan, ! The road from Kac's matrix to Kac's random polynomials. ! In Proceedings of the Fifth SIAM Conference on Applied Linear Algebra, ! edited by John Lewis, ! SIAM, 1994, pages 503-507. ! ! Robert Gregory, David Karney, ! A Collection of Matrices for Testing Computational Algorithms, ! Wiley, 1969, ! ISBN: 0882756494, ! LC: QA263.68 ! ! Olga Taussky, John Todd, ! Another look at a matrix of Mark Kac, ! Linear Algebra and Applications, ! Volume 150, 1991, pages 341-360. ! ! Input: ! ! integer N, the order of the matrix. ! ! real ( kind = rk ) X(N-1), Y(N-1), the first super and ! subdiagonals of the matrix A. ! ! Output: ! ! real ( kind = rk ) A(N,N), the matrix. ! implicit none integer, parameter :: rk = kind ( 1.0D+00 ) integer n real ( kind = rk ) a(n,n) integer i integer j real ( kind = rk ) x(n-1) real ( kind = rk ) y(n-1) do j = 1, n do i = 1, n if ( j == i + 1 ) then a(i,j) = x(i) else if ( i == 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 ) !*****************************************************************************80 ! !! clement2_determinant() returns the determinant of the CLEMENT2 matrix. ! ! Licensing: ! ! This code is distributed under the MIT license. ! ! Modified: ! ! 21 May 2002 ! ! Author: ! ! John Burkardt ! ! Input: ! ! integer N, the order of the matrix. ! ! real ( kind = rk ) X(N-1), Y(N-1), the first super and ! subdiagonals of the matrix A. ! ! Output: ! ! real ( kind = rk ) DETERM, the determinant. ! implicit none integer, parameter :: rk = kind ( 1.0D+00 ) integer n real ( kind = rk ) determ integer i real ( kind = rk ) x(n-1) real ( kind = rk ) y(n-1) if ( mod ( n, 2 ) == 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 ) == 1 ) then determ = -determ end if end if return end subroutine clement2_inverse ( n, x, y, a ) !*****************************************************************************80 ! !! clement2_inverse() returns the inverse of the CLEMENT2 matrix. ! ! Example: ! ! N = 6, X and Y arbitrary: ! ! 0 1/Y1 0 -X2/(Y1*Y3) 0 X2*X4/(Y1*Y3*Y5) ! 1/X1 0 0 0 0 0 ! 0 0 0 1/Y3 0 -X4/(Y3*Y5) ! -Y2/(X1*X3) 0 1/X3 0 0 0 ! 0 0 0 0 0 1/Y5 ! Y2*Y4/(X1*X3*X5) 0 -Y4/(X3*X5) 0 1/X5 0 ! ! Licensing: ! ! This code is distributed under the MIT license. ! ! Modified: ! ! 15 April 1999 ! ! Author: ! ! John Burkardt ! ! Reference: ! ! Paul Clement, ! A class of triple-diagonal matrices for test purposes, ! SIAM Review, ! Volume 1, 1959, pages 50-52. ! ! Input: ! ! integer N, the order of the matrix. N must not be odd! ! ! real ( kind = rk ) X(N-1), Y(N-1), the first super and ! subdiagonals of the matrix A. None of the entries ! of X or Y may be zero. ! ! Output: ! ! real ( kind = rk ) A(N,N), the matrix. ! implicit none integer, parameter :: rk = kind ( 1.0D+00 ) integer n real ( kind = rk ) a(n,n) integer i integer j real ( kind = rk ) p1 real ( kind = rk ) p2 real ( kind = rk ) x(n-1) real ( kind = rk ) y(n-1) if ( mod ( n, 2 ) == 1 ) then write ( *, '(a)' ) ' ' write ( *, '(a)' ) 'CLEMENT2_INVERSE - Fatal error!' write ( *, '(a)' ) ' The matrix is singular for odd N.' stop 1 end if do i = 1, n - 1 if ( x(i) == 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) == 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 a(1:n,1:n) = 0.0D+00 do i = 1, n if ( mod ( i, 2 ) == 1 ) then p1 = 1.0D+00 p2 = 1.0D+00 do j = i, n - 1, 2 if ( j == i ) then p1 = p1 / y(j) p2 = p2 / x(j) else p1 = - p1 * x(j-1) / y(j) p2 = - p2 * y(j-1) / x(j) end if a(i,j+1) = p1 a(j+1,i) = p2 end do end if end do return end subroutine colleague_matrix ( n, c, a ) !*****************************************************************************80 ! !! colleague_matrix() returns the COLLEAGUE matrix. ! ! Discussion: ! ! The colleague matrix is an analog of the companion matrix, adapted ! for use with polynomials represented by a sum of Chebyshev polynomials. ! ! Let the N-th degree polynomial be defined by ! ! P(X) = C(N)*T_N(X) + C(N-1)*T_(N-1)(X) + ... + C(1)*T1(X) + C(0)*T0(X) ! ! where T_I(X) is the I-th Chebyshev polynomial. ! ! Then the roots of P(X) are the eigenvalues of the colleague matrix A(C): ! ! 0 1 0 ... 0 0 0 0 ... 0 ! 1/2 0 1/2 ... 0 0 0 0 ... 0 ! 0 1/2 0 ... 0 - 1/(2*C(N)) * 0 0 0 ... 0 ! ... ... ... ... ... ... ... ... ... ... ! ... ... ... 0 1/2 ... ... ... ... 0 ! ... ... ... 1/2 0 C(0) C(1) C(2) ... C(N-1) ! ! Licensing: ! ! This code is distributed under the MIT license. ! ! Modified: ! ! 09 March 2015 ! ! Author: ! ! John Burkardt ! ! Reference: ! ! I J Good, ! The Colleague Matrix: A Chebyshev Analogue of the Companion Matrix, ! The Quarterly Journal of Mathematics, ! Volume 12, Number 1, 1961, pages 61-68. ! ! Input: ! ! integer N, the order of the matrix. ! ! real ( kind = rk ) C(0:N), the coefficients of the polynomial. ! C(N) should not be zero! ! ! Output: ! ! real ( kind = rk ) A(N,N), the matrix. ! implicit none integer, parameter :: rk = kind ( 1.0D+00 ) integer n real ( kind = rk ) a(n,n) real ( kind = rk ) c(0:n) integer i if ( n == 1 ) then a(1,1) = - c(0) / c(1) else a(1:n,1:n) = 0.0D+00 a(1,2) = 1.0D+00 do i = 2, n a(i,i-1) = 0.5D+00 end do do i = 2, n - 1 a(i,i+1) = 0.5D+00 end do a(n,1:n) = a(n,1:n) - 0.5D+00 * c(0:n-1) / c(n) end if return end subroutine combin_matrix ( alpha, beta, n, a ) !*****************************************************************************80 ! !! combin_matrix() returns the COMBIN matrix. ! ! Discussion: ! ! This matrix is known as the combinatorial matrix. ! ! Formula: ! ! If ( I = J ) then ! A(I,J) = ALPHA + BETA ! else ! A(I,J) = BETA ! ! Example: ! ! N = 5, ALPHA = 2, BETA = 3 ! ! 5 3 3 3 3 ! 3 5 3 3 3 ! 3 3 5 3 3 ! 3 3 3 5 3 ! 3 3 3 3 5 ! ! Properties: ! ! A is symmetric: A' = A. ! ! Because A is symmetric, it is normal. ! ! Because A is normal, it is diagonalizable. ! ! A is persymmetric: A(I,J) = A(N+1-J,N+1-I). ! ! A is a circulant matrix: each row is shifted once to get the next row. ! ! det ( A ) = ALPHA^(N-1) * ( ALPHA + N * BETA ). ! ! A has constant row sums. ! ! Because A has constant row sums, ! it has an eigenvalue with this value, ! and a right eigenvector of ( 1, 1, 1, ..., 1 ). ! ! A has constant column sums. ! ! Because A has constant column sums, ! it has an eigenvalue with this value, ! and a left eigenvector of ( 1, 1, 1, ..., 1 ). ! ! LAMBDA(1:N-1) = ALPHA, ! LAMBDA(N) = ALPHA + N * BETA. ! ! The eigenvector associated with LAMBDA(N) is (1,1,1,...,1)/sqrt(N). ! ! The other N-1 eigenvectors are simply any (orthonormal) basis ! for the space perpendicular to (1,1,1,...,1). ! ! A is nonsingular if ALPHA /= 0 and ALPHA + N * BETA /= 0. ! ! The family of matrices is nested as a function of N. ! ! Licensing: ! ! This code is distributed under the MIT license. ! ! Modified: ! ! 15 April 1999 ! ! Author: ! ! John Burkardt ! ! Reference: ! ! Robert Gregory, David Karney, ! A Collection of Matrices for Testing Computational Algorithms, ! Wiley, 1969, ! ISBN: 0882756494, ! LC: QA263.68 ! ! Donald Knuth, ! The Art of Computer Programming, ! Volume 1, Fundamental Algorithms, Second Edition, ! Addison-Wesley, Reading, Massachusetts, 1973, page 36. ! ! Input: ! ! real ( kind = rk ) ALPHA, BETA, scalars that define A. ! ! integer N, the order of the matrix. ! ! Output: ! ! real ( kind = rk ) A(N,N), the matrix. ! implicit none integer, parameter :: rk = kind ( 1.0D+00 ) integer n real ( kind = rk ) a(n,n) real ( kind = rk ) alpha real ( kind = rk ) beta integer i a(1:n,1:n) = beta do i = 1, n a(i,i) = a(i,i) + alpha end do return end subroutine combin_condition ( alpha, beta, n, cond ) !*****************************************************************************80 ! !! combin_condition() returns the L1 condition of the COMBIN matrix. ! ! Licensing: ! ! This code is distributed under the MIT license. ! ! Modified: ! ! 08 April 2012 ! ! Author: ! ! John Burkardt ! ! Input: ! ! real ( kind = rk ) ALPHA, BETA, scalars that define A. ! ! integer N, the order of the matrix. ! ! Output: ! ! real ( kind = rk ) COND, the L1 condition. ! implicit none integer, parameter :: rk = kind ( 1.0D+00 ) real ( kind = rk ) alpha real ( kind = rk ) a_norm real ( kind = rk ) beta real ( kind = rk ) b_norm real ( kind = rk ) b_norm_bot real ( kind = rk ) b_norm_top real ( kind = rk ) cond integer n a_norm = abs ( alpha + beta ) + real ( n - 1, kind = rk ) * abs ( beta ) b_norm_top = abs ( alpha + real ( n - 1, kind = rk ) * beta ) & + real ( n - 1, kind = rk ) * abs ( beta ) b_norm_bot = abs ( alpha * ( alpha + real ( n, kind = rk ) * beta ) ) b_norm = b_norm_top / b_norm_bot cond = a_norm * b_norm return end subroutine combin_determinant ( alpha, beta, n, determ ) !*****************************************************************************80 ! !! combin_determinant() returns the determinant of the COMBIN matrix. ! ! Licensing: ! ! This code is distributed under the MIT license. ! ! Modified: ! ! 21 May 2002 ! ! Author: ! ! John Burkardt ! ! Input: ! ! real ( kind = rk ) ALPHA, BETA, scalars that define A. ! ! integer N, the order of the matrix. ! ! Output: ! ! real ( kind = rk ) DETERM, the determinant. ! implicit none integer, parameter :: rk = kind ( 1.0D+00 ) real ( kind = rk ) alpha real ( kind = rk ) beta real ( kind = rk ) determ integer n determ = alpha ** ( n - 1 ) * ( alpha + real ( n, kind = rk ) * beta ) return end subroutine combin_eigen_right ( alpha, beta, n, x ) !*****************************************************************************80 ! !! combin_eigen_right() returns the right eigenvectors of the COMBIN matrix. ! ! Licensing: ! ! This code is distributed under the MIT license. ! ! Modified: ! ! 25 November 2007 ! ! Author: ! ! John Burkardt ! ! Input: ! ! real ( kind = rk ) ALPHA, BETA, scalars that define A. ! ! integer N, the order of the matrix. ! ! Output: ! ! real ( kind = rk ) X(N,N), the right eigenvectors. ! implicit none integer, parameter :: rk = kind ( 1.0D+00 ) integer n real ( kind = rk ) alpha real ( kind = rk ) beta integer j real ( kind = rk ) x(n,n) call r8_fake_use ( alpha ) call r8_fake_use ( beta ) x(1:n,1:n) = 0.0D+00 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 combin_eigenvalues ( alpha, beta, n, lambda ) !*****************************************************************************80 ! !! combin_eigenvalues() returns the eigenvalues of the COMBIN matrix. ! ! Licensing: ! ! This code is distributed under the MIT license. ! ! Modified: ! ! 22 May 2002 ! ! Author: ! ! John Burkardt ! ! Input: ! ! real ( kind = rk ) ALPHA, BETA, scalars that define A. ! ! integer N, the order of the matrix. ! ! Output: ! ! real ( kind = rk ) LAMBDA(N), the eigenvalues. ! implicit none integer, parameter :: rk = kind ( 1.0D+00 ) integer n real ( kind = rk ) alpha real ( kind = rk ) beta real ( kind = rk ) lambda(n) lambda(1:n-1) = alpha lambda(n) = alpha + real ( n, kind = rk ) * beta return end subroutine combin_inverse ( alpha, beta, n, a ) !*****************************************************************************80 ! !! combin_inverse() returns the inverse of the COMBIN matrix. ! ! Formula: ! ! if ( I = J ) ! A(I,J) = (ALPHA+(N-1)*BETA) / (ALPHA*(ALPHA+N*BETA)) ! else ! A(I,J) = - BETA / (ALPHA*(ALPHA+N*BETA)) ! ! Example: ! ! N = 5, ALPHA = 2, BETA = 3 ! ! 14 -3 -3 -3 -3 ! -3 14 -3 -3 -3 ! 1/34 * -3 -3 14 -3 -3 ! -3 -3 -3 14 -3 ! -3 -3 -3 -3 14 ! ! Properties: ! ! A is symmetric: A' = A. ! ! Because A is symmetric, it is normal. ! ! Because A is normal, it is diagonalizable. ! ! A is persymmetric: A(I,J) = A(N+1-J,N+1-I). ! ! A is a circulant matrix: each row is shifted once to get the next row. ! ! A is Toeplitz: constant along diagonals. ! ! det ( A ) = 1 / (ALPHA^(N-1) * (ALPHA+N*BETA)). ! ! A is well defined if ALPHA /= 0D+00 and ALPHA+N*BETA /= 0. ! ! Licensing: ! ! This code is distributed under the MIT license. ! ! Modified: ! ! 15 April 1999 ! ! Author: ! ! John Burkardt ! ! Reference: ! ! Donald Knuth, ! The Art of Computer Programming, ! Volume 1, Fundamental Algorithms, Second Edition, ! Addison-Wesley, Reading, Massachusetts, 1973, page 36. ! ! Input: ! ! real ( kind = rk ) ALPHA, BETA, scalars that define the matrix. ! ! integer N, the order of the matrix. ! ! Output: ! ! real ( kind = rk ) A(N,N), the matrix. ! implicit none integer, parameter :: rk = kind ( 1.0D+00 ) integer n real ( kind = rk ) a(n,n) real ( kind = rk ) alpha real ( kind = rk ) beta real ( kind = rk ) bot integer i integer j if ( alpha == 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 == 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 + real ( n, kind = rk ) * beta ) do j = 1, n do i = 1, n if ( i == j ) then a(i,j) = ( alpha + real ( n - 1, kind = rk ) * beta ) / bot else a(i,j) = - beta / bot end if end do end do return end subroutine companion_matrix ( n, x, a ) !*****************************************************************************80 ! !! companion_matrix() returns the COMPANION matrix. ! ! Discussion: ! ! Let the monic N-th degree polynomial be defined by ! ! P(t) = t^N + X(N)*t^(N-1) + X(N-1)*t^(N-2) + ... + X(2)*t + X(1) ! ! Then ! ! A(1,J) = X(N+1-J) for J=1 to N ! A(I,I-1) = 1 for I=2 to N ! A(I,J) = 0 otherwise ! ! A is called the companion matrix of the polynomial P(t), and the ! characteristic equation of A is P(t) = 0. ! ! Matrices of this form are also called Frobenius matrices. ! ! The determinant of a matrix is unaffected by being transposed, ! and only possibly changes sign if the rows are "reflected", so ! there are actually many possible ways to write a companion matrix: ! ! A B C D A 1 0 0 0 1 0 0 0 0 1 0 0 0 1 A ! 1 0 0 0 B 0 1 0 0 0 1 0 0 1 0 0 0 1 0 B ! 0 1 0 0 C 0 0 1 0 0 0 1 1 0 0 0 1 0 0 C ! 0 0 1 0 D 0 0 0 D C B A A B C D 0 0 0 D ! ! Example: ! ! N = 5, X = ( 1, 2, 3, 4, 5 ) ! ! 5 4 3 2 1 ! 1 0 0 0 0 ! 0 1 0 0 0 ! 0 0 1 0 0 ! 0 0 0 1 0 ! ! Properties: ! ! A is generally not symmetric: A' /= A. ! ! A is nonsingular if and only if X(1) is nonzero. ! ! The eigenvalues of A are the roots of P(t) = 0. ! ! If LAMBDA is an eigenvalue of A, then a corresponding eigenvector is ! ( 1, LAMBDA, LAMBDA^2, ..., LAMBDA^(N-1) ). ! ! If LAMBDA is an eigenvalue of multiplicity 2, then a second ! corresponding generalized eigenvector is ! ! ( 0, 1, 2 * LAMBDA, ..., (N-1)*LAMBDA^(N-2) ). ! ! For higher multiplicities, repeatedly differentiate with respect to LAMBDA. ! ! Any matrix with characteristic polynomial P(t) is similar to A. ! ! det ( A ) = +/- X(1). ! ! Licensing: ! ! This code is distributed under the MIT license. ! ! Modified: ! ! 14 February 2000 ! ! Author: ! ! John Burkardt ! ! Reference: ! ! Gene Golub, Charles Van Loan, ! Matrix Computations, second edition, ! Johns Hopkins University Press, Baltimore, Maryland, 1989, ! section 7.4.6. ! ! Charles Kenney, Alan Laub, ! Controllability and stability radii for companion form systems, ! Math. Control Signals Systems, ! Volume 1, 1988, pages 239-256. ! ! James Wilkinson, ! The Algebraic Eigenvalue Problem, ! Oxford University Press, ! 1965, page 12. ! ! Input: ! ! integer N, the order of the matrix. ! ! real ( kind = rk ) X(N), the coefficients of the polynomial ! which define A. ! ! Output: ! ! real ( kind = rk ) A(N,N), the matrix. ! implicit none integer, parameter :: rk = kind ( 1.0D+00 ) integer n real ( kind = rk ) a(n,n) integer i integer j real ( kind = rk ) x(n) do j = 1, n do i = 1, n if ( i == 1 ) then a(i,j) = x(n+1-j) else if ( i == 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 ) !*****************************************************************************80 ! !! companion_condition() returns the L1 condition of the COMPANION matrix. ! ! Licensing: ! ! This code is distributed under the MIT license. ! ! Modified: ! ! 21 January 2015 ! ! Author: ! ! John Burkardt ! ! Input: ! ! integer N, the order of the matrix. ! ! real ( kind = rk ) X(N), the coefficients of the polynomial ! which define A. ! ! Output: ! ! real ( kind = rk ) COND, the L1 condition. ! implicit none integer, parameter :: rk = kind ( 1.0D+00 ) integer n real ( kind = rk ) a_norm real ( kind = rk ) b_norm real ( kind = rk ) cond integer i real ( kind = rk ) 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 ) !*****************************************************************************80 ! !! companion_determinant() returns the determinant of the COMPANION matrix. ! ! Licensing: ! ! This code is distributed under the MIT license. ! ! Modified: ! ! 18 October 2007 ! ! Author: ! ! John Burkardt ! ! Input: ! ! integer N, the order of the matrix. ! ! real ( kind = rk ) X(N), the coefficients of the polynomial ! which define A. ! ! Output: ! ! real ( kind = rk ) DETERM, the determinant. ! implicit none integer, parameter :: rk = kind ( 1.0D+00 ) integer n real ( kind = rk ) determ real ( kind = rk ) x(n) if ( mod ( n, 2 ) == 1 ) then determ = + x(1) else determ = - x(1) end if return end subroutine companion_inverse ( n, x, a ) !*****************************************************************************80 ! !! companion_inverse() returns the inverse of the COMPANION matrix. ! ! Example: ! ! N = 5, X = ( 1, 2, 3, 4, 5 ) ! ! 0 1 0 0 0 ! 0 0 1 0 0 ! 0 0 0 1 0 ! 0 0 0 0 1 ! 1/1 -5/1 -4/1 -3/1 -2/1 ! ! Licensing: ! ! This code is distributed under the MIT license. ! ! Modified: ! ! 13 July 2008 ! ! Author: ! ! John Burkardt ! ! Reference: ! ! Gene Golub, Charles Van Loan, ! Matrix Computations, second edition, ! Johns Hopkins University Press, Baltimore, Maryland, 1989, ! section 7.4.6. ! ! Charles Kenney, Alan Laub, ! Controllability and stability radii for companion form systems, ! Math. Control Signals Systems, ! Volume 1, 1988, pages 239-256. ! ! James Wilkinson, ! The Algebraic Eigenvalue Problem, ! Oxford University Press, ! 1965, page 12. ! ! Input: ! ! integer N, the order of the matrix. ! ! real ( kind = rk ) X(N), the coefficients of the polynomial ! which define the matrix. X(1) must not be zero. ! ! Output: ! ! real ( kind = rk ) A(N,N), the matrix. ! implicit none integer, parameter :: rk = kind ( 1.0D+00 ) integer n real ( kind = rk ) a(n,n) integer i integer j real ( kind = rk ) x(n) do j = 1, n do i = 1, n if ( i == n ) then if ( j == 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 == 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 ) !*****************************************************************************80 ! !! complete_symmetric_poly() evaluates a complete symmetric polynomial. ! ! Discussion: ! ! N\R 0 1 2 3 ! +-------------------------------------------------------- ! 0 | 1 0 0 0 ! 1 | 1 X1 X1^2 X1^3 ! 2 | 1 X1+X2 X1^2+X1X2+X2^2 X1^3+X1^2X2+X1X2^2+X2^3 ! 3 | 1 X1+X2+X3 ... ! ! If X = ( 1, 2, 3, 4, 5, ... ) then ! ! N\R 0 1 2 3 4 ... ! +-------------------------------------------------------- ! 0 | 1 0 0 0 0 ! 1 | 1 1 1 1 1 ! 2 | 1 3 7 15 31 ! 3 | 1 6 25 90 301 ! 4 | 1 10 65 350 1701 ! 5 | 1 15 140 1050 6951 ! ! Licensing: ! ! This code is distributed under the MIT license. ! ! Modified: ! ! 04 November 2013 ! ! Author: ! ! John Burkardt ! ! Input: ! ! integer N, the number of variables. ! 0 <= N. ! ! integer R, the degree of the polynomial. ! 0 <= R. ! ! real ( kind = rk ) X(N), the value of the variables. ! ! Output: ! ! real ( kind = rk ) VALUE, the value of TAU(N,R)(X). ! implicit none integer, parameter :: rk = kind ( 1.0D+00 ) integer n integer r integer nn integer rr real ( kind = rk ) tau(0:max(n,r)) real ( kind = rk ) value real ( kind = rk ) x(n) if ( n < 0 ) then write ( *, '(a)' ) '' write ( *, '(a)' ) 'complete_symmetric_poly - Fatal error!' write ( *, '(a)' ) ' N < 0.' stop 1 end if if ( r < 0 ) then write ( *, '(a)' ) '' write ( *, '(a)' ) 'complete_symmetric_poly - Fatal error!' write ( *, '(a)' ) ' R < 0.' stop 1 end if tau(0:max(n,r)) = 0.0D+00 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_matrix ( a ) !*****************************************************************************80 ! !! complex3_matrix() returns the COMPLEX3 matrix. ! ! Example: ! ! 1 1 + 2i 2 + 10i ! 1 + i 3i -5 + 14i ! 1 + i 5i -8 + 20i ! ! Properties: ! ! A is complex. ! ! A is complex integral. ! ! Licensing: ! ! This code is distributed under the MIT license. ! ! Modified: ! ! 15 April 1999 ! ! Author: ! ! John Burkardt ! ! Reference: ! ! Joan Westlake, ! A Handbook of Numerical Matrix Inversion and Solution of ! Linear Equations, ! John Wiley, 1968, ! ISBN13: 978-0471936756, ! LC: QA263.W47. ! ! Output: ! ! complex ( kind = ck ) A(3,3), the matrix. ! implicit none integer, parameter :: rk = kind ( 1.0D+00 ) integer, parameter :: ck = kind ( ( 1.0D+00, 1.0D+00 ) ) complex ( kind = ck ) a(3,3) a(1,1) = cmplx ( 1.0D+00, 0.0D+00, kind = ck ) a(2,1) = cmplx ( 1.0D+00, 1.0D+00, kind = ck ) a(3,1) = cmplx ( 1.0D+00, 1.0D+00, kind = ck ) a(1,2) = cmplx ( 1.0D+00, 2.0D+00, kind = ck ) a(2,2) = cmplx ( 0.0D+00, 3.0D+00, kind = ck ) a(3,2) = cmplx ( 0.0D+00, 5.0D+00, kind = ck ) a(1,3) = cmplx ( 2.0D+00, 10.0D+00, kind = ck ) a(2,3) = cmplx ( -5.0D+00, 14.0D+00, kind = ck ) a(3,3) = cmplx ( -8.0D+00, 20.0D+00, kind = ck ) return end subroutine complex3_inverse ( a ) !*****************************************************************************80 ! !! complex3_inverse() returns the inverse of the COMPLEX3 matrix. ! ! Example: ! ! 10 + i -2 + 6i -3 - 2i ! 9 - 3i 8i -3 - 2i ! -2 + 2i -1 - 2i 1 ! ! Licensing: ! ! This code is distributed under the MIT license. ! ! Modified: ! ! 14 April 2001 ! ! Author: ! ! John Burkardt ! Reference: ! ! Joan Westlake, ! A Handbook of Numerical Matrix Inversion and Solution of ! Linear Equations, ! John Wiley, 1968, ! ISBN13: 978-0471936756, ! LC: QA263.W47. ! ! Output: ! ! complex ( kind = ck ) A(3,3), the matrix. ! implicit none integer, parameter :: rk = kind ( 1.0D+00 ) integer, parameter :: ck = kind ( ( 1.0D+00, 1.0D+00 ) ) complex ( kind = ck ) a(3,3) a(1,1) = cmplx ( 10.0D+00, 1.0D+00, kind = ck ) a(2,1) = cmplx ( 9.0D+00, -3.0D+00, kind = ck ) a(3,1) = cmplx ( -2.0D+00, 2.0D+00, kind = ck ) a(1,2) = cmplx ( -2.0D+00, 6.0D+00, kind = ck ) a(2,2) = cmplx ( 0.0D+00, 8.0D+00, kind = ck ) a(3,2) = cmplx ( -1.0D+00, -2.0D+00, kind = ck ) a(1,3) = cmplx ( -3.0D+00, -2.0D+00, kind = ck ) a(2,3) = cmplx ( -3.0D+00, -2.0D+00, kind = ck ) a(3,3) = cmplx ( 1.0D+00, 0.0D+00, kind = ck ) return end subroutine complex_i_matrix ( a ) !*****************************************************************************80 ! !! complex_i_matrix() returns the COMPLEX_I matrix. ! ! Discussion: ! ! This is a real matrix, that has some properties similar to the ! imaginary unit. ! ! Example: ! ! 0 1 ! -1 0 ! ! Properties: ! ! A is integral, therefore det ( A ) is integral, and ! det ( A ) * inverse ( A ) is integral. ! ! A is anti-involutory: A * A = - I ! ! A * A * A * A = I ! ! Licensing: ! ! This code is distributed under the MIT license. ! ! Modified: ! ! 10 March 2001 ! ! Author: ! ! John Burkardt ! ! Output: ! ! real ( kind = rk ) A(2,2), the matrix. ! implicit none integer, parameter :: rk = kind ( 1.0D+00 ) real ( kind = rk ) 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 ) !*****************************************************************************80 ! !! complex_i_determinant() returns the determinant of the COMPLEX_I matrix. ! ! Licensing: ! ! This code is distributed under the MIT license. ! ! Modified: ! ! 22 October 2007 ! ! Author: ! ! John Burkardt ! ! Output: ! ! real ( kind = rk ) DETERM, the determinant. ! implicit none integer, parameter :: rk = kind ( 1.0D+00 ) real ( kind = rk ) determ determ = + 1.0D+00 return end subroutine complex_i_inverse ( a ) !*****************************************************************************80 ! !! complex_i_inverse() returns the inverse of the COMPLEX_I matrix. ! ! Licensing: ! ! This code is distributed under the MIT license. ! ! Modified: ! ! 11 October 2007 ! ! Author: ! ! John Burkardt ! ! Output: ! ! real ( kind = rk ) A(2,2), the matrix. ! implicit none integer, parameter :: rk = kind ( 1.0D+00 ) real ( kind = rk ) 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_matrix ( alpha, a ) !*****************************************************************************80 ! !! conex1_matrix() returns the CONEX1 matrix. ! ! Discussion: ! ! The CONEX1 matrix is a counterexample to the LINPACK condition ! number estimator RCOND available in the LINPACK routine DGECO. ! ! Formula: ! ! 1 -1 -2*ALPHA 0 ! 0 1 ALPHA -ALPHA ! 0 1 1+ALPHA -1-ALPHA ! 0 0 0 ALPHA ! ! Example: ! ! ALPHA = 100 ! ! 1 -1 -200 0 ! 0 1 100 -100 ! 0 1 101 -101 ! 0 0 0 100 ! ! Properties: ! ! A is generally not symmetric: A' /= A. ! ! Licensing: ! ! This code is distributed under the MIT license. ! ! Modified: ! ! 15 April 1999 ! ! Author: ! ! John Burkardt ! ! Reference: ! ! Alan Cline, Russell Rew, ! A set of counterexamples to three condition number estimators, ! SIAM Journal on Scientific and Statistical Computing, ! Volume 4, Number 4, December 1983, pages 602-611. ! ! Input: ! ! real ( kind = rk ) ALPHA, the scalar defining A. ! A common value is 100.0. ! ! Output: ! ! real ( kind = rk ) A(4,4), the matrix. ! implicit none integer, parameter :: rk = kind ( 1.0D+00 ) real ( kind = rk ) a(4,4) real ( kind = rk ) 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 ) !*****************************************************************************80 ! !! conex1_condition() returns the L1 condition of the CONEX1 matrix. ! ! Licensing: ! ! This code is distributed under the MIT license. ! ! Modified: ! ! 05 February 2015 ! ! Author: ! ! John Burkardt ! ! Input: ! ! real ( kind = rk ) ALPHA, the scalar defining A. ! ! Output: ! ! real ( kind = rk ) COND, the L1 condition. ! implicit none integer, parameter :: rk = kind ( 1.0D+00 ) real ( kind = rk ) a_norm real ( kind = rk ) alpha real ( kind = rk ) b_norm real ( kind = rk ) cond real ( kind = rk ) v1 real ( kind = rk ) v2 real ( kind = rk ) 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 ) !*****************************************************************************80 ! !! conex1_determinant() returns the determinant of the CONEX1 matrix. ! ! Licensing: ! ! This code is distributed under the MIT license. ! ! Modified: ! ! 22 October 2007 ! ! Author: ! ! John Burkardt ! ! Input: ! ! real ( kind = rk ) ALPHA, the scalar defining A. ! ! Output: ! ! real ( kind = rk ) DETERM, the determinant. ! implicit none integer, parameter :: rk = kind ( 1.0D+00 ) real ( kind = rk ) alpha real ( kind = rk ) determ determ = alpha return end subroutine conex1_inverse ( alpha, a ) !*****************************************************************************80 ! !! conex1_inverse() returns the inverse of the CONEX1 matrix. ! ! Licensing: ! ! This code is distributed under the MIT license. ! ! Modified: ! ! 16 October 2007 ! ! Author: ! ! John Burkardt ! ! Input: ! ! real ( kind = rk ) ALPHA, the scalar defining A. ! ! Output: ! ! real ( kind = rk ) A(4,4), the matrix. ! implicit none integer, parameter :: rk = kind ( 1.0D+00 ) real ( kind = rk ) a(4,4) real ( kind = rk ) 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 - alpha a(2,2) = 1.0D+00 + alpha a(3,2) = -1.0D+00 a(4,2) = 0.0D+00 a(1,3) = alpha a(2,3) = - alpha a(3,3) = 1.0D+00 a(4,3) = 0.0D+00 a(1,4) = 2.0D+00 a(2,4) = 0.0D+00 a(3,4) = 1.0D+00 / alpha a(4,4) = 1.0D+00 / alpha return end subroutine conex2_matrix ( alpha, a ) !*****************************************************************************80 ! !! conex2_matrix() returns the CONEX2 matrix. ! ! Formula: ! ! 1 1-1/ALPHA^2 -2 ! 0 1/ALPHA -1/ALPHA ! 0 0 1 ! ! Example: ! ! ALPHA = 100 ! ! 1 0.9999 -2 ! 0 0.01 -0.01 ! 0 0 1 ! ! Properties: ! ! A is generally not symmetric: A' /= A. ! ! A is upper triangular. ! ! det ( A ) = 1 / ALPHA. ! ! LAMBDA = ( 1, 1/ALPHA, 1 ) ! ! Licensing: ! ! This code is distributed under the MIT license. ! ! Modified: ! ! 15 April 1999 ! ! Author: ! ! John Burkardt ! ! Reference: ! ! Alan Cline, Russell Rew, ! A set of counterexamples to three condition number estimators, ! SIAM Journal on Scientific and Statistical Computing, ! Volume 4, Number 4, December 1983, pages 602-611. ! ! Input: ! ! real ( kind = rk ) ALPHA, the scalar defining A. ! A common value is 100.0. ALPHA must not be zero. ! ! Output: ! ! real ( kind = rk ) A(3,3), the matrix. ! implicit none integer, parameter :: rk = kind ( 1.0D+00 ) real ( kind = rk ) a(3,3) real ( kind = rk ) alpha if ( alpha == 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 ) !*****************************************************************************80 ! !! conex2_condition() returns the L1 condition of the CONEX2 matrix. ! ! Licensing: ! ! This code is distributed under the MIT license. ! ! Modified: ! ! 05 February 2015 ! ! Author: ! ! John Burkardt ! ! Input: ! ! real ( kind = rk ) ALPHA, the scalar defining A. ! ! Output: ! ! real ( kind = rk ) COND, the L1 condition. ! implicit none integer, parameter :: rk = kind ( 1.0D+00 ) real ( kind = rk ) alpha real ( kind = rk ) a_norm real ( kind = rk ) b_norm real ( kind = rk ) c1 real ( kind = rk ) c2 real ( kind = rk ) c3 real ( kind = rk ) 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 ) !*****************************************************************************80 ! !! conex2_determinant() returns the determinant of the CONEX2 matrix. ! ! Licensing: ! ! This code is distributed under the MIT license. ! ! Modified: ! ! 22 October 2007 ! ! Author: ! ! John Burkardt ! ! Input: ! ! real ( kind = rk ) ALPHA, the scalar defining A. ! ! Output: ! ! real ( kind = rk ) DETERM, the determinant. ! implicit none integer, parameter :: rk = kind ( 1.0D+00 ) real ( kind = rk ) alpha real ( kind = rk ) determ determ = 1.0D+00 / alpha return end subroutine conex2_inverse ( alpha, a ) !*****************************************************************************80 ! !! conex2_inverse() returns the inverse of the CONEX2 matrix. ! ! Licensing: ! ! This code is distributed under the MIT license. ! ! Modified: ! ! 15 April 1999 ! ! Author: ! ! John Burkardt ! ! Input: ! ! real ( kind = rk ) ALPHA, the scalar defining A. ! A common value is 100.0. ALPHA must not be zero. ! ! Output: ! ! real ( kind = rk ) A(3,3), the matrix. ! implicit none integer, parameter :: rk = kind ( 1.0D+00 ) real ( kind = rk ) a(3,3) real ( kind = rk ) alpha if ( alpha == 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(2,1) = 0.0D+00 a(3,1) = 0.0D+00 a(1,2) = ( 1.0D+00 - alpha ** 2 ) / alpha a(2,2) = alpha a(3,2) = 0.0D+00 a(1,3) = ( 1.0D+00 + alpha ** 2 ) / alpha ** 2 a(2,3) = 1.0D+00 a(3,3) = 1.0D+00 return end subroutine conex3_matrix ( n, a ) !*****************************************************************************80 ! !! conex3_matrix() returns the CONEX3 matrix. ! ! Formula: ! ! if ( I = J and I < N ) ! A(I,J) = 1.0D+00 for 1<=I A * Q. ! 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 ! ! A -> Q' * A ! 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 ! ! X -> Q' * X ! 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 ! ! Test the size of the off-diagonal elements. ! sum2 = 0.0D+00 do i = 1, n sum2 = sum2 + sum ( abs ( b(i,1:i-1) ) ) end do if ( sum2 <= 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 ) !*****************************************************************************80 ! !! jacobi_symbol() evaluates the Jacobi symbol (Q/P). ! ! Discussion: ! ! If P is prime, then ! Jacobi Symbol (Q/P) = Legendre Symbol (Q/P) ! Else let P have the prime factorization ! P = product ( 1 <= I <= N ) P(I)^E(I) ! Then ! Jacobi Symbol (Q/P) = ! product ( 1 <= I <= N ) Legendre Symbol (Q/P(I))^E(I) ! ! Licensing: ! ! This code is distributed under the MIT license. ! ! Modified: ! ! 30 June 2000 ! ! Author: ! ! John Burkardt ! ! Reference: ! ! Daniel Zwillinger, ! CRC Standard Mathematical Tables and Formulae, ! 30th Edition, ! CRC Press, 1996, pages 86-87. ! ! Input: ! ! integer Q, an integer whose Jacobi symbol with ! respect to P is desired. ! ! integer P, the number with respect to which the Jacobi ! symbol of Q is desired. P should be 2 or greater. ! ! Output: ! ! integer L, the Jacobi symbol (Q/P). ! Ordinarily, L will be -1, 0 or 1. ! -2, not enough factorization space. ! -3, an error during Legendre symbol calculation. ! implicit none integer, parameter :: rk = kind ( 1.0D+00 ) integer, 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 ! ! P must be greater than 1. ! if ( p <= 1 ) then write ( *, '(a)' ) ' ' write ( *, '(a)' ) 'jacobi_symbol - Fatal error!' write ( *, '(a)' ) ' P must be greater than 1.' l = -2 stop 1 end if ! ! Decompose P into factors of prime powers. ! call i4_factor ( p, maxfactor, nfactor, factor, power, nleft ) if ( nleft /= 1 ) then write ( *, '(a)' ) ' ' write ( *, '(a)' ) 'jacobi_symbol - Fatal error!' write ( *, '(a)' ) ' Not enough factorization space.' j = -2 stop 1 end if ! ! Force Q to be nonnegative. ! qq = q do while ( qq < 0 ) qq = qq + p end do ! ! For each prime factor, compute the Legendre symbol, and ! multiply the Jacobi symbol by the appropriate factor. ! j = 1 do i = 1, nfactor pp = factor(i) call legendre_symbol ( qq, pp, l ) if ( l < - 1 ) then write ( *, '(a)' ) ' ' write ( *, '(a)' ) 'jacobi_symbol - Fatal error!' write ( *, '(a)' ) ' Error during Legendre symbol calculation.' j = -3 stop 1 end if j = j * l ** power(i) end do return end subroutine jordan_matrix ( m, n, alpha, a ) !*****************************************************************************80 ! !! jordan_matrix() returns the JORDAN matrix. ! ! Formula: ! ! if ( I = J ) ! A(I,J) = ALPHA ! else if ( I = J-1 ) ! A(I,J) = 1 ! else ! A(I,J) = 0 ! ! Example: ! ! ALPHA = 2, M = 5, N = 5 ! ! 2 1 0 0 0 ! 0 2 1 0 0 ! 0 0 2 1 0 ! 0 0 0 2 1 ! 0 0 0 0 2 ! ! Properties: ! ! A is upper triangular. ! ! A is lower Hessenberg. ! ! A is bidiagonal. ! ! Because A is bidiagonal, it has property A (bipartite). ! ! A is banded, with bandwidth 2. ! ! A is generally not symmetric: A' /= A. ! ! A is persymmetric: A(I,J) = A(N+1-J,N+1-I). ! ! A is nonsingular if and only if ALPHA is nonzero. ! ! det ( A ) = ALPHA^N. ! ! LAMBDA(I) = ALPHA. ! ! A is defective, having only one eigenvector, namely (1,0,0,...,0). ! ! The JORDAN matrix is a special case of the BIS matrix. ! ! The family of matrices is nested as a function of N. ! ! Licensing: ! ! This code is distributed under the MIT license. ! ! Modified: ! ! 01 July 2000 ! ! Author: ! ! John Burkardt ! ! Input: ! ! integer M, N, the order of the matrix. ! ! real ( kind = rk ) ALPHA, the eigenvalue of the Jordan matrix. ! ! Output: ! ! real ( kind = rk ) A(M,N), the matrix. ! implicit none integer, parameter :: rk = kind ( 1.0D+00 ) integer m integer n real ( kind = rk ) a(m,n) real ( kind = rk ) alpha integer i integer j do j = 1, n do i = 1, m if ( i == j ) then a(i,j) = alpha else if ( j == 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, value ) !*****************************************************************************80 ! !! jordan_condition() returns the L1 condition of the JORDAN matrix. ! ! Licensing: ! ! This code is distributed under the MIT license. ! ! Modified: ! ! 17 February 2015 ! ! Author: ! ! John Burkardt ! ! Input: ! ! integer N, the order of the matrix. ! ! real ( kind = rk ) ALPHA, the eigenvalue of the Jordan matrix. ! ! Output: ! ! real ( kind = rk ) VALUE, the L1 condition of the matrix. ! implicit none integer, parameter :: rk = kind ( 1.0D+00 ) real ( kind = rk ) a_norm real ( kind = rk ) a2 real ( kind = rk ) alpha real ( kind = rk ) b_norm integer n real ( kind = rk ) value a2 = abs ( alpha ) if ( n == 1 ) then a_norm = a2 else a_norm = a2 + 1.0D+00 end if if ( a2 == 1 ) then b_norm = real ( n, kind = rk ) * a2 else b_norm = ( a2 ** n - 1.0D+00 ) / ( a2 - 1.0D+00 ) / a2 ** n end if value = a_norm * b_norm return end subroutine jordan_determinant ( n, alpha, determ ) !*****************************************************************************80 ! !! jordan_determinant() returns the determinant of the JORDAN matrix. ! ! Licensing: ! ! This code is distributed under the MIT license. ! ! Modified: ! ! 21 May 2002 ! ! Author: ! ! John Burkardt ! ! Input: ! ! integer N, the order of the matrix. ! ! real ( kind = rk ) ALPHA, the eigenvalue of the Jordan matrix. ! ! Output: ! ! real ( kind = rk ) DETERM, the determinant. ! implicit none integer, parameter :: rk = kind ( 1.0D+00 ) real ( kind = rk ) alpha real ( kind = rk ) determ integer n determ = alpha**n return end subroutine jordan_eigenvalues ( n, alpha, lambda ) !*****************************************************************************80 ! !! jordan_eigenvalues() returns the eigenvalues of the JORDAN matrix. ! ! Licensing: ! ! This code is distributed under the MIT license. ! ! Modified: ! ! 12 June 2011 ! ! Author: ! ! John Burkardt ! ! Input: ! ! integer N, the order of the matrix. ! ! real ( kind = rk ) ALPHA, the eigenvalue of the Jordan matrix. ! ! Output: ! ! real ( kind = rk ) LAMBDA(N), the eigenvalues. ! implicit none integer, parameter :: rk = kind ( 1.0D+00 ) integer n real ( kind = rk ) alpha real ( kind = rk ) lambda(n) lambda(1:n) = alpha return end subroutine jordan_inverse ( n, alpha, a ) !*****************************************************************************80 ! !! jordan_inverse() returns the inverse of the JORDAN matrix. ! ! Formula: ! ! if ( I <= J ) ! A(I,J) = -1 * (-1/ALPHA)^(J+1-I) ! else ! A(I,J) = 0 ! ! Example: ! ! ALPHA = 2, N = 4 ! ! 1/2 -1/4 1/8 -1/16 ! 0 1/2 -1/4 1/8 ! 0 0 1/2 -1/4 ! 0 0 0 1/2 ! ! Properties: ! ! A is upper triangular. ! ! A is Toeplitz: constant along diagonals. ! ! A is generally not symmetric: A' /= A. ! ! A is persymmetric: A(I,J) = A(N+1-J,N+1-I). ! ! The inverse of A is the Jordan block matrix, whose diagonal ! entries are ALPHA, whose first superdiagonal entries are 1, ! with all other entries zero. ! ! det ( A ) = (1/ALPHA)^N. ! ! LAMBDA(1:N) = 1 / ALPHA. ! ! Licensing: ! ! This code is distributed under the MIT license. ! ! Modified: ! ! 15 April 1999 ! ! Author: ! ! John Burkardt ! ! Input: ! ! integer N, the order of the matrix. ! ! real ( kind = rk ) ALPHA, the eigenvalue of the Jordan matrix. ! ! Output: ! ! real ( kind = rk ) A(N,N), the matrix. ! implicit none integer, parameter :: rk = kind ( 1.0D+00 ) integer n real ( kind = rk ) a(n,n) real ( kind = rk ) alpha integer i integer j if ( alpha == 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 <= 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_condition ( alpha, n, c ) !*****************************************************************************80 ! !! kahan_condition() returns the L1 condition of the KAHAN matrix. ! ! Licensing: ! ! This code is distributed under the MIT license. ! ! Modified: ! ! 30 October 2021 ! ! Author: ! ! John Burkardt ! ! Input: ! ! real ( kind = rk ) ALPHA, the scalar that defines A. A typical ! value is 1.2. The "interesting" range of ALPHA is 0 < ALPHA < PI. ! ! integer N, the order of the matrix. ! ! Output: ! ! real ( kind = rk ) C, the L1 condition number. ! implicit none integer, parameter :: rk = kind ( 1.0D+00 ) integer n real ( kind = rk ) a(n,n) real ( kind = rk ) alpha real ( kind = rk ) anorm real ( kind = rk ) b(n,n) real ( kind = rk ) bnorm real ( kind = rk ) c real ( kind = rk ) r8mat_norm_l1 call kahan_matrix ( alpha, n, n, a ) call kahan_inverse ( alpha, n, b ) anorm = r8mat_norm_l1 ( n, n, a ) bnorm = r8mat_norm_l1 ( n, n, b ) c = anorm * bnorm return end subroutine kahan_determinant ( alpha, n, determ ) !*****************************************************************************80 ! !! kahan_determinant() returns the determinant of the KAHAN matrix. ! ! Licensing: ! ! This code is distributed under the MIT license. ! ! Modified: ! ! 21 May 2002 ! ! Author: ! ! John Burkardt ! ! Input: ! ! real ( kind = rk ) ALPHA, the scalar that defines A. A typical ! value is 1.2. The "interesting" range of ALPHA is 0 < ALPHA < PI. ! ! integer N, the order of the matrix. ! ! Output: ! ! real ( kind = rk ) DETERM, the determinant. ! implicit none integer, parameter :: rk = kind ( 1.0D+00 ) real ( kind = rk ) alpha real ( kind = rk ) determ integer n integer power power = ( n * ( n + 1 ) ) / 2 determ = ( sin ( alpha ) ) ** power return end subroutine kahan_inverse ( alpha, n, a ) !*****************************************************************************80 ! !! kahan_inverse() returns the inverse of the KAHAN matrix. ! ! Example: ! ! ALPHA = 0.25, N = 5 ! ! 4 158 126.0 1002.6 7978.7 ! 0 163 64.0 509.2 4052.3 ! 0 0 66.0 258.6 2058.2 ! 0 0 0 266.9 1045.3 ! 0 0 0 0 1078.9 ! ! Licensing: ! ! This code is distributed under the MIT license. ! ! Modified: ! ! 27 May 2002 ! ! Author: ! ! John Burkardt ! ! Input: ! ! real ( kind = rk ) ALPHA, the scalar that defines A. A typical ! value is 1.2. The "interesting" range of ALPHA is 0 < ALPHA < PI. ! ! integer N, the order of the matrix. ! ! Output: ! ! real ( kind = rk ) A(N,N), the matrix. ! implicit none integer, parameter :: rk = kind ( 1.0D+00 ) integer n real ( kind = rk ) a(n,n) real ( kind = rk ) alpha real ( kind = rk ) ci integer i integer j real ( kind = rk ) si ci = cos ( alpha ) do i = 1, n do j = 1, n if ( i == j ) then a(i,j) = 1.0D+00 else if ( i == j - 1 ) then a(i,j) = ci else if ( i < 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 ! ! Scale the columns. ! do j = 1, n si = sin ( alpha ) ** j a(1:n,j) = a(1:n,j) / si end do return end subroutine kahan_matrix ( alpha, m, n, a ) !*****************************************************************************80 ! !! kahan_matrix() returns the KAHAN matrix. ! ! Formula: ! ! if ( I = J ) ! A(I,I) = sin(ALPHA)^I ! else if ( I < J ) ! A(I,J) = - sin(ALPHA)^I * cos(ALPHA) ! else ! A(I,J) = 0 ! ! Example: ! ! ALPHA = 0.25, M = 5, N = 5 ! ! 0.2474 -0.2397 -0.2397 -0.2397 -0.2397 ! 0 0.0612 -0.0593 -0.0593 -0.0593 ! 0 0 0.0151 -0.0147 -0.0147 ! 0 0 0 0.0037 -0.0036 ! 0 0 0 0 0.0009 ! ! where ! ! S = sin(ALPHA), C=COS(ALPHA) ! ! Properties: ! ! A is upper triangular. ! ! A = B * C, where B is a diagonal matrix and C is unit upper triangular. ! For instance, for the case M = 3, N = 4: ! ! A = | S 0 0 | * | 1 -C -C -C | ! | 0 S^2 0 | | 0 1 -C -C | ! | 0 0 S^3 | | 0 0 1 -C | ! ! A is generally not symmetric: A' /= A. ! ! A has some interesting properties regarding estimation of ! condition and rank. ! ! det ( A ) = sin(ALPHA)^(N*(N+1)/2). ! ! LAMBDA(I) = sin ( ALPHA )^I ! ! A is nonsingular if and only if sin ( ALPHA ) =/= 0. ! ! The family of matrices is nested as a function of N. ! ! Licensing: ! ! This code is distributed under the MIT license. ! ! Modified: ! ! 15 April 1999 ! ! Author: ! ! John Burkardt ! ! Reference: ! ! Nicholas Higham, ! A survey of condition number estimation for triangular matrices, ! SIAM Review, ! Volume 9, Number 4, December 1987, pages 575-596. ! ! W Kahan, ! Numerical Linear Algebra, ! Canadian Mathematical Bulletin, ! Volume 9, 1966, pages 757-801. ! ! Input: ! ! real ( kind = rk ) ALPHA, the scalar that defines A. A typical ! value is 1.2. The "interesting" range of ALPHA is 0 < ALPHA < PI. ! ! integer M, N, the order of the matrix. ! ! Output: ! ! real ( kind = rk ) A(M,N), the matrix. ! implicit none integer, parameter :: rk = kind ( 1.0D+00 ) integer m integer n real ( kind = rk ) a(m,n) real ( kind = rk ) alpha real ( kind = rk ) csi integer i integer j real ( kind = rk ) si do i = 1, m si = sin ( alpha ) ** i csi = - cos ( alpha ) * si do j = 1, n if ( j < i ) then a(i,j) = 0.0D+00 else if ( j == i ) then a(i,j) = si else a(i,j) = csi end if end do end do return end subroutine kershaw_condition ( cond ) !*****************************************************************************80 ! !! kershaw_condition() returns the L1 condition of the KERSHAW matrix. ! ! Licensing: ! ! This code is distributed under the MIT license. ! ! Modified: ! ! 17 February 2015 ! ! Author: ! ! John Burkardt ! ! Output: ! ! real ( kind = rk ) COND, the L1 condition of the matrix. ! implicit none integer, parameter :: rk = kind ( 1.0D+00 ) real ( kind = rk ) a_norm real ( kind = rk ) b_norm real ( kind = rk ) cond a_norm = 7.0D+00 b_norm = 7.0D+00 cond = a_norm * b_norm return end subroutine kershaw_determinant ( determ ) !*****************************************************************************80 ! !! kershaw_determinant() returns the determinant of the KERSHAW matrix. ! ! Licensing: ! ! This code is distributed under the MIT license. ! ! Modified: ! ! 01 October 2007 ! ! Author: ! ! John Burkardt ! ! Output: ! ! real ( kind = rk ) DETERM, the determinant. ! implicit none integer, parameter :: rk = kind ( 1.0D+00 ) real ( kind = rk ) determ determ = 1.0D+00 return end subroutine kershaw_eigen_right ( x ) !*****************************************************************************80 ! !! kershaw_eigen_right() returns the right eigenvectors of the KERSHAW matrix. ! ! Licensing: ! ! This code is distributed under the MIT license. ! ! Modified: ! ! 13 March 2015 ! ! Author: ! ! John Burkardt ! ! Output: ! ! real ( kind = rk ) X(4,4), the eigenvectors. ! implicit none integer, parameter :: rk = kind ( 1.0D+00 ) real ( kind = rk ) x(4,4) ! ! Note that the matrix entries are listed by column. ! real ( kind = rk ), dimension ( 4, 4 ) :: x_save = reshape ( (/ & 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 /), & (/ 4, 4 /) ) call r8mat_copy ( 4, 4, x_save, x ) return end subroutine kershaw_eigenvalues ( lambda ) !*****************************************************************************80 ! !! kershaw_eigenvalues() returns the eigenvalues of the KERSHAW matrix. ! ! Licensing: ! ! This code is distributed under the MIT license. ! ! Modified: ! ! 01 October 2007 ! ! Author: ! ! John Burkardt ! ! Output: ! ! real ( kind = rk ) LAMBDA(4), the eigenvalues. ! implicit none integer, parameter :: rk = kind ( 1.0D+00 ) real ( kind = rk ) lambda(4) real ( kind = rk ), dimension ( 4 ), save :: 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 ) !*****************************************************************************80 ! !! kershaw_inverse() returns the inverse of the KERSHAW matrix. ! ! Example: ! ! 3 2 0 -2 ! 2 3 2 0 ! 0 2 3 2 ! -2 0 2 3 ! ! Licensing: ! ! This code is distributed under the MIT license. ! ! Modified: ! ! 19 October 2007 ! ! Author: ! ! John Burkardt ! ! Output: ! ! real ( kind = rk ) A(4,4), the matrix. ! implicit none integer, parameter :: rk = kind ( 1.0D+00 ) real ( kind = rk ) a(4,4) ! ! Note that the matrix entries are listed by column. ! real ( kind = rk ), dimension(4,4), save :: a_save = reshape ( (/ & 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 /), (/ 4, 4 /) ) call r8mat_copy ( 4, 4, a_save, a ) return end subroutine kershaw_llt ( a ) !*****************************************************************************80 ! !! kershaw_llt() returns the Cholesky factor of the KERSHAW matrix. ! ! Licensing: ! ! This code is distributed under the MIT license. ! ! Modified: ! ! 14 March 2015 ! ! Author: ! ! John Burkardt ! ! Output: ! ! real ( kind = rk ) A(4,4), the matrix. ! implicit none integer, parameter :: rk = kind ( 1.0D+00 ) real ( kind = rk ) a(4,4) ! ! Note that the matrix entries are listed by column. ! real ( kind = rk ), dimension(4,4), save :: a_save = reshape ( (/ & 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 /), (/ 4, 4 /) ) call r8mat_copy ( 4, 4, a_save, a ) return end subroutine kershaw_matrix ( a ) !*****************************************************************************80 ! !! kershaw_matrix() returns the KERSHAW matrix. ! ! Discussion: ! ! The Kershaw matrix is a simple example of a symmetric ! positive definite matrix for which the incomplete Cholesky ! factorization fails, because of a negative pivot. ! ! Example: ! ! 3 -2 0 2 ! -2 3 -2 0 ! 0 -2 3 -2 ! 2 0 -2 3 ! ! Properties: ! ! A is symmetric. ! ! A is positive definite. ! ! det ( A ) = 1. ! ! LAMBDA(A) = [ ! 5.828427124746192 ! 5.828427124746188 ! 0.171572875253810 ! 0.171572875253810 ]. ! ! A does not have an incomplete Cholesky factorization. ! ! Licensing: ! ! This code is distributed under the MIT license. ! ! Modified: ! ! 13 October 2007 ! ! Author: ! ! John Burkardt ! ! Reference: ! ! David Kershaw, ! The Incomplete Cholesky-Conjugate Gradient Method for the Iterative ! Solution of Systems of Linear Equations, ! Journal of Computational Physics, ! Volume 26, Number 1, January 1978, pages 43-65. ! ! Output: ! ! real ( kind = rk ) A(4,4), the matrix. ! implicit none integer, parameter :: rk = kind ( 1.0D+00 ) real ( kind = rk ) a(4,4) ! ! Note that the matrix entries are listed by column. ! real ( kind = rk ), dimension ( 4, 4 ), save :: a_save = reshape ( (/& 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 /), (/ 4, 4 /) ) call r8mat_copy ( 4, 4, a_save, a ) return end subroutine kershawtri_matrix ( n, x, a ) !*****************************************************************************80 ! !! kershawtri_matrix() returns the kershawtri matrix. ! ! Discussion: ! ! A(I,I) = X(I) for I <= (N+1)/2 ! A(I,I) = X(N+1-I) for (N+1)/2 < I ! A(I,J) = 1 for I = J + 1 or I = J - 1. ! A(I,J) = 0 otherwise. ! ! Example: ! ! N = 5, X = ( 10, 20, 30 ) ! ! 10 1 0 0 0 ! 1 20 1 0 0 ! 0 1 30 1 0 ! 0 0 1 20 1 ! 0 0 0 1 10 ! ! Properties: ! ! A is tridiagonal. ! ! A is symmetric. ! ! If the entries in X are integers, then det(A) is an integer. ! ! If det(A) is an integer, then det(A) * inv(A) is an integer matrix. ! ! A is persymmetric: A(I,J) = A(N+1-J,N+1-I). ! ! A is centrosymmetric: A(I,J) = A(N+1-I,N+1-J). ! ! Licensing: ! ! This code is distributed under the MIT license. ! ! Modified: ! ! 05 November 2007 ! ! Author: ! ! John Burkardt ! ! Reference: ! ! P Schlegel, ! The Explicit Inverse of a Tridiagonal Matrix, ! Mathematics of Computation, ! Volume 24, Number 111, July 1970, page 665. ! ! Input: ! ! integer N, the order of the matrix. ! ! real ( kind = rk ) X((N+1)/2), defines the diagonal of the matrix. ! ! Output: ! ! real ( kind = rk ) A(N,N), the matrix. ! implicit none integer, parameter :: rk = kind ( 1.0D+00 ) integer n real ( kind = rk ) a(n,n) integer i integer nh real ( kind = rk ) x((n+1)/2) a(1:n,1:n) = 0.0D+00 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 ) == 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 ) !*****************************************************************************80 ! !! kershawtri_determinant() returns the determinant of the kershawtri matrix. ! ! Licensing: ! ! This code is distributed under the MIT license. ! ! Modified: ! ! 05 November 2007 ! ! Author: ! ! John Burkardt ! ! Input: ! ! integer N, the order of the matrix. ! ! real ( kind = rk ) X((N+1)/2), defines the diagonal of the matrix. ! ! Output: ! ! real ( kind = rk ) DETERM, the determinant. ! implicit none integer, parameter :: rk = kind ( 1.0D+00 ) integer n real ( kind = rk ) determ integer i integer nh real ( kind = rk ) r(n+1) real ( kind = rk ) x((n+1)/2) real ( kind = rk ) xim1 nh = ( n / 2 ) r(1:n+1) = 0.0D+00 r(1) = 1.0D+00 r(2) = - x(1) do i = 3, n if ( i - 1 <= 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 ) !*****************************************************************************80 ! !! kershawtri_inverse() returns the inverse of the kershawtri matrix. ! ! Licensing: ! ! This code is distributed under the MIT license. ! ! Modified: ! ! 05 November 2007 ! ! Author: ! ! John Burkardt ! ! Input: ! ! integer N, the order of the matrix. ! ! real ( kind = rk ) X((N+1)/2), defines the diagonal of the matrix. ! ! Output: ! ! real ( kind = rk ) A(N,N), the matrix. ! implicit none integer, parameter :: rk = kind ( 1.0D+00 ) integer n real ( kind = rk ) a(n,n) integer i integer j integer nh real ( kind = rk ) r(n+1) real ( kind = rk ) x((n+1)/2) real ( kind = rk ) xim1 nh = ( n / 2 ) r(1:n+1) = 0.0D+00 r(1) = 1.0D+00 r(2) = - x(1) do i = 3, n if ( i - 1 <= 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) a(1:n,1:n) = 0.0D+00 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_matrix ( alpha, m, n, a ) !*****************************************************************************80 ! !! kms_matrix() returns the KMS matrix. ! ! Discussion: ! ! The KMS matrix is also called the Kac-Murdock-Szego matrix. ! ! Formula: ! ! A(I,J) = ALPHA^abs ( I - J ) ! ! Example: ! ! ALPHA = 2, N = 5 ! ! 1 2 4 8 16 ! 2 1 2 4 8 ! 4 2 1 2 4 ! 8 4 2 1 2 ! 16 8 4 2 1 ! ! ALPHA = 1/2, N = 5 ! ! 1 1/2 1/4 1/8 1/16 ! 1/2 1 1/2 1/4 1/8 ! 1/4 1/2 1 1/2 1/4 ! 1/8 1/4 1/2 1 1/2 ! 1/16 1/8 1/4 1/2 1 ! ! Properties: ! ! A is Toeplitz: constant along diagonals. ! ! A is symmetric: A' = A. ! ! Because A is symmetric, it is normal. ! ! Because A is normal, it is diagonalizable. ! ! A is persymmetric: A(I,J) = A(N+1-J,N+1-I). ! ! A is centrosymmetric: A(I,J) = A(N+1-I,N+1-J). ! ! A has an L*D*L' factorization, with L being the inverse ! of the transpose of the matrix with 1's on the diagonal and ! -ALPHA on the superdiagonal and zero elsewhere, and ! D(I,I) = (1-ALPHA^2) except that D(1,1)=1. ! ! det ( A ) = ( 1 - ALPHA * ALPHA )^(N-1). ! ! The inverse of A is tridiagonal. ! ! A is positive definite if and only if 0 < abs ( ALPHA ) < 1. ! ! The family of matrices is nested as a function of N. ! ! Licensing: ! ! This code is distributed under the MIT license. ! ! Modified: ! ! 15 April 1999 ! ! Author: ! ! John Burkardt ! ! Reference: ! ! William Trench, ! Numerical solution of the eigenvalue problem for Hermitian ! Toeplitz matrices, ! SIAM Journal on Matrix Analysis and Applications, ! Volume 10, Number 2, April 1989, pages 135-146. ! ! Input: ! ! real ( kind = rk ) ALPHA, the scalar that defines A. ! A typical value is 0.5. ! ! integer M, N, the order of the matrix. ! ! Output: ! ! real ( kind = rk ) A(M,N), the matrix. ! implicit none integer, parameter :: rk = kind ( 1.0D+00 ) integer m integer n real ( kind = rk ) a(m,n) real ( kind = rk ) alpha integer i integer j do i = 1, m do j = 1, n if ( alpha == 0.0D+00 .and. i == 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 ) !*****************************************************************************80 ! !! kms_determinant() returns the determinant of the KMS matrix. ! ! Licensing: ! ! This code is distributed under the MIT license. ! ! Modified: ! ! 20 October 2007 ! ! Author: ! ! John Burkardt ! ! Input: ! ! real ( kind = rk ) ALPHA, the scalar that defines A. ! ! integer N, the order of the matrix. ! ! Output: ! ! real ( kind = rk ) DETERM, the determinant. ! implicit none integer, parameter :: rk = kind ( 1.0D+00 ) real ( kind = rk ) alpha real ( kind = rk ) determ integer n if ( n == 1 ) then determ = 1.0D+00 else determ = ( ( 1.0D+00 - alpha ) * ( 1.0D+00 + alpha ) ) ** ( n - 1 ) end if return end subroutine kms_eigen_right ( alpha, n, a ) !*****************************************************************************80 ! !! kms_eigen_right() returns the right eigenvectors of the KMS matrix. ! ! Licensing: ! ! This code is distributed under the MIT license. ! ! Modified: ! ! 08 June 2011 ! ! Author: ! ! John Burkardt ! ! Reference: ! ! William Trench, ! Spectral decomposition of Kac-Murdock-Szego matrices, ! Unpublished technical report. ! ! Input: ! ! real ( kind = rk ) ALPHA, the parameter. ! Eigenvalue computations require 0 <= ALPHA <= 1. ! ! integer N, the order of A. ! ! Output: ! ! real ( kind = rk ) A(N,N), the right eigenvector matrix. ! implicit none integer, parameter :: rk = kind ( 1.0D+00 ) integer n real ( kind = rk ) a(n,n) real ( kind = rk ) alpha integer i real ( kind = rk ) t(n) call kms_eigenvalues_theta ( alpha, n, t ) do i = 1, n a(i,1:n) = sin ( real ( i, kind = rk ) * t(1:n) ) & - alpha * sin ( real ( i - 1, kind = rk ) * t(1:n) ) end do return end subroutine kms_eigenvalues ( alpha, n, lambda ) !*****************************************************************************80 ! !! kms_eigenvalues() returns the eigenvalues of the KMS matrix. ! ! Licensing: ! ! This code is distributed under the MIT license. ! ! Modified: ! ! 08 June 2011 ! ! Author: ! ! John Burkardt ! ! Reference: ! ! William Trench, ! Spectral decomposition of Kac-Murdock-Szego matrices, ! Unpublished technical document. ! ! Input: ! ! real ( kind = rk ) ALPHA, the scalar that defines A. ! Eigenvalue computations require 0 <= ALPHA <= 1. ! ! integer N, the order of the matrix. ! ! Output: ! ! real ( kind = rk ) LAMBDA(N), the eigenvalues. ! implicit none integer, parameter :: rk = kind ( 1.0D+00 ) integer n real ( kind = rk ) alpha integer i real ( kind = rk ) lambda(n) real ( kind = rk ) 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 ) !*****************************************************************************80 ! !! kms_eigenvalues_theta() returns data needed to compute KMS eigenvalues. ! ! Licensing: ! ! This code is distributed under the MIT license. ! ! Modified: ! ! 08 June 2011 ! ! Author: ! ! John Burkardt ! ! Reference: ! ! William Trench, ! Spectral decomposition of Kac-Murdock-Szego matrices, ! Unpublished technical document. ! ! Input: ! ! real ( kind = rk ) ALPHA, the scalar that defines A. ! Eigenvalue computations require 0 <= ALPHA <= 1. ! ! integer N, the order of the matrix. ! ! Output: ! ! real ( kind = rk ) T(N), the angles associated with ! the eigenvalues. ! implicit none integer, parameter :: rk = kind ( 1.0D+00 ) integer n real ( kind = rk ) alpha real ( kind = rk ) fxa real ( kind = rk ) fxb real ( kind = rk ) fxc integer i real ( kind = rk ) kms_eigenvalues_theta_f real ( kind = rk ), parameter :: r8_pi = 3.141592653589793D+00 integer step integer, parameter :: step_max = 100 real ( kind = rk ) t(n) real ( kind = rk ) temp real ( kind = rk ) xa real ( kind = rk ) xb real ( kind = rk ) xc do i = 1, n ! ! Avoid confusion in first subinterval, where f(0) = 0. ! if ( i == 1 ) then xa = 0.0001D+00 else xa = real ( i - 1, kind = rk ) * r8_pi / real ( n + 1, kind = rk ) end if fxa = kms_eigenvalues_theta_f ( alpha, n, xa ) xb = real ( i, kind = rk ) * r8_pi / real ( n + 1, kind = rk ) fxb = kms_eigenvalues_theta_f ( alpha, n, xb ) if ( 0.0D+00 < 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 ) ! ! Return if residual is small. ! if ( abs ( fxc ) <= 0.0000001D+00 ) then exit end if ! ! Return if interval is small. ! if ( abs ( xb - xa ) <= 0.0000001D+00 ) then exit end if if ( fxc < 0.0D+00 ) then xa = xc fxa = fxc else xb = xc fxb = fxc end if end do t(i) = xc end do return end function kms_eigenvalues_theta_f ( alpha, n, t ) !*****************************************************************************80 ! !! kms_eigenvalues_theta_f() evaluates a function for KMS eigenvalues. ! ! Licensing: ! ! This code is distributed under the MIT license. ! ! Modified: ! ! 08 June 2011 ! ! Author: ! ! John Burkardt ! ! Reference: ! ! William Trench, ! Spectral decomposition of Kac-Murdock-Szego matrices, ! Unpublished technical document. ! ! Input: ! ! real ( kind = rk ) ALPHA, the scalar that defines A. ! Eigenvalue computations require 0 <= ALPHA <= 1. ! ! integer N, the order of the matrix. ! ! real ( kind = rk ) T, an angle associated with the eigenvalue. ! ! Output: ! ! real ( kind = rk ) KMS_EIGENVALUES_THETA_F, the function value. ! implicit none integer, parameter :: rk = kind ( 1.0D+00 ) real ( kind = rk ) alpha real ( kind = rk ) kms_eigenvalues_theta_f integer n real ( kind = rk ) n_r8 real ( kind = rk ) t real ( kind = rk ) value n_r8 = real ( n, kind = rk ) 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 ) !*****************************************************************************80 ! !! kms_inverse() returns the inverse of the KMS matrix. ! ! Formula: ! ! if ( I = J ) ! if ( I = 1 ) ! A(I,J) = -1/(ALPHA^2-1) ! else if ( I < N ) ! A(I,J) = -(ALPHA^2+1)/(ALPHA^2-1) ! else if ( I = N ) ! A(I,J) = -1/(ALPHA^2-1) ! else if ( J = I + 1 or I = J + 1 ) ! A(I,J) = ALPHA/(ALPHA^2-1) ! else ! A(I,J) = 0 otherwise ! ! Example: ! ! ALPHA = 2, N = 5 ! ! -1 2 0 0 0 ! 2 -5 2 0 0 ! 1/3 * 0 2 -5 2 0 ! 0 0 2 -5 2 ! 0 0 0 2 -1 ! ! Properties: ! ! A is symmetric: A' = A. ! ! Because A is symmetric, it is normal. ! ! Because A is normal, it is diagonalizable. ! ! A is persymmetric: A(I,J) = A(N+1-J,N+1-I). ! ! Licensing: ! ! This code is distributed under the MIT license. ! ! Modified: ! ! 15 April 1999 ! ! Author: ! ! John Burkardt ! ! Reference: ! ! William Trench, ! Numerical solution of the eigenvalue problem for Hermitian ! Toeplitz matrices, ! SIAM Journal on Matrix Analysis and Applications, ! Volume 10, Number 2, April 1989, pages 135-146. ! ! Input: ! ! real ( kind = rk ) ALPHA, the scalar that defines A. ! ! integer N, the order of the matrix. ! ! Output: ! ! real ( kind = rk ) A(N,N), the matrix. ! implicit none integer, parameter :: rk = kind ( 1.0D+00 ) integer n real ( kind = rk ) a(n,n) real ( kind = rk ) alpha real ( kind = rk ) bot integer i integer j bot = alpha * alpha - 1.0D+00 do i = 1, n do j = 1, n if ( i == j ) then if ( j == 1 ) then a(i,j) = - 1.0D+00 / bot else if ( j < n ) then a(i,j) = - ( alpha * alpha + 1.0D+00 ) / bot else if ( j == n ) then a(i,j) = -1.0D+00 / bot end if else if ( i == j + 1 .or. j == 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 ) !*****************************************************************************80 ! !! kms_ldl() returns the LDL factorization of the KMS matrix. ! ! Discussion: ! ! A = L * D * L' ! ! Example: ! ! ALPHA = 0.5, N = 5 ! ! D = ! ! 1 0 0 0 0 ! 0 3/4 0 0 0 ! 0 0 3/4 0 0 ! 0 0 0 3/4 0 ! 0 0 0 0 3/4 ! ! L = ! ! 1 0 0 0 0 ! 1/2 1 0 0 0 ! 1/4 1/2 1 0 0 ! 1/8 1/4 1/2 1 0 ! 1/16 1/8 1/4 1/2 1 ! ! Licensing: ! ! This code is distributed under the MIT license. ! ! Modified: ! ! 12 October 2007 ! ! Author: ! ! John Burkardt ! ! Reference: ! ! William Trench, ! Numerical solution of the eigenvalue problem for Hermitian ! Toeplitz matrices, ! SIAM Journal on Matrix Analysis and Applications, ! Volume 10, Number 2, April 1989, pages 135-146. ! ! Input: ! ! real ( kind = rk ) ALPHA, the scalar that defines A. ! A typical value is 0.5. ! ! integer N, the order of the matrix. ! ! Output: ! ! real ( kind = rk ) L(N,N), the lower triangular factor. ! ! real ( kind = rk ) D(N,N), the diagonal factor. ! implicit none integer, parameter :: rk = kind ( 1.0D+00 ) integer n real ( kind = rk ) alpha real ( kind = rk ) d(n,n) integer i integer j real ( kind = rk ) 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 l(1:j-1,j) = 0.0D+00 l(j:n,j) = l(1:n+1-j,1) end do d(1:n,1:n) = 0.0D+00 d(1,1) = 1.0D+00 do i = 2, n d(i,i) = 1.0D+00 - alpha * alpha end do return end subroutine kms_lu ( alpha, n, l, u ) !*****************************************************************************80 ! !! kms_lu() returns the LU factors of the KMS matrix. ! ! Example: ! ! ALPHA = 0.5, N = 5 ! ! P = Identity matrix ! ! L = ! ! 1 0 0 0 0 ! 1/2 1 0 0 0 ! 1/4 1/2 1 0 0 ! 1/8 1/4 1/2 1 0 ! 1/16 1/8 1/4 1/2 1 ! ! U = ! ! 1 1/2 1/4 1/8 1/16 ! 0 3/4 3/8 3/16 3/32 ! 0 0 3/4 3/8 3/16 ! 0 0 0 3/4 3/8 ! 0 0 0 0 3/4 ! ! Licensing: ! ! This code is distributed under the MIT license. ! ! Modified: ! ! 28 October 2021 ! ! Author: ! ! John Burkardt ! ! Reference: ! ! William Trench, ! Numerical solution of the eigenvalue problem for Hermitian ! Toeplitz matrices, ! SIAM Journal on Matrix Analysis and Applications, ! Volume 10, Number 2, April 1989, pages 135-146. ! ! Input: ! ! real ( kind = rk ) ALPHA, the scalar that defines A. ! A typical value is 0.5. ! ! integer N, the order of the matrix. ! ! Output: ! ! real ( kind = rk ) L(N,N), U(N,N), the factors. ! implicit none integer, parameter :: rk = kind ( 1.0D+00 ) integer n real ( kind = rk ) alpha integer i integer j real ( kind = rk ) l(n,n) real ( kind = rk ) u(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 l(1:j-1,j) = 0.0D+00 l(j:n,j) = l(1:n+1-j,1) 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_plu ( alpha, n, p, l, u ) !*****************************************************************************80 ! !! kms_plu() returns the PLU factors of the KMS matrix. ! ! Example: ! ! ALPHA = 0.5, N = 5 ! ! P = Identity matrix ! ! L = ! ! 1 0 0 0 0 ! 1/2 1 0 0 0 ! 1/4 1/2 1 0 0 ! 1/8 1/4 1/2 1 0 ! 1/16 1/8 1/4 1/2 1 ! ! U = ! ! 1 1/2 1/4 1/8 1/16 ! 0 3/4 3/8 3/16 3/32 ! 0 0 3/4 3/8 3/16 ! 0 0 0 3/4 3/8 ! 0 0 0 0 3/4 ! ! Licensing: ! ! This code is distributed under the MIT license. ! ! Modified: ! ! 16 August 2008 ! ! Author: ! ! John Burkardt ! ! Reference: ! ! William Trench, ! Numerical solution of the eigenvalue problem for Hermitian ! Toeplitz matrices, ! SIAM Journal on Matrix Analysis and Applications, ! Volume 10, Number 2, April 1989, pages 135-146. ! ! Input: ! ! real ( kind = rk ) ALPHA, the scalar that defines A. ! A typical value is 0.5. ! ! integer N, the order of the matrix. ! ! Output: ! ! real ( kind = rk ) P(N,N), L(N,N), U(N,N), the PLU factors. ! implicit none integer, parameter :: rk = kind ( 1.0D+00 ) integer n real ( kind = rk ) alpha integer i integer j real ( kind = rk ) l(n,n) real ( kind = rk ) p(n,n) real ( kind = rk ) u(n,n) do j = 1, n do i = 1, n if ( i == 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 l(1:j-1,j) = 0.0D+00 l(j:n,j) = l(1:n+1-j,1) 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 krylov_matrix ( n, b, x, a ) !*****************************************************************************80 ! !! krylov_matrix() returns the KRYLOV matrix. ! ! Formula: ! ! Column 1 of A is X. ! Column 2 of A is B*X. ! Column 3 of A is B*B*X. ! .. ! Column N of A is B^(N-1)*X. ! ! Example: ! ! N = 5, X = ( 1, -2, 3, -4, 5 ) ! ! Matrix B: ! ! 1 2 1 0 1 ! 1 0 3 1 4 ! 2 1 3 2 1 ! 1 1 2 1 0 ! 1 -4 3 5 0 ! ! Matrix A: ! ! 6 61 71 688 ! 26 16 -37 2752 ! 6 54 312 1878 ! 1 44 229 887 ! -2 -76 379 2300 ! ! Properties: ! ! A is generally not symmetric: A' /= A. ! ! The family of matrices is nested as a function of N. ! ! Licensing: ! ! This code is distributed under the MIT license. ! ! Modified: ! ! 15 April 1999 ! ! Author: ! ! John Burkardt ! ! Reference: ! ! Gene Golub, Charles Van Loan, ! Matrix Computations, ! Johns Hopkins University Press, 1983, page 224. ! ! Input: ! ! integer N, the order of the matrices. ! ! real ( kind = rk ) B(N,N), the multiplying matrix. ! ! real ( kind = rk ) X(N), the vector defining A. ! ! Output: ! ! real ( kind = rk ) A(N,N), the matrix. ! implicit none integer, parameter :: rk = kind ( 1.0D+00 ) integer n real ( kind = rk ) a(n,n) real ( kind = rk ) b(n,n) integer j real ( kind = rk ) x(n) a(1:n,1) = x(1:n) do j = 2, n a(1:n,j) = matmul ( b(1:n,1:n), a(1:n,j-1) ) end do return end subroutine laguerre_matrix ( n, a ) !*****************************************************************************80 ! !! laguerre_matrix() returns the LAGUERRE matrix. ! ! Example: ! ! N = 8 (each column must be divided by the factor below it.) ! ! 1 1 2 6 24 120 720 5040 ! . -1 -4 -18 -96 -600 -4320 -35280 ! . . 1 9 72 600 5400 52920 ! . . . 1 -16 -200 -2400 -29400 ! . . . . 1 25 450 7350 ! . . . . . -1 -36 -882 ! . . . . . . 1 49 ! . . . . . . . -1 ! ! /1 /1 /2 /6 /24 /120 /720 /5040 ! ! Licensing: ! ! This code is distributed under the MIT license. ! ! Modified: ! ! 24 February 2024 ! ! Author: ! ! John Burkardt ! ! Reference: ! ! Milton Abramowitz, Irene Stegun, ! Handbook of Mathematical Functions, ! US Department of Commerce, 1964. ! ! Input: ! ! integer N, the order of the matrix. ! ! Output: ! ! real ( kind = rk ) A(N,N), the matrix. ! implicit none integer, parameter :: rk = kind ( 1.0D+00 ) integer n real ( kind = rk ) A(n,n) integer i integer j if ( n <= 0 ) then return end if A(1:n,1:n) = 0.0D+00 A(1,1) = 1.0D+00 if ( n == 1 ) then return end if A(1,2) = 1.0D+00 A(2,2) = -1.0D+00 if ( n == 2 ) then return end if do j = 3, n do i = 1, n if ( i == 1 ) then A(i,j) = ( real ( 2 * j - 3, kind = rk ) * A(i,j-1) & + real ( - j + 2, kind = rk ) * A(i,j-2) ) & / real ( j - 1, kind = rk ) else A(i,j) = ( real ( 2 * j - 3, kind = rk ) * A(i,j-1) & - real ( 1, kind = rk ) * A(i-1,j-1) & + real ( - j + 2, kind = rk ) * A(i,j-2) ) & / real ( j - 1, kind = rk ) end if end do end do return end subroutine laguerre_determinant ( n, determ ) !*****************************************************************************80 ! !! laguerre_determinant() returns the determinant of the LAGUERRE matrix. ! ! Licensing: ! ! This code is distributed under the MIT license. ! ! Modified: ! ! 03 November 2007 ! ! Author: ! ! John Burkardt ! ! Input: ! ! integer N, the order of the matrix. ! ! Output: ! ! real ( kind = rk ) DETERM, the determinant. ! implicit none integer, parameter :: rk = kind ( 1.0D+00 ) real ( kind = rk ) determ integer i integer im1 integer n real ( kind = rk ) p real ( kind = rk ) 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 ) !*****************************************************************************80 ! !! laguerre_inverse() returns the inverse of the LAGUERRE matrix. ! ! Example: ! ! N = 9 ! ! 1 1 2 6 24 120 720 5040 40320 ! . -1 -4 -18 -96 -600 -4320 -35280 -322560 ! . . 2 18 144 1200 10800 105840 1128960 ! . . . -6 -96 -1200 -14400 -176400 -2257920 ! . . . . 24 600 10800 176400 2822400 ! . . . . . -120 -4320 -105840 -2257920 ! . . . . . . 720 35280 1128960 ! . . . . . . . -5040 -322560 ! . . . . . . . . 40320 ! ! Licensing: ! ! This code is distributed under the MIT license. ! ! Modified: ! ! 22 February 2024 ! ! Author: ! ! John Burkardt ! ! Input: ! ! integer N, the order of the matrix. ! ! Output: ! ! real ( kind = rk ) A(N,N), the matrix. ! implicit none integer, parameter :: rk = kind ( 1.0D+00 ) integer n real ( kind = rk ) A(n,n) integer i integer j if ( n <= 0 ) then return end if A(1:n,1:n) = 0.0D+00 A(1,1) = 1.0D+00 if ( n == 1 ) then return end if A(1,2) = 1.0D+00 A(2,2) = -1.0D+00 if ( n == 2 ) then return end if do j = 3, n do i = 1, n if ( i == 1 ) then A(i,j) = real ( j - 1, kind = rk ) * ( A(i,j-1) ) else A(i,j) = real ( j - 1, kind = rk ) * ( A(i,j-1) - A(i-1,j-1) ) end if end do end do return end subroutine lauchli_matrix ( alpha, m, n, a ) !*****************************************************************************80 ! !! lauchli_matrix() returns the LAUCHLI matrix. ! ! Discussion: ! ! The Lauchli matrix is of order M by N, with M = N + 1. ! ! This matrix is a well-known example in least squares that indicates ! the danger of forming the matrix of the normal equations, A' * A. ! ! A common value for ALPHA is sqrt(EPS) where EPS is the machine epsilon. ! ! Formula: ! ! if ( I = 1 ) ! A(I,J) = 1 ! else if ( I-1 = J ) ! A(I,J) = ALPHA ! else ! A(I,J) = 0 ! ! Example: ! ! M = 5, N = 4 ! ALPHA = 2 ! ! 1 1 1 1 ! 2 0 0 0 ! 0 2 0 0 ! 0 0 2 0 ! 0 0 0 2 ! ! Properties: ! ! The matrix is singular in a simple way. The first row is ! equal to the sum of the other rows, divided by ALPHA. ! ! if ( ALPHA /= 0 ) then ! rank ( A ) = N - 1 ! else if ( ALPHA == 0 ) then ! rank ( A ) = 1 ! ! The family of matrices is nested as a function of N. ! ! Licensing: ! ! This code is distributed under the MIT license. ! ! Modified: ! ! 15 April 1999 ! ! Author: ! ! John Burkardt ! ! Reference: ! ! Peter Lauchli, ! Jordan-Elimination und Ausgleichung nach kleinsten Quadraten, ! (Jordan elimination and smoothing by least squares), ! Numerische Mathematik, ! Volume 3, Number 1, December 1961, pages 226-240. ! ! Input: ! ! real ( kind = rk ) ALPHA, the scalar defining the matrix. ! ! integer M, N, the order of the matrix. ! It should be the case that M = N + 1. ! ! Output: ! ! real ( kind = rk ) A(M,N), the matrix. ! implicit none integer, parameter :: rk = kind ( 1.0D+00 ) integer m integer n real ( kind = rk ) a(m,n) real ( kind = rk ) alpha integer i integer j do j = 1, n do i = 1, m if ( i == 1 ) then a(i,j) = 1.0D+00 else if ( i == 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 ) !*****************************************************************************80 ! !! lauchli_null_left() returns a left null vector of the LAUCHLI matrix. ! ! Licensing: ! ! This code is distributed under the MIT license. ! ! Modified: ! ! 03 November 2007 ! ! Author: ! ! John Burkardt ! ! Input: ! ! real ( kind = rk ) ALPHA, the scalar defining the matrix. ! ! integer M, N, the order of the matrix. ! It should be the case that M = N + 1. ! ! Output: ! ! real ( kind = rk ) X(M), the vector. ! implicit none integer, parameter :: rk = kind ( 1.0D+00 ) integer m integer n real ( kind = rk ) alpha real ( kind = rk ) x(m) call i4_fake_use ( n ) x(1) = - alpha x(2:m) = 1.0D+00 return end subroutine legendre_matrix ( n, A ) !*****************************************************************************80 ! !! legendre_matrix() returns the LEGENDRE matrix. ! ! Example: ! ! N = 11 (each column must be divided by factor at bottom) ! ! 1 . -1 . 3 . -5 . 35 . -63 ! . 1 . -3 . 15 . -25 . 315 . ! . . 3 . -30 . 105 . -1260 . 3465 ! . . . 5 . -70 . 315 . -4620 . ! . . . . 35 . -315 . 6930 .-30030 ! . . . . . 63 . -693 . 18018 . ! . . . . . . 231 . -12012 . 90090 ! . . . . . . . 429 .-25740 . ! . . . . . . . . 6435 -109395 ! . . . . . . . . . 12155 . ! . . . . . . . . . . 46189 ! ! /1 /1 /2 /2 /8 /8 /16 /16 /128 /128 /256 ! ! Properties: ! ! A is generally not symmetric: A' /= A. ! ! A is lower triangular. ! ! The elements of each row sum to 1. ! ! Because it has a constant row sum of 1, ! A has an eigenvalue of 1, and ! a (right) eigenvector of ( 1, 1, 1, ..., 1 ). ! ! A is reducible. ! ! The diagonals form a pattern of zero, positive, zero, negative. ! ! The family of matrices is nested as a function of N. ! ! A is not diagonally dominant. ! ! Licensing: ! ! This code is distributed under the MIT license. ! ! Modified: ! ! 20 February 2024 ! ! Author: ! ! John Burkardt ! ! Input: ! ! integer N, the order of A. ! ! Output: ! ! real A(N,N), the matrix. ! implicit none integer, parameter :: rk = kind ( 1.0D+00 ) integer n real ( kind = rk ) A(n,n) integer i integer j A(1:n,1:n) = 0.0D+00 if ( n <= 0 ) then return end if A(1,1) = 1.0D+00 if ( n == 1 ) then return end if A(2,2) = 1.0D+00 if ( n == 2 ) then return end if do j = 3, n do i = 1, n if ( i == 1 ) then A(i,j) = - ( j - 2 ) * A(i,j-2) & / ( j - 1 ) else A(i,j) = ( ( 2 * j - 3 ) * A(i-1,j-1) & + ( - j + 2 ) * A(i,j-2) ) & / ( j - 1 ) end if end do end do return end subroutine legendre_determinant ( n, value ) !*****************************************************************************80 ! !! legendre_determinant() returns the determinant of the LEGENDRE matrix. ! ! Licensing: ! ! This code is distributed under the MIT license. ! ! Modified: ! ! 07 February 2015 ! ! Author: ! ! John Burkardt ! ! Input: ! ! integer N, the order of the matrix. ! ! Output: ! ! real ( kind = rk ) VALUE, the determinant. ! implicit none integer, parameter :: rk = kind ( 1.0D+00 ) integer i integer n real ( kind = rk ) t real ( kind = rk ) value value = 1.0D+00 t = 1.0D+00 do i = 3, n t = t * real ( 2 * i - 3, kind = rk ) / real ( i - 1, kind = rk ) value = value * t; end do return end subroutine legendre_inverse ( n, A ) !*****************************************************************************80 ! !! legendre_inverse(): convert monomial to Legendre basis. ! ! Discussion: ! ! If PM(x) is a linear combination of monomials ! with coefficients CM, then PL(x) is a linear combination of ! Legendre polynomials with coefficients CL = A * CM. ! ! Note that we assume the coefficients are ordered such that ! the constant term is first. ! ! Example: ! ! N = 11 (each column must be divided by the underlying factor). ! ! 1 . 1 . 7 . 33 . 715 . 4199 ! . 1 . 3 . 27 . 143 . 3315 . ! . . 2 . 20 . 110 . 2600 .16150 ! . . . 2 . 28 . 182 . 4760 . ! . . . . 8 . 72 . 2160 .15504 ! . . . . . 8 . 88 . 2992 . ! . . . . . . 16 . 832 . 7904 ! . . . . . . . 16 . 960 . ! . . . . . . . . 128 . 2176 ! . . . . . . . . . 128 . ! . . . . . . . . . . 256 ! ! /1 /1 /3 /5 /35 /63 /231 /429 /6435/12155/46189 ! ! Licensing: ! ! This code is distributed under the MIT license. ! ! Modified: ! ! 19 February 2024 ! ! Author: ! ! John Burkardt ! ! Input: ! ! integer N, the order of the matrix. ! ! Output: ! ! real A(N,N), the matrix. ! implicit none integer, parameter :: rk = kind ( 1.0D+00 ) integer n real ( kind = rk ) A(n,n) integer i integer j A(1:n,1:n) = 0.0D+00 if ( n <= 0 ) then return end if A(1,1) = 1.0D+00 if ( n == 1 ) then return end if A(2,2) = 1.0D+00 if ( n == 2 ) then return end if do j = 3, n do i = 1, n if ( i == 1 ) then A(i,j) = ( i ) * A(i+1,j-1) / ( 2 * i + 1 ) else if ( i < n ) then A(i,j) = ( i - 1 ) * A(i-1,j-1) / ( 2 * i - 3 ) & + ( i ) * A(i+1,j-1) / ( 2 * i + 1 ) else A(i,j) = ( i - 1 ) * A(i-1,j-1) / ( 2 * i - 3 ) end if end do end do return end subroutine legendre_symbol ( q, p, l ) !*****************************************************************************80 ! !! legendre_symbol() evaluates the Legendre symbol (Q/P). ! ! Discussion: ! ! Let P be an odd prime. Q is a QUADRATIC RESIDUE modulo P ! if there is an integer R such that R*R = Q ( mod P ). ! The Legendre symbol ( Q / P ) is defined to be: ! ! + 1 if Q ( mod P ) /= 0 and Q is a quadratic residue modulo P, ! - 1 if Q ( mod P ) /= 0 and Q is not a quadratic residue modulo P, ! 0 if Q ( mod P ) == 0. ! ! We can also define ( Q / P ) for P = 2 by: ! ! + 1 if Q ( mod P ) /= 0 ! 0 if Q ( mod P ) == 0 ! ! Example: ! ! (0/7) = 0 ! (1/7) = + 1 ( 1^2 = 1 mod 7 ) ! (2/7) = + 1 ( 3^2 = 2 mod 7 ) ! (3/7) = - 1 ! (4/7) = + 1 ( 2^2 = 4 mod 7 ) ! (5/7) = - 1 ! (6/7) = - 1 ! ! Note: ! ! For any prime P, exactly half of the integers from 1 to P-1 ! are quadratic residues. ! ! ( 0 / P ) = 0. ! ! ( Q / P ) = ( mod ( Q, P ) / P ). ! ! ( Q / P ) = ( Q1 / P ) * ( Q2 / P ) if Q = Q1 * Q2. ! ! If Q is prime, and P is prime and greater than 2, then: ! ! if ( Q == 1 ) then ! ! ( Q / P ) = 1 ! ! else if ( Q == 2 ) then ! ! ( Q / P ) = + 1 if mod ( P, 8 ) = 1 or mod ( P, 8 ) = 7, ! ( Q / P ) = - 1 if mod ( P, 8 ) = 3 or mod ( P, 8 ) = 5. ! ! else ! ! ( Q / P ) = - ( P / Q ) if Q = 3 ( mod 4 ) and P = 3 ( mod 4 ), ! = ( P / Q ) otherwise. ! ! Licensing: ! ! This code is distributed under the MIT license. ! ! Modified: ! ! 28 March 2001 ! ! Author: ! ! John Burkardt ! ! Reference: ! ! Charles Pinter, ! A Book of Abstract Algebra, ! McGraw Hill, 1982, pages 236-237. ! ! Daniel Zwillinger, ! CRC Standard Mathematical Tables and Formulae, ! 30th Edition, ! CRC Press, 1996, pages 86-87. ! ! Input: ! ! integer Q, an integer whose Legendre symbol with ! respect to P is desired. ! ! integer P, a prime number, greater than 1, with respect ! to which the Legendre symbol of Q is desired. ! ! Output: ! ! integer L, the Legendre symbol (Q/P). ! Ordinarily, L will be -1, 0 or 1. ! L = -2, P is less than or equal to 1. ! L = -3, P is not prime. ! L = -4, the internal stack of factors overflowed. ! L = -5, not enough factorization space. ! implicit none integer, parameter :: rk = kind ( 1.0D+00 ) integer, parameter :: maxfactor = 20 integer, 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 ! ! P must be greater than 1. ! if ( p <= 1 ) then write ( *, '(a)' ) ' ' write ( *, '(a)' ) 'legendre_symbol - Fatal error!' write ( *, '(a)' ) ' P must be greater than 1.' l = -2 stop 1 end if ! ! P must be prime. ! if ( .not. i4_is_prime ( p ) ) then write ( *, '(a)' ) ' ' write ( *, '(a)' ) 'legendre_symbol - Fatal error!' write ( *, '(a)' ) ' P is not prime.' l = -3 stop 1 end if ! ! ( k*P / P ) = 0. ! if ( mod ( q, p ) == 0 ) then l = 0 return end if ! ! For the special case P = 2, (Q/P) = 1 for all odd numbers. ! if ( p == 2 ) then l = 1 return end if ! ! Make a copy of Q, and force it to be nonnegative. ! qq = q do while ( qq < 0 ) qq = qq + p end do nstack = 0 pp = p l = 1 do qq = mod ( qq, pp ) ! ! Decompose QQ into factors of prime powers. ! call i4_factor ( qq, maxfactor, nfactor, factor, power, nleft ) if ( nleft /= 1 ) then write ( *, '(a)' ) ' ' write ( *, '(a)' ) 'legendre_symbol - Fatal error!' write ( *, '(a)' ) ' Not enough factorization space.' l = - 5 stop 1 end if ! ! Each factor which is an odd power is added to the stack. ! nmore = 0 do i = 1, nfactor if ( mod ( power(i), 2 ) == 1 ) then nmore = nmore + 1 nstack = nstack + 1 if ( maxstack < nstack ) then write ( *, '(a)' ) ' ' write ( *, '(a)' ) 'legendre_symbol - Fatal error!' write ( *, '(a)' ) ' Stack overflow!' l = - 4 stop 1 end if pstack(nstack) = pp qstack(nstack) = factor(i) end if end do if ( nmore /= 0 ) then qq = qstack(nstack) nstack = nstack - 1 ! ! Check for a QQ of 1 or 2. ! if ( qq == 1 ) then l = + 1 * l else if ( qq == 2 .and. & ( mod ( pp, 8 ) == 1 .or. mod ( pp, 8 ) == 7 ) ) then l = + 1 * l else if ( qq == 2 .and. & ( mod ( pp, 8 ) == 3 .or. mod ( pp, 8 ) == 5 ) ) then l = - 1 * l else if ( mod ( pp, 4 ) == 3 .and. mod ( qq, 4 ) == 3 ) then l = - 1 * l end if t = pp pp = qq qq = t cycle end if end if ! ! If the stack is empty, we're done. ! if ( nstack == 0 ) then exit end if ! ! Otherwise, get the last P and Q from the stack, and process them. ! pp = pstack(nstack) qq = qstack(nstack) nstack = nstack - 1 end do return end subroutine legendre_van_matrix ( m, a, b, n, x, v ) !*****************************************************************************80 ! !! legendre_van_matrix() returns the legendre_VAN matrix. ! ! Discussion: ! ! The legendre_VAN matrix is the Legendre Vandermonde-like matrix. ! ! Normally, the Legendre polynomials are defined on -1 <= XI <= +1. ! Here, we assume the Legendre polynomials have been defined on the ! interval A <= X <= B, using the mapping ! XI = ( - ( B - X ) + ( X - A ) ) / ( B - A ) ! so that ! Lab(A,B;X) = L(XI). ! ! if ( I = 1 ) then ! V(1,1:N) = 1 ! else if ( I = 2 ) then ! V(2,1:N) = XI(1:N) ! else ! V(I,1:N) = ( (2*I-1) * XI(1:N) * V(I-1,1:N) - (I-1)*V(I-2,1:N) ) / I ! ! Example: ! ! M = 5, A = -1.0, B = +1.0, N = 5, X = ( -1, -1/2, 0, +1/2, +1 ) ! ! 1.0000 1.0000 1.0000 1.0000 1.0000 ! -1.0000 -0.5000 0 0.5000 1.0000 ! 1.0000 -0.2500 -0.6667 -0.2500 1.0000 ! -1.0000 0.5938 0 -0.5938 1.0000 ! 1.0000 -0.3344 0.5333 -0.3344 1.0000 ! ! Licensing: ! ! This code is distributed under the MIT license. ! ! Modified: ! ! 10 April 2014 ! ! Author: ! ! John Burkardt ! ! Input: ! ! integer M, the number of rows of the matrix. ! ! real ( kind = rk ) A, B, the interval. ! ! integer N, the number of columns of the matrix. ! ! real ( kind = rk ) X(N), the vector that defines the matrix. ! ! Output: ! ! real ( kind = rk ) V(M,N), the matrix. ! implicit none integer, parameter :: rk = kind ( 1.0D+00 ) integer m integer n real ( kind = rk ) a real ( kind = rk ) b integer i integer j real ( kind = rk ) v(m,n) real ( kind = rk ) x(n) real ( kind = rk ) xi do j = 1, n xi = ( - ( b - x(j) ) + ( x(j) - a ) ) / ( b - a ) do i = 1, m if ( i == 1 ) then v(i,j) = 1.0D+00 else if ( i == 2 ) then v(i,j) = xi else v(i,j) = ( real ( 2 * i - 1, kind = rk ) * xi * v(i-1,j) + & real ( - i + 1, kind = rk ) * v(i-2,j) ) & / real ( i, kind = rk ) end if end do end do return end subroutine legendre_zeros ( n, x ) !*****************************************************************************80 ! !! legendre_zeros() computes the zeros of the Legendre polynomial. ! ! Licensing: ! ! This code is distributed under the MIT license. ! ! Modified: ! ! 24 May 2002 ! ! Author: ! ! Original FORTRAN77 version by Philip Davis, Philip Rabinowitz. ! FORTRAN90 version by John Burkardt. ! ! Input: ! ! integer N, the degree of the polynomial. ! ! Output: ! ! real ( kind = rk ) X(N), the zeros of the polynomial. ! implicit none integer, parameter :: rk = kind ( 1.0D+00 ) integer n real ( kind = rk ) d1 real ( kind = rk ) d2pn real ( kind = rk ) d3pn real ( kind = rk ) d4pn real ( kind = rk ) dp real ( kind = rk ) dpn real ( kind = rk ) e1 real ( kind = rk ) fx real ( kind = rk ) h integer i integer iback integer k integer m integer mp1mi integer ncopy integer nmove real ( kind = rk ) p real ( kind = rk ), parameter :: r8_pi = 3.141592653589793D+00 real ( kind = rk ) pk real ( kind = rk ) pkm1 real ( kind = rk ) pkp1 real ( kind = rk ) t real ( kind = rk ) u real ( kind = rk ) v real ( kind = rk ) x0 real ( kind = rk ) x(n) real ( kind = rk ) xtemp e1 = real ( n * ( n + 1 ), kind = rk ) m = ( n + 1 ) / 2 do i = 1, m mp1mi = m + 1 - i t = real ( 4 * i - 1, kind = rk ) * r8_pi / real ( 4 * n + 2, kind = rk ) x0 = cos(t) * ( 1.0D+00 - ( 1.0D+00 - 1.0D+00 / real ( n, kind = rk ) ) & / real ( 8 * n * n, kind = rk ) ) pkm1 = 1.0D+00 pk = x0 do k = 2, n pkp1 = 2.0D+00 * x0 * pk - pkm1 - ( x0 * pk - pkm1 ) & / real ( k, kind = rk ) pkm1 = pk pk = pkp1 end do d1 = real ( n, kind = rk ) * ( 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 ! ! Initial approximation H: ! h = - u * ( 1.0D+00 + 0.5D+00 * u * ( v + u * ( v * v - d3pn / & ( 3.0D+00 * dpn ) ) ) ) ! ! Refine H using one step of Newton's method: ! 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 ) == 1 ) then x(1) = 0.0D+00 end if ! ! Shift the data up. ! nmove = ( n + 1 ) / 2 ncopy = n - nmove do i = 1, nmove iback = n + 1 - i x(iback) = x(iback-ncopy) end do ! ! Reflect values for the negative abscissas. ! do i = 1, n - nmove x(i) = - x(n+1-i) end do return end subroutine lehmer_matrix ( m, n, a ) !*****************************************************************************80 ! !! lehmer_matrix() returns the LEHMER matrix. ! ! Discussion: ! ! This matrix is also known as the "Westlake" matrix. ! ! See page 154 of the Todd reference. ! ! Formula: ! ! A(I,J) = min ( I, J ) / max ( I, J ) ! ! Example: ! ! N = 5 ! ! 1/1 1/2 1/3 1/4 1/5 ! 1/2 2/2 2/3 2/4 2/5 ! 1/3 2/3 3/3 3/4 3/5 ! 1/4 2/4 3/4 4/4 4/5 ! 1/5 2/5 3/5 4/5 5/5 ! ! Properties: ! ! A is symmetric: A' = A. ! ! Because A is symmetric, it is normal. ! ! Because A is normal, it is diagonalizable. ! ! A is positive definite. ! ! A is totally nonnegative. ! ! The inverse of A is tridiagonal. ! ! The condition number of A lies between N and 4*N*N. ! ! The family of matrices is nested as a function of N. ! ! Licensing: ! ! This code is distributed under the MIT license. ! ! Modified: ! ! 15 April 1999 ! ! Author: ! ! John Burkardt ! ! Reference: ! ! Morris Newman, John Todd, ! The evaluation of matrix inversion programs, ! Journal of the Society for Industrial and Applied Mathematics, ! Volume 6, Number 4, 1958, pages 466-476. ! ! Solutions to problem E710, proposed by DH Lehmer: The inverse of ! a matrix. ! American Mathematical Monthly, ! Volume 53, Number 9, November 1946, pages 534-535. ! ! John Todd, ! Basic Numerical Mathematics, ! Volume 2: Numerical Algebra, ! Birkhauser, 1980, ! ISBN: 0817608117, ! LC: QA297.T58. ! ! Input: ! ! integer M, N, the order of the matrix. ! ! Output: ! ! real ( kind = rk ) A(M,N), the matrix. ! implicit none integer, parameter :: rk = kind ( 1.0D+00 ) integer m integer n real ( kind = rk ) a(m,n) integer i integer j do j = 1, n do i = 1, m a(i,j) = real ( min ( i, j ), kind = rk ) / real ( max ( i, j ), kind = rk ) end do end do return end subroutine lehmer_determinant ( n, value ) !*****************************************************************************80 ! !! lehmer_determinant() returns the determinant of the LEHMER matrix. ! ! Formula: ! ! determinant = (2n)! / 2^n / (n!)^3 ! ! Licensing: ! ! This code is distributed under the MIT license. ! ! Modified: ! ! 06 April 2015 ! ! Author: ! ! John Burkardt ! ! Reference: ! ! Emrah Kilic, Pantelimon Stanica, ! The Lehmer matrix and its recursive analogue, ! Journal of Combinatorial Mathematics and Combinatorial Computing, ! Volume 74, August 2010, pages 193-205. ! ! Input: ! ! integer N, the order of the matrix. ! ! Output: ! ! real ( kind = rk ) VALUE, the determinant. ! implicit none integer, parameter :: rk = kind ( 1.0D+00 ) integer i integer n real ( kind = rk ) value value = 1.0D+00 do i = 1, n value = value * real ( n + i, kind = rk ) / real ( 2 * i * i, kind = rk ) end do return end subroutine lehmer_inverse ( n, a ) !*****************************************************************************80 ! !! lehmer_inverse() returns the inverse of the LEHMER matrix. ! ! Example: ! ! N = 5 ! ! 1.3333 -0.6667 0 0 0 ! -0.6667 2.1333 -1.2000 0 0 ! 0 -1.2000 3.0857 -1.7143 0 ! 0 0 -1.7143 4.0635 -2.2222 ! 0 0 0 -2.2222 2.7778 ! ! Properties: ! ! The family of inverse Lehmer matrices is NEARLY nested as a function of N. ! The (N,N) element of the N-th matrix is not the (N,N) element of ! subsequent matrices. ! ! Licensing: ! ! This code is distributed under the MIT license. ! ! Modified: ! ! 21 May 2002 ! ! Author: ! ! John Burkardt ! ! Input: ! ! integer N, the order of the matrix. ! ! Output: ! ! real ( kind = rk ) A(N,N), the matrix. ! implicit none integer, parameter :: rk = kind ( 1.0D+00 ) integer n real ( kind = rk ) a(n,n) integer i a(1:n,1:n) = 0.0D+00 do i = 1, n - 1 a(i,i) = real ( 4 * i * i * i, kind = rk ) / real ( 4 * i * i - 1, kind = rk ) end do a(n,n) = real ( n * n, kind = rk ) / real ( 2 * n - 1, kind = rk ) do i = 1, n - 1 a(i,i+1) = - real ( i * ( i + 1 ), kind = rk ) / real ( 2 * i + 1, kind = rk ) a(i+1,i) = - real ( i * ( i + 1 ), kind = rk ) / real ( 2 * i + 1, kind = rk ) end do return end subroutine lehmer_llt ( n, a ) !*****************************************************************************80 ! !! lehmer_llt() returns the Cholesky factor of the LEHMER matrix. ! ! Licensing: ! ! This code is distributed under the MIT license. ! ! Modified: ! ! 06 April 2015 ! ! Author: ! ! John Burkardt ! ! Reference: ! ! Emrah Kilic, Pantelimon Stanica, ! The Lehmer matrix and its recursive analogue, ! Journal of Combinatorial Mathematics and Combinatorial Computing, ! Volume 74, August 2010, pages 193-205. ! ! Input: ! ! integer N, the order of the matrix. ! ! Output: ! ! real ( kind = rk ) A(N,N), the matrix. ! implicit none integer, parameter :: rk = kind ( 1.0D+00 ) integer n real ( kind = rk ) 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 ( real ( 2 * j - 1, kind = rk ) ) / real ( i, kind = rk ) end do end do return end subroutine lehmer_lu ( n, l, u ) !*****************************************************************************80 ! !! lehmer_lu() returns the LU factors of the LEHMER matrix. ! ! Licensing: ! ! This code is distributed under the MIT license. ! ! Modified: ! ! 28 October 2021 ! ! Author: ! ! John Burkardt ! ! Reference: ! ! Emrah Kilic, Pantelimon Stanica, ! The Lehmer matrix and its recursive analogue, ! Journal of Combinatorial Mathematics and Combinatorial Computing, ! Volume 74, August 2010, pages 193-205. ! ! Input: ! ! integer N, the order of the matrix. ! ! Output: ! ! real ( kind = rk ) L(N,N), U(N,N), the factors. ! implicit none integer, parameter :: rk = kind ( 1.0D+00 ) integer n integer i integer j real ( kind = rk ) l(n,n) real ( kind = rk ) u(n,n) 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) = real ( j, kind = rk ) / real ( i, kind = rk ) end do end do do j = 1, n do i = 1, j u(i,j) = real ( 2 * i - 1, kind = rk ) / real ( i * j, kind = rk ) end do do i = j + 1, n u(i,j) = 0.0D+00 end do end do return end subroutine lehmer_plu ( n, p, l, u ) !*****************************************************************************80 ! !! lehmer_plu() returns the PLU factors of the LEHMER matrix. ! ! Licensing: ! ! This code is distributed under the MIT license. ! ! Modified: ! ! 06 April 2015 ! ! Author: ! ! John Burkardt ! ! Reference: ! ! Emrah Kilic, Pantelimon Stanica, ! The Lehmer matrix and its recursive analogue, ! Journal of Combinatorial Mathematics and Combinatorial Computing, ! Volume 74, August 2010, pages 193-205. ! ! Input: ! ! integer N, the order of the matrix. ! ! Output: ! ! real ( kind = rk ) P(N,N), L(N,N), U(N,N), the PLU factors. ! implicit none integer, parameter :: rk = kind ( 1.0D+00 ) integer n integer i integer j real ( kind = rk ) l(n,n) real ( kind = rk ) p(n,n) real ( kind = rk ) u(n,n) do j = 1, n do i = 1, n if ( i == 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) = real ( j, kind = rk ) / real ( i, kind = rk ) end do end do do j = 1, n do i = 1, j u(i,j) = real ( 2 * i - 1, kind = rk ) / real ( i * j, kind = rk ) end do do i = j + 1, n u(i,j) = 0.0D+00 end do end do return end subroutine leslie_matrix ( b, di, da, a ) !*****************************************************************************80 ! !! leslie_matrix() returns the LESLIE matrix. ! ! Discussion: ! ! This matrix is used in population dynamics. ! ! Formula: ! ! 5/6 * ( 1 - DI ) 0 B 0 ! 1/6 * ( 1 - DI ) 13/14 0 0 ! 0 1/14 39/40 0 ! 0 0 1/40 9/10 * ( 1 - DA ) ! ! Discussion: ! ! A human population is assumed to be grouped into the categories: ! ! X(1) = between 0 and 5+ ! X(2) = between 6 and 19+ ! X(3) = between 20 and 59+ ! X(4) = between 60 and 69+ ! ! Humans older than 69 are ignored. Deaths occur in the 60 to 69 ! year bracket at a relative rate of DA per year, and in the 0 to 5 ! year bracket at a relative rate of DI per year. Deaths do not occurr ! in the other two brackets. ! ! Births occur at a rate of B relative to the population in the ! 20 to 59 year bracket. ! ! Thus, given the population vector X in a given year, the population ! in the next year will be A * X. ! ! Licensing: ! ! This code is distributed under the MIT license. ! ! Modified: ! ! 03 September 1999 ! ! Author: ! ! John Burkardt ! ! Reference: ! ! Ke Chen, Peter Giblin, Alan Irving, ! Mathematical Explorations with MATLAB, ! Cambridge University Press, 1999, ! ISBN: 0-521-63920-4. ! ! Input: ! ! real ( kind = rk ) B, DI, DA, the birth rate, infant mortality rate, ! and aged mortality rate. These should be positive values. ! The mortality rates must be between 0.0D+00 and 1.0. Reasonable ! values might be B = 0.025, DI = 0.010, and DA = 0.100 ! ! Output: ! ! real ( kind = rk ) A(4,4), the matrix. ! implicit none integer, parameter :: rk = kind ( 1.0D+00 ) real ( kind = rk ) a(4,4) real ( kind = rk ) b real ( kind = rk ) da real ( kind = rk ) di if ( b < 0.0D+00 ) then write ( *, '(a)' ) ' ' write ( *, '(a)' ) 'LESLIE - Fatal error!' write ( *, '(a)' ) ' 0 <= B is required.' stop 1 end if if ( da < 0.0D+00 .or. 1.0D+00 < da ) then write ( *, '(a)' ) ' ' write ( *, '(a)' ) 'LESLIE - Fatal error!' write ( *, '(a)' ) ' 0 <= DA <= 1.0D+00 is required.' stop 1 end if if ( di < 0.0D+00 .or. 1.0D+00 < 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 ) !*****************************************************************************80 ! !! leslie_determinant() returns the determinant of the LESLIE matrix. ! ! Discussion: ! ! DETERM = a(4,4) * ( ! a(1,1) * a(2,2) * a(3,3) ! + a(1,3) * a(2,1) * a(3,2) ) ! ! Licensing: ! ! This code is distributed under the MIT license. ! ! Modified: ! ! 24 October 2007 ! ! Author: ! ! John Burkardt ! ! Input: ! ! real ( kind = rk ) B, DI, DA, the birth rate, infant mortality rate, ! and aged mortality rate. These should be positive values. ! The mortality rates must be between 0.0D+00 and 1.0. Reasonable ! values might be B = 0.025, DI = 0.010, and DA = 0.100 ! ! Output: ! ! real ( kind = rk ) DETERM, the determinant. ! implicit none integer, parameter :: rk = kind ( 1.0D+00 ) real ( kind = rk ) b real ( kind = rk ) da real ( kind = rk ) determ real ( kind = rk ) 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_matrix ( m, n, a ) !*****************************************************************************80 ! !! lesp_matrix() returns the LESP matrix. ! ! Formula: ! ! if ( I - J == 1 ) then ! A(I,J) = 1 / I ! else if ( I - J == 0 ) then ! A(I,J) = - ( 2*I+3 ) ! else if ( I - J == 1 ) then ! A(I,J) = J ! else ! A(I,J) = 0 ! ! Example: ! ! M = 5, N = 5 ! ! -5 2 . . . ! 1/2 -7 3 . . ! . 1/3 -9 4 . ! . . 1/4 -11 5 ! . . . 1/5 -13 ! ! ! Properties: ! ! The matrix is tridiagonal. ! ! Because A is tridiagonal, it has property A (bipartite). ! ! A is generally not symmetric: A' /= A. ! ! The eigenvalues are real, and smoothly distributed in [-2*N-3.5, -4.5]. ! ! The eigenvalues are sensitive. ! ! The matrix is similar to the symmetric tridiagonal matrix with ! the same diagonal entries and with off-diagonal entries 1, ! via a similarity transformation using the diagonal matrix ! D = diagonal ( 1!, 2!, ..., N! ). ! ! The family of matrices is nested as a function of N. ! ! Licensing: ! ! This code is distributed under the MIT license. ! ! Modified: ! ! 15 April 1999 ! ! Author: ! ! John Burkardt ! ! Reference: ! ! Wim Lenferink, MN Spijker, ! On the use of stability regions in the numerical analysis of initial ! value problems, ! Mathematics of Computation, ! Volume 57, 1991, pages 221-237. ! ! Lloyd Trefethen, ! Pseudospectra of matrices, ! in Numerical Analysis 1991, ! Proceedings of the 14th Dundee Conference, ! D F Griffiths and G A Watson, editors, ! Pitman Research Notes in Mathematics, volume 260, ! Longman Scientific and Technical, Essex, UK, 1992, pages 234-266. ! ! Input: ! ! integer M, N, the order of the matrix. ! ! Output: ! ! real ( kind = rk ) A(M,N), the matrix. ! implicit none integer, parameter :: rk = kind ( 1.0D+00 ) integer m integer n real ( kind = rk ) a(m,n) integer i integer j do j = 1, n do i = 1, m if ( i - j == 1 ) then a(i,j) = 1.0D+00 / real ( i, kind = rk ) else if ( i - j == 0 ) then a(i,j) = - real ( 2 * i + 3, kind = rk ) else if ( i - j == -1 ) then a(i,j) = real ( j, kind = rk ) else a(i,j) = 0.0D+00 end if end do end do return end subroutine lesp_determinant ( n, determ ) !*****************************************************************************80 ! !! lesp_determinant() returns the determinant of the LESP matrix. ! ! Licensing: ! ! This code is distributed under the MIT license. ! ! Modified: ! ! 08 November 2007 ! ! Author: ! ! John Burkardt ! ! Input: ! ! integer N, the order of the matrix. ! ! Output: ! ! real ( kind = rk ) DETERM, the determinant. ! implicit none integer, parameter :: rk = kind ( 1.0D+00 ) integer n real ( kind = rk ) determ real ( kind = rk ) determ_nm1 real ( kind = rk ) determ_nm2 integer i determ_nm1 = - real ( 2 * n + 3, kind = rk ) if ( n == 1 ) then determ = determ_nm1 return end if determ_nm2 = determ_nm1 determ_nm1 = real ( 2 * n + 1, kind = rk ) & * real ( 2 * n + 3, kind = rk ) - 1.0D00 if ( n == 2 ) then determ = determ_nm1 return end if do i = n - 2, 1, -1 determ = - real ( 2 * i + 3 ) * determ_nm1 - determ_nm2 determ_nm2 = determ_nm1 determ_nm1 = determ end do return end subroutine lesp_inverse ( n, a ) !*****************************************************************************80 ! !! lesp_inverse() returns the inverse of the LESP matrix. ! ! Discussion: ! ! This computation is an application of the triv_INVERSE function. ! ! Example: ! ! N = 5 ! ! -0.2060 -0.0598 -0.0201 -0.0074 -0.0028 ! -0.0150 -0.1495 -0.0504 -0.0184 -0.0071 ! -0.0006 -0.0056 -0.1141 -0.0418 -0.0161 ! -0.0000 -0.0001 -0.0026 -0.0925 -0.0356 ! -0.0000 -0.0000 -0.0000 -0.0014 -0.0775 ! ! Licensing: ! ! This code is distributed under the MIT license. ! ! Modified: ! ! 08 April 2015 ! ! Author: ! ! John Burkardt ! ! Reference: ! ! CM daFonseca, J Petronilho, ! Explicit Inverses of Some Tridiagonal Matrices, ! Linear Algebra and Its Applications, ! Volume 325, 2001, pages 7-21. ! ! Input: ! ! integer N, the order of the matrix. ! ! Output: ! ! real ( kind = rk ) A(N,N), the inverse of the matrix. ! implicit none integer, parameter :: rk = kind ( 1.0D+00 ) integer n real ( kind = rk ) a(n,n) integer i real ( kind = rk ) x(n-1) real ( kind = rk ) y(n) real ( kind = rk ) z(n-1) do i = 1, n - 1 x(i) = 1.0D+00 / real ( i + 1, kind = rk ) end do do i = 1, n y(i) = real ( - 2 * i - 3, kind = rk ) end do do i = 1, n - 1 z(i) = real ( i + 1, kind = rk ) end do call triv_inverse ( n, x, y, z, a ) return end subroutine lietzke_matrix ( n, a ) !*****************************************************************************80 ! !! lietzke_matrix() returns the LIETZKE matrix. ! ! Formula: ! ! A(I,J) = N - abs ( I - J ) ! ! Example: ! ! N = 5 ! ! 5 4 3 2 1 ! 4 5 4 3 2 ! 3 4 5 4 3 ! 2 3 4 5 4 ! 1 2 3 4 5 ! ! Properties: ! ! A is integral, therefore det ( A ) is integral, and ! det ( A ) * inverse ( A ) is integral. ! ! A is symmetric: A' = A. ! ! Because A is symmetric, it is normal. ! ! Because A is normal, it is diagonalizable. ! ! det ( A ) = ( n + 1 ) * 2^( n - 2 ) ! ! Licensing: ! ! This code is distributed under the MIT license. ! ! Modified: ! ! 09 September 2006 ! ! Author: ! ! John Burkardt ! ! Reference: ! ! M Lietzke, R Stoughton, Marjorie Lietzke, ! A Comparison of Several Methods for Inverting Large Symmetric ! Positive Definite Matrices, ! Mathematics of Computation, ! Volume 18, Number 87, pages 449-456. ! ! Input: ! ! integer N, the order of the matrix. ! ! Output: ! ! real ( kind = rk ) A(N,N), the matrix. ! implicit none integer, parameter :: rk = kind ( 1.0D+00 ) integer n real ( kind = rk ) a(n,n) integer i integer j do j = 1, n do i = 1, n a(i,j) = real ( n - abs ( i - j ), kind = rk ) end do end do return end subroutine lietzke_condition ( n, value ) !*****************************************************************************80 ! !! lietzke_condition() returns the L1 condition of the LIETZKE matrix. ! ! Licensing: ! ! This code is distributed under the MIT license. ! ! Modified: ! ! 08 April 2015 ! ! Author: ! ! John Burkardt ! ! Input: ! ! integer N, the order of the matrix. ! ! Output: ! ! real ( kind = rk ) VALUE, the L1 condition. ! implicit none integer, parameter :: rk = kind ( 1.0D+00 ) real ( kind = rk ) a_norm real ( kind = rk ) b_norm integer i integer k integer n integer s real ( kind = rk ) value s = 0 k = n do i = 1, n s = s + k if ( mod ( i, 2 ) == 1 ) then k = k - 1 end if end do a_norm = real ( s, kind = rk ) if ( n == 1 ) then b_norm = 0.25D+00 else if ( n == 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 ) !*****************************************************************************80 ! !! lietzke_determinant() returns the determinant of the LIETZKE matrix. ! ! Licensing: ! ! This code is distributed under the MIT license. ! ! Modified: ! ! 15 October 2007 ! ! Author: ! ! John Burkardt ! ! Input: ! ! integer N, the order of the matrix. ! ! Output: ! ! real ( kind = rk ) DETERM, the determinant. ! implicit none integer, parameter :: rk = kind ( 1.0D+00 ) real ( kind = rk ) determ integer n determ = real ( n + 1, kind = rk ) * real ( 2 ** ( n - 2 ), kind = rk ) return end subroutine lietzke_inverse ( n, a ) !*****************************************************************************80 ! !! lietzke_inverse() returns the inverse of the LIETZKE matrix. ! ! Example: ! ! N = 5 ! ! 0.5833 -0.5000 0 0 0.0833 ! -0.5000 1.0000 -0.5000 0 0 ! 0 -0.5000 1.0000 -0.5000 0 ! 0 0 -0.5000 1.0000 -0.5000 ! 0.0833 0 0 -0.5000 0.5833 ! ! Licensing: ! ! This code is distributed under the MIT license. ! ! Modified: ! ! 13 October 2007 ! ! Author: ! ! John Burkardt ! ! Input: ! ! integer N, the order of the matrix. ! ! Output: ! ! real ( kind = rk ) A(N,N), the matrix. ! implicit none integer, parameter :: rk = kind ( 1.0D+00 ) integer n real ( kind = rk ) a(n,n) integer i a(1:n,1:n) = 0.0D+00 a(1,1) = real ( n + 2, kind = rk ) / real ( 2 * n + 2, kind = rk ) do i = 2, n - 1 a(i,i) = 1.0D+00 end do a(n,n) = real ( n + 2, kind = rk ) / real ( 2 * n + 2, kind = rk ) if ( n == 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 / real ( 2 * n + 2, kind = rk ) a(n,1) = 1.0D+00 / real ( 2 * n + 2, kind = rk ) return end subroutine lights_out_matrix ( row_num, col_num, n, a ) !*****************************************************************************80 ! !! lights_out_matrix() returns the LIGHTS_OUT matrix. ! ! Discussion: ! ! This is the adjacency matrix for a set of points arranged in ! an ROW_NUM by COL_NUM grid, with the addition of a self-edge ! at each node. ! ! Diagram: ! ! ROW_NUM = 4, COL_NUM = 3 ! ! 1---5---9 ! | | | ! 2---6--10 ! | | | ! 3---7--11 ! | | | ! 4---8--12 ! ! Example: ! ! ROW_NUM = 4, COL_NUM = 3 ! ! 1 1 0 0 1 0 0 0 0 0 0 0 ! 1 1 1 0 0 1 0 0 0 0 0 0 ! 0 1 1 1 0 0 1 0 0 0 0 0 ! 0 0 1 1 1 0 0 1 0 0 0 0 ! ! 1 0 0 0 1 1 0 0 1 0 0 0 ! 0 1 0 0 1 1 1 0 0 1 0 0 ! 0 0 1 0 0 1 1 1 0 0 1 0 ! 0 0 0 1 0 0 1 1 0 0 0 1 ! ! 0 0 0 0 1 0 0 0 1 1 0 0 ! 0 0 0 0 0 1 0 0 1 1 1 0 ! 0 0 0 0 0 0 1 0 0 1 1 1 ! 0 0 0 0 0 0 0 1 0 0 1 1 ! ! Discussion: ! ! A game called "Lights Out" comprises a 5 by 5 array of lights. ! Initially, a random subset of the lights are on, and the player's ! task is to turn all the lights off. Pressing any light ! reverses the state of that light and its immediate neighbors to ! the north, south, east and west. ! ! The "Lights Out" matrix summarizes the relationships between ! the lights. We represent any configuration of lights ! by a vector B0 of 1's and 0's. If we want to push light 17, ! say, then we make a vector X which is all zero, except for a ! 1 in entry 17. We multiply this perturbation matrix by A, ! to get the vector, or list, A*X, of all the lights that switch ! their state, and we use this to update B. ! ! In particular, if we agree to do arithmetic modulo 2, then ! the new state B1 can be computed by ! ! B1 = B0 + A*X (mod 2) ! ! Note that if we plan to push 10 buttons, we can calculate the ! final result by computing each change, or we can simply have ! the vector X record all the buttons we are going to push, and ! do the calculation in a single step. ! ! Thus, if we start with all the lights on, and we want to end ! with all the lights off, we are asking for the solubility ! of the system ! ! 1 + A*X = 0 (mod 2) ! ! or, equivalently, ! ! A*X = 1 (mod 2) ! ! Thus, if A has full rank, we can always solve the system, ! but if it has null vectors, there will be some configurations of ! lights that we cannot shut down. ! ! In some versions of the game, "wrap-around" is allowed, so that ! lights on the extreme right boundary can affect lights on the ! extreme left, and similarly for lights at the top and bottom. ! ! Properties: ! ! A is symmetric: A' = A. ! ! Because A is symmetric, it is normal. ! ! Because A is normal, it is diagonalizable. ! ! A is a zero/one matrix. ! ! A is integral, therefore det ( A ) is integral, and ! det ( A ) * inverse ( A ) is integral. ! ! A is block tridiagonal. ! ! A is an adjacency matrix. ! ! For ROW_NUM = COL_NUM, the dimension of the null space of A is: ! ! ROW_NUM N Null ! ! 2 4 0 ! 3 9 0 ! 4 16 4 ! 5 25 2 ! 6 36 0 ! 7 49 0 ! 8 64 0 ! 9 81 8 ! 10 100 0 ! 11 121 6 ! 12 144 0 ! 13 169 0 ! 14 196 4 ! 15 225 0 ! 16 256 8 ! 17 289 2 ! 18 324 0 ! 19 361 16 ! 20 400 0 ! 21 441 0 ! ! Licensing: ! ! This code is distributed under the MIT license. ! ! Modified: ! ! 18 June 2011 ! ! Author: ! ! John Burkardt ! ! Reference: ! ! Marlow Anderson, Todd Feil, ! Turning Lights Out With Linear Algebra, ! Mathematics Magazine, ! Volume 71, Number 4, October 1998, pages 300-303. ! ! Input: ! ! integer ROW_NUM, COL_NUM, the number of rows and ! columns in the underlying array. ! ! integer N, the order of the matrix. ! N = ROW_NUM * COL_NUM. ! ! Output: ! ! real ( kind = rk ) A(N,N), the matrix. ! implicit none integer, parameter :: rk = kind ( 1.0D+00 ) integer n real ( kind = rk ) a(n,n) integer col_num integer i integer i_block integer j integer j_block integer row_num a(1:n,1:n) = 0.0D+00 do j_block = 1, col_num j = ( j_block - 1 ) * row_num + 1 do i_block = 1, col_num i = ( i_block - 1 ) * row_num + 1 if ( j_block == i_block ) then call line_loop_adj_matrix ( row_num, a(i:i+row_num-1,j:j+row_num-1) ) else if ( abs ( j_block - i_block ) == 1 ) then call identity_matrix ( row_num, row_num, a(i:i+row_num-1,j:j+row_num-1) ) else call zero_matrix ( row_num, row_num, a(i:i+row_num-1,j:j+row_num-1) ) end if end do end do return end subroutine line_adj_matrix ( n, a ) !*****************************************************************************80 ! !! line_adj_matrix() returns the line_adj matrix. ! ! Discussion: ! ! The matrix describes the adjacency of points on a line. ! ! Example: ! ! N = 5 ! ! 0 1 0 0 0 ! 1 0 1 0 0 ! 0 1 0 1 0 ! 0 0 1 0 1 ! 0 0 0 1 0 ! ! Properties: ! ! A is symmetric: A' = A. ! ! Because A is symmetric, it is normal. ! ! Because A is normal, it is diagonalizable. ! ! A is tridiagonal. ! ! A is a special case of the TRIS or tridiagonal scalar matrix. ! ! Because A is tridiagonal, it has property A (bipartite). ! ! A is banded, with bandwidth 3. ! ! A is an adjacency matrix for a set of points arranged in a line. ! ! A has a zero diagonal. ! ! A is a zero/one matrix. ! ! The row and column sums are all 2, except for the first and last ! rows and columns which have a sum of 1. ! ! A is singular if N is odd. ! ! det ( A ) = 0, -1, 0, +1, as mod ( N, 4 ) = 1, 2, 3 or 0. ! ! The family of matrices is nested as a function of N. ! ! Licensing: ! ! This code is distributed under the MIT license. ! ! Modified: ! ! 15 October 2007 ! ! Author: ! ! John Burkardt ! ! Input: ! ! integer N, the order of the matrix. ! ! Output: ! ! real ( kind = rk ) A(N,N), the matrix. ! implicit none integer, parameter :: rk = kind ( 1.0D+00 ) integer n real ( kind = rk ) a(n,n) integer i integer j do j = 1, n do i = 1, n if ( j == i - 1 ) then a(i,j) = 1.0D+00 else if ( j == 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 ) !*****************************************************************************80 ! !! line_adj_determinant() returns the determinant of the line_adj matrix. ! ! Licensing: ! ! This code is distributed under the MIT license. ! ! Modified: ! ! 15 October 2007 ! ! Author: ! ! John Burkardt ! ! Input: ! ! integer N, the order of the matrix. ! ! Output: ! ! real ( kind = rk ) DETERM, the determinant. ! implicit none integer, parameter :: rk = kind ( 1.0D+00 ) real ( kind = rk ) determ integer n if ( mod ( n, 4 ) == 1 ) then determ = 0.0D+00 else if ( mod ( n, 4 ) == 2 ) then determ = - 1.0D+00 else if ( mod ( n, 4 ) == 3 ) then determ = 0.0D+00 else if ( mod ( n, 4 ) == 0 ) then determ = + 1.0D+00 end if return end subroutine line_adj_eigen_right ( n, a ) !*****************************************************************************80 ! !! line_adj_eigen_right() returns the right eigenvectors of the BAB matrix. ! ! Discussion: ! ! Note that all symmetric tridiagonal Toeplitz matrices have the ! same eigenvectors. ! ! Licensing: ! ! This code is distributed under the MIT license. ! ! Modified: ! ! 04 April 2015 ! ! Author: ! ! John Burkardt ! ! Input: ! ! integer N, the order of the matrix. ! ! Output: ! ! real ( kind = rk ) A(N,N), the right eigenvector matrix. ! implicit none integer, parameter :: rk = kind ( 1.0D+00 ) integer n real ( kind = rk ) a(n,n) real ( kind = rk ) angle integer i integer j real ( kind = rk ), parameter :: r8_pi = 3.141592653589793D+00 do j = 1, n do i = 1, n angle = real ( i * j, kind = rk ) * r8_pi / real ( n + 1, kind = rk ) a(i,j) = sqrt ( 2.0D+00 / real ( n + 1, kind = rk ) ) * sin ( angle ) end do end do return end subroutine line_adj_eigenvalues ( n, lambda ) !*****************************************************************************80 ! !! line_adj_eigenvalues() returns the eigenvalues of the line_adj matrix. ! ! Licensing: ! ! This code is distributed under the MIT license. ! ! Modified: ! ! 17 October 2007 ! ! Author: ! ! John Burkardt ! ! Input: ! ! integer N, the order of the matrix. ! ! Output: ! ! real ( kind = rk ) LAMBDA(N), the eigenvalues. ! implicit none integer, parameter :: rk = kind ( 1.0D+00 ) integer n real ( kind = rk ) angle integer i real ( kind = rk ) lambda(n) real ( kind = rk ), parameter :: r8_pi = 3.141592653589793D+00 do i = 1, n angle = real ( i, kind = rk ) * r8_pi / real ( n + 1, kind = rk ) lambda(i) = 2.0D+00 * cos ( angle ) end do return end subroutine line_adj_inverse ( n, a ) !*****************************************************************************80 ! !! line_adj_inverse() returns the inverse of the line_adj matrix. ! ! Example: ! ! N = 6: ! ! 0 1 0 -1 0 1 ! 1 0 0 0 0 0 ! 0 0 0 1 0 -1 ! -1 0 1 0 0 0 ! 0 0 0 0 0 1 ! 1 0 -1 0 1 0 ! ! Licensing: ! ! This code is distributed under the MIT license. ! ! Modified: ! ! 17 April 2015 ! ! Author: ! ! John Burkardt ! ! Input: ! ! integer N, the order of the matrix. ! ! Output: ! ! real ( kind = rk ) A(N,N), the matrix. ! implicit none integer, parameter :: rk = kind ( 1.0D+00 ) integer n real ( kind = rk ) a(n,n) integer i integer j real ( kind = rk ) p if ( mod ( n, 2 ) == 1 ) then write ( *, '(a)' ) ' ' write ( *, '(a)' ) 'line_adj_INVERSE - Fatal error!' write ( *, '(a)' ) ' The matrix is singular for odd N.' stop 1 end if a(1:n,1:n) = 0.0D+00 do i = 1, n if ( mod ( i, 2 ) == 1 ) then do j = i, n - 1, 2 if ( j == 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 ) !*****************************************************************************80 ! !! line_adj_null_left() returns a left null vector of the line_adj matrix. ! ! Licensing: ! ! This code is distributed under the MIT license. ! ! Modified: ! ! 13 March 2015 ! ! Author: ! ! John Burkardt ! ! Input: ! ! integer M, N, the order of the matrix. ! ! Output: ! ! real ( kind = rk ) X(M), a null vector ! implicit none integer, parameter :: rk = kind ( 1.0D+00 ) integer m integer n real ( kind = rk ) x(m) call i4_fake_use ( n ) if ( mod ( m, 2 ) == 0 ) then write ( *, '(a)' ) ' ' write ( *, '(a)' ) 'line_adj_NULL_LEFT - Fatal error!' write ( *, '(a)' ) ' For M even, there is no null vector.' stop 1 end if x(1:m:4) = 1.0D+00 x(2:m:2) = 0.0D+00 x(3:m:4) = -1.0D+00 return end subroutine line_adj_null_right ( m, n, x ) !*****************************************************************************80 ! !! line_adj_null_right() returns a right null vector of the line_adj matrix. ! ! Licensing: ! ! This code is distributed under the MIT license. ! ! Modified: ! ! 03 November 2007 ! ! Author: ! ! John Burkardt ! ! Input: ! ! integer M, N, the order of the matrix. ! ! Output: ! ! real ( kind = rk ) X(N), a null vector ! implicit none integer, parameter :: rk = kind ( 1.0D+00 ) integer m integer n real ( kind = rk ) x(n) call i4_fake_use ( m ) if ( mod ( n, 2 ) == 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 x(1:n:4) = 1.0D+00 x(2:n:2) = 0.0D+00 x(3:n:4) = -1.0D+00 return end subroutine line_loop_adj_matrix ( n, a ) !*****************************************************************************80 ! !! line_loop_adj_matrix() returns the LINE_LOOP_ADJ matrix. ! ! Discussion: ! ! The matrix describes the adjacency of points on a loop. ! ! Example: ! ! N = 5 ! ! 1 1 0 0 0 ! 1 1 1 0 0 ! 0 1 1 1 0 ! 0 0 1 1 1 ! 0 0 0 1 1 ! ! Properties: ! ! A is symmetric: A' = A. ! ! Because A is symmetric, it is normal. ! ! Because A is normal, it is diagonalizable. ! ! A is tridiagonal. ! ! A is a special case of the TRIS or tridiagonal scalar matrix. ! ! Because A is tridiagonal, it has property A (bipartite). ! ! A is banded, with bandwidth 3. ! ! A is an adjacency matrix for a set of points arranged in a line. ! ! A is a zero/one matrix. ! ! The row and column sums are all 3, except for the first and last ! rows and columns which have a sum of 2. ! ! The family of matrices is nested as a function of N. ! ! Licensing: ! ! This code is distributed under the MIT license. ! ! Modified: ! ! 06 July 2000 ! ! Author: ! ! John Burkardt ! ! Input: ! ! integer N, the order of the matrix. ! ! Output: ! ! real ( kind = rk ) A(N,N), the matrix. ! implicit none integer, parameter :: rk = kind ( 1.0D+00 ) integer n real ( kind = rk ) a(n,n) integer i integer j do j = 1, n do i = 1, n if ( j == i - 1 ) then a(i,j) = 1.0D+00 else if ( j == i ) then a(i,j) = 1.0D+00 else if ( j == 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 ) !*****************************************************************************80 ! !! line_loop_adj_determinant() returns the determinant of the LINE_LOOP_ADJ matrix. ! ! Licensing: ! ! This code is distributed under the MIT license. ! ! Modified: ! ! 25 October 2007 ! ! Author: ! ! John Burkardt ! ! Input: ! ! integer N, the order of the matrix. ! ! Output: ! ! real ( kind = rk ) DETERM, the determinant. ! implicit none integer, parameter :: rk = kind ( 1.0D+00 ) integer n real ( kind = rk ) angle real ( kind = rk ) determ integer i real ( kind = rk ), parameter :: r8_pi = 3.141592653589793D+00 if ( mod ( n, 2 ) == 1 ) then determ = 0.0D+00 else determ = 1.0D+00 do i = 1, n angle = real ( i, kind = rk ) * r8_pi / real ( n + 1, kind = rk ) determ = determ * ( 1.0D+00 + 2.0D+00 * cos ( angle ) ) end do end if return end subroutine line_loop_adj_eigen_right ( n, a ) !*****************************************************************************80 ! !! line_loop_adj_eigen_right() returns the right eigenvectors of the BAB matrix. ! ! Discussion: ! ! Note that all symmetric tridiagonal Toeplitz matrices have the ! same eigenvectors. ! ! Licensing: ! ! This code is distributed under the MIT license. ! ! Modified: ! ! 04 April 2015 ! ! Author: ! ! John Burkardt ! ! Input: ! ! integer N, the order of the matrix. ! ! Output: ! ! real ( kind = rk ) A(N,N), the right eigenvector matrix. ! implicit none integer, parameter :: rk = kind ( 1.0D+00 ) integer n real ( kind = rk ) a(n,n) real ( kind = rk ) angle integer i integer j real ( kind = rk ), parameter :: r8_pi = 3.141592653589793D+00 do j = 1, n do i = 1, n angle = real ( i * j, kind = rk ) * r8_pi / real ( n + 1, kind = rk ) a(i,j) = sqrt ( 2.0D+00 / real ( n + 1, kind = rk ) ) * sin ( angle ) end do end do return end subroutine line_loop_adj_eigenvalues ( n, lambda ) !*****************************************************************************80 ! !! line_loop_adj_eigenvalues() returns the eigenvalues of the LINE_LOOP_ADJ matrix. ! ! Licensing: ! ! This code is distributed under the MIT license. ! ! Modified: ! ! 17 October 2007 ! ! Author: ! ! John Burkardt ! ! Input: ! ! integer N, the order of the matrix. ! ! Output: ! ! real ( kind = rk ) LAMBDA(N), the eigenvalues. ! implicit none integer, parameter :: rk = kind ( 1.0D+00 ) integer n real ( kind = rk ) angle integer i real ( kind = rk ) lambda(n) real ( kind = rk ), parameter :: r8_pi = 3.141592653589793D+00 do i = 1, n angle = real ( i, kind = rk ) * r8_pi / real ( n + 1, kind = rk ) lambda(i) = 1.0D+00 + 2.0D+00 * cos ( angle ) end do return end subroutine loewner_matrix ( w, x, y, z, n, a ) !*****************************************************************************80 ! !! loewner_matrix() returns the LOEWNER matrix. ! ! Formula: ! ! A(I,J) = ( W(I) - X(J) ) / ( Y(I) - Z(J) ) ! ! Example: ! ! N = 3 ! W = (/ 8, 4, 9 /) ! X = (/ 1, 2, 3 /) ! Y = (/ 9, 6, 4 /) ! Z = (/ 2, 3, 1 /) ! ! A = ! ! 8 - 1 8 - 2 8 - 3 ! ----- ----- ----- ! 9 - 2 9 - 3 9 - 1 ! ! 4 - 1 4 - 2 4 - 3 ! ----- ----- ----- ! 6 - 2 6 - 3 6 - 1 ! ! 9 - 1 9 - 2 9 - 3 ! ----- ----- ----- ! 4 - 2 4 - 3 4 - 1 ! ! = ! ! 7/7 6/6 5/8 ! ! 3/4 2/3 1/5 ! ! 8/2 7/1 6/3 ! ! Properties: ! ! A is generally not symmetric: A' /= A. ! ! The family of matrices is nested as a function of N. ! ! Licensing: ! ! This code is distributed under the MIT license. ! ! Modified: ! ! 04 March 2001 ! ! Author: ! ! John Burkardt ! ! Input: ! ! real ( kind = rk ) W(N), X(N), Y(N), Z(N), vectors defining ! the matrix. ! ! integer N, the order of the matrix. ! ! Output: ! ! real ( kind = rk ) A(N,N), the matrix. ! implicit none integer, parameter :: rk = kind ( 1.0D+00 ) integer n real ( kind = rk ) a(n,n) integer i integer j real ( kind = rk ) w(n) real ( kind = rk ) x(n) real ( kind = rk ) y(n) real ( kind = rk ) z(n) do j = 1, n do i = 1, n if ( y(i) - z(j) == 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_matrix ( m, n, a ) !*****************************************************************************80 ! !! lotkin_matrix() returns the LOTKIN matrix. ! ! Formula: ! ! if ( I = 1 ) ! A(I,J) = 1 ! else ! A(I,J) = 1 / ( I + J - 1 ) ! ! Example: ! ! N = 5 ! ! 1 1 1 1 1 ! 1/2 1/3 1/4 1/5 1/6 ! 1/3 1/4 1/5 1/6 1/7 ! 1/4 1/5 1/6 1/7 1/8 ! 1/5 1/6 1/7 1/8 1/9 ! ! Properties: ! ! A is the Hilbert matrix with the first row set to all 1's. ! ! A is generally not symmetric: A' /= A. ! ! A is ill-conditioned. ! ! A has many negative eigenvalues of small magnitude. ! ! The inverse of A has all integer elements, and is known explicitly. ! ! For N = 6, the eigenvalues are: ! 2.132376, ! -0.2214068, ! -0.3184330E-01, ! -0.8983233E-03, ! -0.1706278E-04, ! -0.1394499E-06. ! ! det ( A(N) ) = ( -1 )^(N-1) / DELTA(N) ! ! where ! ! DELTA(N) = CHOOSE ( 2*N-2, N-2 ) * CHOOSE ( 2*N-2, N-1 ) ! * ( 2*N-1) * DELTA(N-1), ! DELTA(1) = 1. ! ! The family of matrices is nested as a function of N. ! ! Licensing: ! ! This code is distributed under the MIT license. ! ! Modified: ! ! 15 April 1999 ! ! Author: ! ! John Burkardt ! ! Reference: ! ! Robert Gregory, David Karney, ! A Collection of Matrices for Testing Computational Algorithms, ! Wiley, 1969, ! ISBN: 0882756494, ! LC: QA263.G68. ! ! Max Lotkin, ! A set of test matrices, ! Mathematics Tables and Other Aids to Computation, ! Volume 9, 1955, pages 153-161. ! ! Joan Westlake, ! A Handbook of Numerical Matrix Inversion and Solution of ! Linear Equations, ! John Wiley, 1968, ! ISBN13: 978-0471936756, ! LC: QA263.W47. ! ! Input: ! ! integer M, N, the order of the matrix. ! ! Output: ! ! real ( kind = rk ) A(M,N), the matrix. ! implicit none integer, parameter :: rk = kind ( 1.0D+00 ) integer m integer n real ( kind = rk ) a(m,n) integer i integer j do j = 1, n do i = 1, m if ( i == 1 ) then a(i,j) = 1.0D+00 else a(i,j) = 1.0D+00 / real ( i + j - 1, kind = rk ) end if end do end do return end subroutine lotkin_determinant ( n, determ ) !*****************************************************************************80 ! !! lotkin_determinant() returns the determinant of the LOTKIN matrix. ! ! Licensing: ! ! This code is distributed under the MIT license. ! ! Modified: ! ! 02 June 2008 ! ! Author: ! ! John Burkardt ! ! Input: ! ! integer N, the order of the matrix. ! ! Output: ! ! real ( kind = rk ) DETERM, the determinant. ! implicit none integer, parameter :: rk = kind ( 1.0D+00 ) integer n real ( kind = rk ) delta real ( kind = rk ) determ integer i real ( kind = rk ) 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 ) !*****************************************************************************80 ! !! lotkin_inverse() returns the inverse of the LOTKIN matrix. ! ! Example: ! ! N = 5 ! ! 5 300 -2100 4200 -2520 ! -60 -2400 18900 -40320 25200 ! 210 6300 -52920 117600 -75600 ! -280 -6720 58800 -134400 88200 ! 126 2520 -22680 52920 -35280 ! ! Licensing: ! ! This code is distributed under the MIT license. ! ! Modified: ! ! 02 June 2008 ! ! Author: ! ! John Burkardt ! ! Input: ! ! integer N, the order of the matrix. ! ! Output: ! ! real ( kind = rk ) A(N,N), the matrix. ! implicit none integer, parameter :: rk = kind ( 1.0D+00 ) integer n real ( kind = rk ) a(n,n) integer i integer j real ( kind = rk ) r8_choose real ( kind = rk ) r8_mop do j = 1, n do i = 1, n if ( j == 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 ) * real ( i, kind = rk ) & * 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_matrix ( n, a ) !*****************************************************************************80 ! !! magic_matrix() returns a MAGIC matrix. ! ! Discussion: ! ! The entries of A are the integers from 1 to N*N, each occurring once. ! The sum of the entries along any row or column, the diagonal, or the ! antidiagonal is always equal to N*(N*N+1)/2. ! ! The algorithms used are derived from ACM algorithms 117 and 118, ! which in turn are derived from Kraitchik. ! ! There is no 2 by 2 magic square. ! ! Example: ! ! N = 3 ! ! 8 3 4 ! 1 5 9 ! 6 7 2 ! ! Properties: ! ! A is generally not symmetric: A' /= A. ! ! A is integral, therefore det ( A ) is integral, and ! det ( A ) * inverse ( A ) is integral. ! ! A is a multiple of a doubly stochastic matrix. ! ! Because it has a constant row sum of N*(N*N+1)/2, ! A has an eigenvalue of N*(N*N+1)/2. ! and a right eigenvector of ( 1, 1, 1, ..., 1 ). ! ! Because it has a constant column sum of N*(N*N+1)/2, ! A has an eigenvalue of N*(N*N+1)/2. ! and a left eigenvector of ( 1, 1, 1, ..., 1 ). ! ! A is singular when N is even. This is because A is a "regular" ! magic square, for which A(i,j) + A(n-i+1,n-j+1) = n^2+1. ! ! Licensing: ! ! This code is distributed under the MIT license. ! ! Modified: ! ! 15 April 1999 ! ! Author: ! ! Original FORTRAN77 version by David Collison. ! FORTRAN90 version by John Burkardt. ! ! Reference: ! ! David Collison, ! Algorithms 117 and 118: ! Magic square (even order) and Magic square (odd order), ! Communications of the ACM, ! Volume 5, Number 8, pages 435-436. ! ! Maurice Kraitchik, ! Mathematical Recreations, ! Norton, 1942, pages 149-152. ! ! Input: ! ! integer N, the order of the matrix. N must not be 2. ! ! Output: ! ! real ( kind = rk ) A(N,N), the matrix. ! implicit none integer, parameter :: rk = kind ( 1.0D+00 ) integer n real ( kind = rk ) a(n,n) if ( n <= 0 ) then write ( *, '(a)' ) ' ' write ( *, '(a)' ) 'MAGIC - Fatal error!' write ( *, '(a,i8)' ) ' Nonpositive value of N = ', n stop 1 else if ( n == 1 ) then a(1,1) = 1.0D+00 else if ( n == 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 ) == 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 ) !*****************************************************************************80 ! !! magic_a() is a utility routine for magic square computations. ! ! Licensing: ! ! This code is distributed under the MIT license. ! ! Modified: ! ! 15 April 1999 ! ! Author: ! ! Original FORTRAN77 version by David Collison. ! FORTRAN90 version by John Burkardt. ! ! Reference: ! ! David Collison, ! Algorithms 117 and 118: ! Magic square (even order) and Magic square (odd order), ! Communications of the ACM, ! Volume 5, Number 8, pages 435-436. ! ! Input: ! ! integer N, the order of the matrix. N must not be 2. ! ! real ( kind = rk ) A(N,N), ... ! ! integer I, ? ! ! integer J, ? ! ! integer K, ? ! ! logical BOOL, ? ! ! Output: ! ! real ( kind = rk ) A(N,N), ... ! implicit none integer, parameter :: rk = kind ( 1.0D+00 ) integer n real ( kind = rk ) 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 ) !*****************************************************************************80 ! !! magic_b() is a utility routine for magic square computations. ! ! Licensing: ! ! This code is distributed under the MIT license. ! ! Modified: ! ! 15 April 1999 ! ! Author: ! ! Original FORTRAN77 version by David Collison. ! FORTRAN90 version by John Burkardt. ! ! Reference: ! ! David Collison, ! Algorithms 117 and 118: ! Magic square (even order) and Magic square (odd order), ! Communications of the ACM, ! Volume 5, Number 8, pages 435-436. ! ! Input: ! ! integer N, the order of the matrix. N must not be 2. ! ! real ( kind = rk ) A(N,N), ... ! ! integer I, ? ! ! integer J, ? ! ! integer K, ? ! ! logical BOOL, ? ! ! Output: ! ! real ( kind = rk ) A(N,N), ... ! implicit none integer, parameter :: rk = kind ( 1.0D+00 ) integer n real ( kind = rk ) 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 ) !*****************************************************************************80 ! !! magic_bimarkov() returns a magic biMarkov matrix. ! ! Discussion: ! ! The matrix returned will be magic (row sums = column sums = diagonal ! sums) and biMarkov ( row sums = 1, column sums = 1 ). ! ! There is no 2 by 2 magic square. ! ! Example: ! ! N = 3 ! ! 8/15 3/15 4/15 ! 1/15 5/15 9/15 ! 6/15 7/15 2/15 ! ! Properties: ! ! A is generally not symmetric: A' /= A. ! ! A is magic. ! ! A is biMarkov. ! ! A is positive. ! ! Licensing: ! ! This code is distributed under the MIT license. ! ! Modified: ! ! 24 May 2002 ! ! Author: ! ! John Burkardt ! ! Input: ! ! integer N, the order of the matrix. N must not be 2. ! ! Output: ! ! real ( kind = rk ) A(N,N), the matrix. ! implicit none integer, parameter :: rk = kind ( 1.0D+00 ) integer n real ( kind = rk ) a(n,n) real ( kind = rk ) rsum if ( n <= 0 ) then write ( *, '(a)' ) ' ' write ( *, '(a)' ) 'MAGIC_BIMARKOV - Fatal error!' write ( *, '(a,i8)' ) ' Nonpositive value of N = ', n stop 1 else if ( n == 1 ) then a(1,1) = 1.0D+00 else if ( n == 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_matrix ( n, a ) rsum = sum ( a(1:n,1) ) a(1:n,1:n) = a(1:n,1:n) / rsum end if return end subroutine magic_c ( n, a, i, j, k, bool ) !*****************************************************************************80 ! !! magic_c() is a utility routine for magic square computations. ! ! Licensing: ! ! This code is distributed under the MIT license. ! ! Modified: ! ! 15 April 1999 ! ! Author: ! ! Original FORTRAN77 version by David Collison. ! FORTRAN90 version by John Burkardt ! ! Reference: ! ! David Collison, ! Algorithms 117 and 118: ! Magic square (even order) and Magic square (odd order), ! Communications of the ACM, ! Volume 5, Number 8, pages 435-436. ! ! Input: ! ! integer N, the order of the matrix. N must not be 2. ! ! real ( kind = rk ) A(N,N), ... ! ! integer I, ? ! ! integer J, ? ! ! integer K, ? ! ! logical BOOL, ? ! ! Output: ! ! real ( kind = rk ) A(N,N), ... ! implicit none integer, parameter :: rk = kind ( 1.0D+00 ) integer n real ( kind = rk ) 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 ) !*****************************************************************************80 ! !! magic_even() constructs a magic square for the case where N is even. ! ! Licensing: ! ! This code is distributed under the MIT license. ! ! Modified: ! ! 15 April 1999 ! ! Author: ! ! Original FORTRAN77 version by David Collison. ! FORTRAN90 version by John Burkardt ! ! Reference: ! ! David Collison, ! Algorithms 117 and 118: ! Magic square (even order) and Magic square (odd order), ! Communications of the ACM, ! Volume 5, Number 8, pages 435-436. ! ! Input: ! ! integer N, the order of the matrix. N must not be 2. ! ! Output: ! ! real ( kind = rk ) A(N,N), the matrix. ! implicit none integer, parameter :: rk = kind ( 1.0D+00 ) integer n real ( kind = rk ) 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 ) == 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 ) !*****************************************************************************80 ! !! magic_odd() constructs a magic square for the case where N is odd. ! ! Licensing: ! ! This code is distributed under the MIT license. ! ! Modified: ! ! 15 April 1999 ! ! Author: ! ! Original FORTRAN77 version by David Collison. ! FORTRAN90 version by John Burkardt ! ! Reference: ! ! David Collison, ! Algorithms 117 and 118: ! Magic square (even order) and Magic square (odd order), ! Communications of the ACM, ! Volume 5, Number 8, pages 435-436. ! ! Input: ! ! integer N, the order of the matrix. N must not be 2. ! ! Output: ! ! real ( kind = rk ) A(N,N), the matrix. ! implicit none integer, parameter :: rk = kind ( 1.0D+00 ) integer n real ( kind = rk ) a(n,n) integer i integer j integer k a(1:n,1:n) = 0.0D+00 i = ( n + 1 ) / 2 j = n do k = 1, n * n if ( a(i,j) /= 0.0D+00 ) then i = i - 1 if ( i < 1 ) then i = i + n end if j = j - 2 if ( j < 1 ) then j = j + n end if end if a(i,j) = real ( k, kind = rk ) i = i + 1 if ( n < i ) then i = i - n end if j = j + 1 if ( n < j ) then j = j - n end if end do return end subroutine markov_random_matrix ( n, seed, a ) !*****************************************************************************80 ! !! markov_random_matrix() returns the MARKOV_RANDOM matrix. ! ! Discussion: ! ! A Markov matrix, also called a "stochastic" matrix, is distinguished ! by two properties: ! ! * All matrix entries are nonnegative; ! * The sum of the entries in each row is 1. ! ! A "transition matrix" is the transpose of a Markov matrix, and ! has column sums equal to 1. ! ! Example: ! ! N = 4 ! ! 1/10 2/10 3/10 4/10 ! 1 0 0 0 ! 5/10 2/10 3/10 0 ! 2/10 2/10 2/10 4/10 ! ! Properties: ! ! A is generally not symmetric: A' /= A. ! ! 0 <= A(I,J) <= 1.0D+00 for every I and J. ! ! The sum of the entries in each row of A is 1. ! ! Because it has a constant row sum of 1, ! A has an eigenvalue of 1, and ! a right eigenvector of ( 1, 1, 1, ..., 1 ). ! ! All the eigenvalues of A have modulus no greater than 1. ! ! The eigenvalue 1 lies on the boundary of all the Gerschgorin rowsum disks. ! ! Licensing: ! ! This code is distributed under the MIT license. ! ! Modified: ! ! 05 December 1998 ! ! Author: ! ! John Burkardt ! ! Input: ! ! integer N, the order of the matrix. ! ! integer SEED, a seed for the random number generator. ! ! Output: ! ! real ( kind = rk ) A(N,N), the matrix. ! ! integer SEED, an updated seed. ! implicit none integer, parameter :: rk = kind ( 1.0D+00 ) integer n real ( kind = rk ) a(n,n) integer i real ( kind = rk ) row_sum integer seed call r8mat_uniform_01 ( n, n, seed, a ) do i = 1, n row_sum = sum ( a(i,1:n) ) a(i,1:n) = a(i,1:n) / row_sum end do return end subroutine maxij_matrix ( m, n, a ) !*****************************************************************************80 ! !! maxij_matrix() returns the MAXIJ matrix. ! ! Discussion: ! ! This matrix is occasionally known as the "Boothroyd MAX" matrix. ! ! Formula: ! ! A(I,J) = max(I,J) ! ! Example: ! ! N = 5 ! ! 1 2 3 4 5 ! 2 2 3 4 5 ! 3 3 3 4 5 ! 4 4 4 4 5 ! 5 5 5 5 5 ! ! Properties: ! ! A is integral, therefore det ( A ) is integral, and ! det ( A ) * inverse ( A ) is integral. ! ! A is symmetric: A' = A. ! ! Because A is symmetric, it is normal. ! ! Because A is normal, it is diagonalizable. ! ! The inverse of A is tridiagonal. ! ! The matrix A is not positive definite. ! ! The family of matrices is nested as a function of N. ! ! Licensing: ! ! This code is distributed under the MIT license. ! ! Modified: ! ! 15 April 1999 ! ! Author: ! ! John Burkardt ! ! Reference: ! ! Robert Gregory, David Karney, ! A Collection of Matrices for Testing Computational Algorithms, ! Wiley, 1969, ! ISBN: 0882756494, ! LC: QA263.G68. ! ! Input: ! ! integer M, N, the order of the matrix. ! ! Output: ! ! real ( kind = rk ) A(M,N), the matrix. ! implicit none integer, parameter :: rk = kind ( 1.0D+00 ) integer m integer n real ( kind = rk ) a(m,n) integer i integer j do i = 1, m do j = 1, n a(i,j) = real ( max ( i, j ), kind = rk ) end do end do return end subroutine maxij_condition ( n, cond ) !*****************************************************************************80 ! !! maxij_condition() returns the L1 condition of the MAXIJ matrix. ! ! Licensing: ! ! This code is distributed under the MIT license. ! ! Modified: ! ! 26 January 2015 ! ! Author: ! ! John Burkardt ! ! Input: ! ! integer N, the order of the matrix. ! ! Output: ! ! real ( kind = rk ) COND, the L1 condition. ! implicit none integer, parameter :: rk = kind ( 1.0D+00 ) real ( kind = rk ) a_norm real ( kind = rk ) b_norm real ( kind = rk ) cond integer n a_norm = real ( n * n, kind = rk ) if ( n == 1 ) then b_norm = 1.0D+00 else if ( n == 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, value ) !*****************************************************************************80 ! !! maxij_determinant() returns the determinant of the MAXIJ matrix. ! ! Licensing: ! ! This code is distributed under the MIT license. ! ! Modified: ! ! 23 October 2007 ! ! Author: ! ! John Burkardt ! ! Input: ! ! integer N, the order of the matrix. ! ! Output: ! ! real ( kind = rk ) VALUE, the determinant. ! implicit none integer, parameter :: rk = kind ( 1.0D+00 ) integer n real ( kind = rk ) value value = real ( n, kind = rk ) return end subroutine maxij_inverse ( n, a ) !*****************************************************************************80 ! !! maxij_inverse() returns the inverse of the MAXIJ matrix. ! ! Formula: ! ! if ( I = 1 and J = 1 ) ! A(I,J) = -1 ! else if ( I = N and J = N ) ! A(I,J) = -(N-1)/N ! else if ( I = J ) ! A(I,J) = -2 ! else if ( J = I-1 or J = I + 1 ) ! A(I,J) = 1 ! else ! A(I,J) = 0 ! ! Example: ! ! N = 5 ! ! -1 1 0 0 0 ! 1 -2 1 0 0 ! 0 1 -2 1 0 ! 0 0 1 -2 1 ! 0 0 0 1 -4/5 ! ! Properties: ! ! A is symmetric: A' = A. ! ! Because A is symmetric, it is normal. ! ! Because A is normal, it is diagonalizable. ! ! A is tridiagonal. ! ! Because A is tridiagonal, it has property A (bipartite). ! ! A is "almost" equal to the second difference matrix. ! ! Licensing: ! ! This code is distributed under the MIT license. ! ! Modified: ! ! 15 April 1999 ! ! Author: ! ! John Burkardt ! ! Input: ! ! integer N, the order of the matrix. ! ! Output: ! ! real ( kind = rk ) A(N,N), the matrix. ! implicit none integer, parameter :: rk = kind ( 1.0D+00 ) integer n real ( kind = rk ) a(n,n) integer i integer j do i = 1, n do j = 1, n if ( j == i ) then if ( i == 1 ) then a(i,j) = - 1.0D+00 else if ( i < n ) then a(i,j) = - 2.0D+00 else a(i,j) = - real ( n - 1, kind = rk ) / real ( n, kind = rk ) end if else if ( j == i - 1 .or. j == 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 ) !*****************************************************************************80 ! !! maxij_plu() returns the PLU factors of the MAXIJ matrix. ! ! Licensing: ! ! This code is distributed under the MIT license. ! ! Modified: ! ! 26 June 2011 ! ! Author: ! ! John Burkardt ! ! Input: ! ! integer N, the order of the matrix. ! ! Output: ! ! real ( kind = rk ) P(N,N), L(N,N), U(N,N), the PLU factors. ! implicit none integer, parameter :: rk = kind ( 1.0D+00 ) integer n integer i integer i4_wrap integer j real ( kind = rk ) l(n,n) real ( kind = rk ) p(n,n) real ( kind = rk ) u(n,n) do j = 1, n do i = 1, n if ( i4_wrap ( j - i, 1, n ) == 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) = real ( i - 1, kind = rk ) / real ( n, kind = rk ) 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) = real ( n, kind = rk ) 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) = real ( j + 1 - i, kind = rk ) end do end do return end function mertens ( n ) !*****************************************************************************80 ! !! mertens() evaluates the Mertens function. ! ! Discussion: ! ! The Mertens function M(N) is the sum from 1 to N of the Moebius ! function MU. That is, ! ! M(N) = sum ( 1 <= I <= N ) MU(I) ! ! N M(N) ! -- ---- ! 1 1 ! 2 0 ! 3 -1 ! 4 -1 ! 5 -2 ! 6 -1 ! 7 -2 ! 8 -2 ! 9 -2 ! 10 -1 ! 11 -2 ! 12 -2 ! 100 1 ! 1000 2 ! 10000 -23 ! 100000 -48 ! ! The determinant of the Redheffer matrix of order N is equal ! to the Mertens function M(N). ! ! Licensing: ! ! This code is distributed under the MIT license. ! ! Modified: ! ! 16 October 2007 ! ! Author: ! ! John Burkardt ! ! Reference: ! ! M Deleglise, J Rivat, ! Computing the Summation of the Moebius Function, ! Experimental Mathematics, ! Volume 5, 1996, pages 291-295. ! ! Eric Weisstein, ! CRC Concise Encyclopedia of Mathematics, ! CRC Press, 2002, ! Second edition, ! ISBN: 1584883472, ! LC: QA5.W45 ! ! Input: ! ! integer N, the argument. ! ! Output: ! ! integer MERTENS, the value. ! implicit none integer, parameter :: rk = kind ( 1.0D+00 ) 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 ) !*****************************************************************************80 ! !! mertens_values() returns some values of the Mertens function. ! ! Discussion: ! ! The Mertens function M(N) is the sum from 1 to N of the Moebius ! function MU. ! ! Licensing: ! ! This code is distributed under the MIT license. ! ! Modified: ! ! 17 October 2007 ! ! Author: ! ! John Burkardt ! ! Reference: ! ! Marc Deleglise, Joel Rivat, ! Computing the Summation of the Moebius Function, ! Experimental Mathematics, ! Volume 5, 1996, pages 291-295. ! ! Eric Weisstein, ! CRC Concise Encyclopedia of Mathematics, ! CRC Press, 2002, ! Second edition, ! ISBN: 1584883472, ! LC: QA5.W45. ! ! Input: ! ! integer N_DATA, on first call, the user sets N_DATA to 0. ! ! Output: ! ! integer N_DATA, the input value of N_DATA is ! incremented and that test data item is returned, if available. When ! there is no more test data, N_DATA is set to 0. ! ! integer N, the argument of the Mertens function. ! ! integer C, the value of the Mertens function. ! implicit none integer, parameter :: rk = kind ( 1.0D+00 ) integer, parameter :: nmax = 15 integer c integer, save, dimension ( nmax ) :: c_vec = (/ & 1, 0, -1, -1, -2, -1, -2, -2, -2, -1, & -2, -2, 1, 2, -23 /) integer n integer n_data integer, save, dimension ( nmax ) :: n_vec = (/ & 1, 2, 3, 4, 5, 6, 7, 8, 9, 10, & 11, 12, 100, 1000, 10000 /) if ( n_data < 0 ) then n_data = 0 end if n_data = n_data + 1 if ( nmax < 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_matrix ( m, n, x, a ) !*****************************************************************************80 ! !! milnes_matrix() returns the MILNES matrix. ! ! Formula: ! ! If ( I <= J ) ! A(I,J) = 1 ! else ! A(I,J) = X(J) ! ! Example: ! ! M = 5, N = 5, X = ( 4, 7, 3, 8 ) ! ! 1 1 1 1 1 ! 4 1 1 1 1 ! 4 7 1 1 1 ! 4 7 3 1 1 ! 4 7 3 8 1 ! ! M = 3, N = 6, X = ( 5, 7 ) ! ! 1 1 1 1 1 ! 5 1 1 1 1 ! 5 7 1 1 1 ! ! M = 5, N = 3, X = ( 5, 7, 8 ) ! ! 1 1 1 ! 5 1 1 ! 5 7 1 ! 5 7 8 ! 5 7 8 ! ! Properties: ! ! A is generally not symmetric: A' /= A. ! ! det ( A ) = ( 1 - X(1) ) * ( 1 - X(2) ) * ... * ( 1 - X(N-1) ). ! ! A is singular if and only if X(I) = 1 for any I. ! ! The family of matrices is nested as a function of N. ! ! Licensing: ! ! This code is distributed under the MIT license. ! ! Modified: ! ! 13 July 2000 ! ! Author: ! ! John Burkardt ! ! Reference: ! ! Robert Gregory, David Karney, ! A Collection of Matrices for Testing Computational Algorithms, ! Wiley, 1969, ! ISBN: 0882756494, ! LC: QA263.G68. ! ! Input: ! ! integer M, N, the order of the matrix. ! ! real ( kind = rk ) X(*), the lower column values. ! If M <= N, then X should be dimensioned M-1. ! If N < M, X should be dimensioned N. ! ! Output: ! ! real ( kind = rk ) A(M,N), the matrix. ! implicit none integer, parameter :: rk = kind ( 1.0D+00 ) integer m integer n real ( kind = rk ) a(m,n) integer i integer j real ( kind = rk ) x(*) do i = 1, m do j = 1, n if ( i <= 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 ) !*****************************************************************************80 ! !! milnes_determinant() returns the determinant of the MILNES matrix. ! ! Licensing: ! ! This code is distributed under the MIT license. ! ! Modified: ! ! 21 May 2002 ! ! Author: ! ! John Burkardt ! ! Input: ! ! integer N, the order of the matrix. ! ! real ( kind = rk ) X(N-1), the lower column values. ! ! Output: ! ! real ( kind = rk ) DETERM, the determinant. ! implicit none integer, parameter :: rk = kind ( 1.0D+00 ) integer n real ( kind = rk ) determ real ( kind = rk ) x(n-1) if ( n == 1 ) then determ = 1.0D+00 else determ = product ( 1.0D+00 - x(1:n-1) ) end if return end subroutine milnes_inverse ( n, x, a ) !*****************************************************************************80 ! !! milnes_inverse() returns the inverse of the MILNES matrix. ! ! Licensing: ! ! This code is distributed under the MIT license. ! ! Modified: ! ! 15 April 1999 ! ! Author: ! ! John Burkardt ! ! Reference: ! ! Robert Gregory, David Karney, ! A Collection of Matrices for Testing Computational Algorithms, ! Wiley, 1969, ! ISBN: 0882756494, ! LC: QA263.G68. ! ! Input: ! ! integer N, the order of the matrix. ! ! real ( kind = rk ) X(N-1), the lower column values. ! ! Output: ! ! real ( kind = rk ) A(N,N), the matrix. ! implicit none integer, parameter :: rk = kind ( 1.0D+00 ) integer n real ( kind = rk ) a(n,n) integer i integer j real ( kind = rk ) x(n-1) do i = 1, n do j = 1, n if ( i == j .and. i /= n ) then a(i,j) = 1.0D+00 / ( 1.0D+00 - x(i) ) else if ( j == i + 1 .and. i /= n ) then a(i,j) = - 1.0D+00 / ( 1.0D+00 - x(i) ) else if ( i == n .and. j /= 1 .and. j /= n ) then a(i,j) = ( x(j-1) - x(j) ) / & ( ( 1.0D+00 - x(j) ) * ( 1.0D+00 - x(j-1) ) ) else if ( i == n .and. j == 1 ) then a(i,j) = -x(1) / ( 1.0D+00 - x(1) ) else if ( i == n .and. j == 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_matrix ( m, n, a ) !*****************************************************************************80 ! !! minij_matrix() returns the MINIJ matrix. ! ! Discussion: ! ! See page 158 of the Todd reference. ! ! Formula: ! ! A(I,J) = min ( I, J ) ! ! Example: ! ! N = 5 ! ! 1 1 1 1 1 ! 1 2 2 2 2 ! 1 2 3 3 3 ! 1 2 3 4 4 ! 1 2 3 4 5 ! ! Properties: ! ! A is integral, therefore det ( A ) is integral, and ! det ( A ) * inverse ( A ) is integral. ! ! A is positive definite. ! ! A is symmetric: A' = A. ! ! Because A is symmetric, it is normal. ! ! Because A is normal, it is diagonalizable. ! ! The inverse of A is tridiagonal. ! ! The eigenvalues of A are ! ! LAMBDA(I) = 0.5 / ( 1 - cos ( ( 2 * I - 1 ) * pi / ( 2 * N + 1 ) ) ), ! ! For N = 12, the characteristic polynomial is ! P(X) = X^12 - 78 X^11 + 1001 X^10 - 5005 X^9 + 12870 X^8 ! - 19448 X^7 + 18564 X^6 - 11628 X^5 + 4845 X^4 - 1330 X^3 ! + 231 X^2 - 23 X + 1. ! ! (N+1)*ONES(N) - A also has a tridiagonal inverse. ! ! Gregory and Karney consider the matrix defined by ! ! B(I,J) = N + 1 - MAX(I,J) ! ! which is equal to the MINIJ matrix, but with the rows and ! columns reversed. ! ! The family of matrices is nested as a function of N. ! ! Licensing: ! ! This code is distributed under the MIT license. ! ! Modified: ! ! 15 April 1999 ! ! Author: ! ! John Burkardt ! ! Reference: ! ! Robert Gregory, David Karney, ! A Collection of Matrices for Testing Computational Algorithms, ! Wiley, 1969, ! ISBN: 0882756494, ! LC: QA263.G68. ! ! Daniel Rutherford, ! Some continuant determinants arising in physics and chemistry II, ! Proceedings of the Royal Society Edinburgh, ! Volume 63, A, 1952, pages 232-241. ! ! John Todd, ! Basic Numerical Mathematics, ! Volume 2: Numerical Algebra, ! Birkhauser, 1980, ! ISBN: 0817608117, ! LC: QA297.T58. ! ! Joan Westlake, ! A Handbook of Numerical Matrix Inversion and Solution of ! Linear Equations, ! John Wiley, 1968, ! ISBN13: 978-0471936756, ! LC: QA263.W47. ! ! Input: ! ! integer M, N, the order of the matrix. ! ! Output: ! ! real ( kind = rk ) A(M,N), the matrix. ! implicit none integer, parameter :: rk = kind ( 1.0D+00 ) integer m integer n real ( kind = rk ) a(m,n) integer i integer j do i = 1, m do j = 1, n a(i,j) = real ( min ( i, j ), kind = rk ) end do end do return end subroutine minij_condition ( n, value ) !*****************************************************************************80 ! !! minij_condition() returns the L1 condition of the MINIJ matrix. ! ! Licensing: ! ! This code is distributed under the MIT license. ! ! Modified: ! ! 28 January 2015 ! ! Author: ! ! John Burkardt ! ! Input: ! ! integer N, the order of the matrix. ! ! Output: ! ! real ( kind = rk ) VALUE, the L1 condition. ! implicit none integer, parameter :: rk = kind ( 1.0D+00 ) integer n real ( kind = rk ) a_norm real ( kind = rk ) b_norm real ( kind = rk ) value a_norm = real ( n * ( n + 1 ), kind = rk ) / 2.0D+00 if ( n == 1 ) then b_norm = 1.0D+00 else if ( n == 2 ) then b_norm = 3.0D+00 else b_norm = 4.0D+00 end if value = a_norm * b_norm return end subroutine minij_determinant ( n, determ ) !*****************************************************************************80 ! !! minij_determinant() returns the determinant of the MINIJ matrix. ! ! Licensing: ! ! This code is distributed under the MIT license. ! ! Modified: ! ! 13 October 2007 ! ! Author: ! ! John Burkardt ! ! Input: ! ! integer N, the order of the matrix. ! ! Output: ! ! real ( kind = rk ) DETERM, the determinant. ! implicit none integer, parameter :: rk = kind ( 1.0D+00 ) integer n real ( kind = rk ) angle real ( kind = rk ) determ integer i real ( kind = rk ), parameter :: r8_pi = 3.141592653589793D+00 determ = 1.0D+00 do i = 1, n angle = real ( 2 * i - 1, kind = rk ) * r8_pi / real ( 2 * n + 1, kind = rk ) determ = determ * 0.5D+00 / ( 1.0D+00 - cos ( angle ) ) end do return end subroutine minij_eigenvalues ( n, lambda ) !*****************************************************************************80 ! !! minij_eigenvalues() returns the eigenvalues of the MINIJ matrix. ! ! Licensing: ! ! This code is distributed under the MIT license. ! ! Modified: ! ! 21 May 2002 ! ! Author: ! ! John Burkardt ! ! Input: ! ! integer N, the order of the matrix. ! ! Output: ! ! real ( kind = rk ) LAMBDA(N), the eigenvalues. ! implicit none integer, parameter :: rk = kind ( 1.0D+00 ) integer n real ( kind = rk ) angle integer i real ( kind = rk ) lambda(n) real ( kind = rk ), parameter :: r8_pi = 3.141592653589793D+00 do i = 1, n angle = real ( 2 * i - 1, kind = rk ) * r8_pi / real ( 2 * n + 1, kind = rk ) lambda(i) = 0.5D+00 / ( 1.0D+00 - cos ( angle ) ) end do return end subroutine minij_inverse ( n, a ) !*****************************************************************************80 ! !! minij_inverse() returns the inverse of the MINIJ matrix. ! ! Formula: ! ! A(I,J) = -1 if J=I-1 or J=I+1 ! A(I,J) = 2 if J=I and J is not N. ! A(I,J) = 1 if J=I and J=N. ! A(I,J) = 0 otherwise ! ! Example: ! ! N = 5 ! ! 2 -1 0 0 0 ! -1 2 -1 0 0 ! 0 -1 2 -1 0 ! 0 0 -1 2 -1 ! 0 0 0 -1 1 ! ! Properties: ! ! A is symmetric: A' = A. ! ! Because A is symmetric, it is normal. ! ! Because A is normal, it is diagonalizable. ! ! A is tridiagonal. ! ! Because A is tridiagonal, it has property A (bipartite). ! ! A is banded, with bandwidth 3. ! ! A is integral, therefore det ( A ) is integral, and ! det ( A ) * inverse ( A ) is integral. ! ! A is "almost" equal to the second difference matrix, ! as computed by DIF. ! ! Licensing: ! ! This code is distributed under the MIT license. ! ! Modified: ! ! 15 April 1999 ! ! Author: ! ! John Burkardt ! ! Input: ! ! integer N, the order of the matrix. ! ! Output: ! ! real ( kind = rk ) A(N,N), the matrix. ! implicit none integer, parameter :: rk = kind ( 1.0D+00 ) integer n real ( kind = rk ) a(n,n) integer i integer j do i = 1, n do j = 1, n if ( i == j ) then if ( i < n ) then a(i,j) = 2.0D+00 else a(i,j) = 1.0D+00 end if else if ( i == j + 1 .or. i == 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 ) !*****************************************************************************80 ! !! minij_llt() returns the Cholesky factor of the MINIJ matrix. ! ! Discussion: ! ! This is an instance of the SUMMATION matrix. ! ! Example: ! ! N = 5 ! ! 1 0 0 0 0 ! 1 1 0 0 0 ! 1 1 1 0 0 ! 1 1 1 1 0 ! 1 1 1 1 1 ! ! Licensing: ! ! This code is distributed under the MIT license. ! ! Modified: ! ! 07 June 2011 ! ! Author: ! ! John Burkardt ! ! Input: ! ! integer N, the order of the matrix. ! ! ! Output: ! ! real ( kind = rk ) A(N,N), the matrix. ! implicit none integer, parameter :: rk = kind ( 1.0D+00 ) integer n real ( kind = rk ) a(n,n) integer i do i = 1, n a(i,1:i) = 1.0D+00 a(i,i+1:n) = 0.0D+00 end do return end subroutine minij_lu ( n, l, u ) !*****************************************************************************80 ! !! minij_lu() returns the LU factors of the MINIJ matrix. ! ! Licensing: ! ! This code is distributed under the MIT license. ! ! Modified: ! ! 28 October 2021 ! ! Author: ! ! John Burkardt ! ! Input: ! ! integer N, the order of the matrix. ! ! Output: ! ! real ( kind = rk ) L(N,N), U(N,N), the factors. ! implicit none integer, parameter :: rk = kind ( 1.0D+00 ) integer n integer i integer j real ( kind = rk ) l(n,n) real ( kind = rk ) u(n,n) 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 minij_plu ( n, p, l, u ) !*****************************************************************************80 ! !! minij_plu() returns the PLU factors of the MINIJ matrix. ! ! Licensing: ! ! This code is distributed under the MIT license. ! ! Modified: ! ! 19 August 2008 ! ! Author: ! ! John Burkardt ! ! Input: ! ! integer N, the order of the matrix. ! ! Output: ! ! real ( kind = rk ) P(N,N), L(N,N), U(N,N), the PLU factors. ! implicit none integer, parameter :: rk = kind ( 1.0D+00 ) integer n integer i integer j real ( kind = rk ) l(n,n) real ( kind = rk ) p(n,n) real ( kind = rk ) u(n,n) do j = 1, n do i = 1, n if ( i == 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 ) !*****************************************************************************80 ! !! moebius() returns the value of MU(N), the Moebius function of N. ! ! Discussion: ! ! MU(N) is defined as follows: ! ! MU(N) = 1 if N = 1; ! 0 if N is divisible by the square of a prime; ! (-1)^K, if N is the product of K distinct primes. ! ! As special cases, MU(N) is -1 if N is a prime, and MU(N) is 0 ! if N is a square, cube, etc. ! ! The Moebius function is related to Euler's totient function: ! ! PHI(N) = Sum ( D divides N ) MU(D) * ( N / D ). ! ! First values: ! ! N MU(N) ! ! 1 1 ! 2 -1 ! 3 -1 ! 4 0 ! 5 -1 ! 6 1 ! 7 -1 ! 8 0 ! 9 0 ! 10 1 ! 11 -1 ! 12 0 ! 13 -1 ! 14 1 ! 15 1 ! 16 0 ! 17 -1 ! 18 0 ! 19 -1 ! 20 0 ! ! Licensing: ! ! This code is distributed under the MIT license. ! ! Modified: ! ! 01 March 1999 ! ! Author: ! ! John Burkardt ! ! Input: ! ! integer N, the value to be analyzed. ! ! Output: ! ! integer MU, the value of MU(N). ! If N is less than or equal to 0, MU will be returned as -2. ! If there was not enough internal space for factoring, MU ! is returned as -3. ! implicit none integer, parameter :: rk = kind ( 1.0D+00 ) integer, parameter :: maxfactor = 20 integer factor(maxfactor) integer i integer mu integer n integer nfactor integer nleft integer power(maxfactor) if ( n <= 0 ) then mu = - 2 return end if if ( n == 1 ) then mu = 1 return end if ! ! Factor N. ! call i4_factor ( n, maxfactor, nfactor, factor, power, nleft ) if ( nleft /= 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 < power(i) ) then mu = 0 return end if end do return end subroutine moebius_values ( n_data, n, c ) !*****************************************************************************80 ! !! moebius_values() returns some values of the Moebius function. ! ! Discussion: ! ! MU(N) is defined as follows: ! ! MU(N) = 1 if N = 1; ! 0 if N is divisible by the square of a prime; ! (-1)^K, if N is the product of K distinct primes. ! ! In Mathematica, the function can be evaluated by: ! ! MoebiusMu[n] ! ! First values: ! ! N MU(N) ! ! 1 1 ! 2 -1 ! 3 -1 ! 4 0 ! 5 -1 ! 6 1 ! 7 -1 ! 8 0 ! 9 0 ! 10 1 ! 11 -1 ! 12 0 ! 13 -1 ! 14 1 ! 15 1 ! 16 0 ! 17 -1 ! 18 0 ! 19 -1 ! 20 0 ! ! Note: ! ! As special cases, MU(N) is -1 if N is a prime, and MU(N) is 0 ! if N is a square, cube, etc. ! ! Formula: ! ! The Moebius function is related to Euler's totient function: ! ! PHI(N) = Sum ( D divides N ) MU(D) * ( N / D ). ! ! Licensing: ! ! This code is distributed under the MIT license. ! ! Modified: ! ! 16 February 2003 ! ! Author: ! ! John Burkardt ! ! Reference: ! ! Milton Abramowitz, Irene Stegun, ! Handbook of Mathematical Functions, ! National Bureau of Standards, 1964, ! ISBN: 0-486-61272-4, ! LC: QA47.A34. ! ! Stephen Wolfram, ! The Mathematica Book, ! Fourth Edition, ! Cambridge University Press, 1999, ! ISBN: 0-521-64314-7, ! LC: QA76.95.W65. ! ! Input: ! ! integer N_DATA, the user sets N_DATA to 0 before first call. ! ! Output: ! ! integer N_DATA, the routine increments N_DATA by 1, ! and returns the corresponding data; when there is no more data, the ! output value of N_DATA will be 0 again. ! ! integer N, the argument of the Moebius function. ! ! integer C, the value of the Moebius function. ! implicit none integer, parameter :: rk = kind ( 1.0D+00 ) integer, parameter :: n_max = 20 integer c integer, save, dimension ( n_max ) :: c_vec = (/ & 1, -1, -1, 0, -1, 1, -1, 0, 0, 1, & -1, 0, -1, 1, 1, 0, -1, 0, -1, 0 /) integer n integer n_data integer, save, dimension ( n_max ) :: 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 < 0 ) then n_data = 0 end if n_data = n_data + 1 if ( n_max < 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_matrix ( alpha, m, n, a ) !*****************************************************************************80 ! !! moler1_matrix() returns the MOLER1 matrix. ! ! Formula: ! ! If ( I = J ) ! A(I,J) = min ( I-1, J-1 ) * ALPHA^2 + 1 ! else ! A(I,J) = min ( I-1, J-1 ) * ALPHA^2 + ALPHA ! ! Example: ! ! ALPHA = 2, N = 5 ! ! 1 2 2 2 2 ! 2 5 6 6 6 ! 2 6 9 10 10 ! 2 6 10 13 14 ! 2 6 10 14 17 ! ! Properties: ! ! Successive elements of each diagonal increase by an increment of ALPHA^2. ! ! A is the product of B' * B, where B is the matrix returned by ! ! CALL TRIW ( ALPHA, N-1, N, B ). ! ! A is symmetric: A' = A. ! ! Because A is symmetric, it is normal. ! ! Because A is normal, it is diagonalizable. ! ! A is positive definite. ! ! If ALPHA = -1, A(I,J) = min ( I, J ) - 2, A(I,I)=I. ! ! A has one small eigenvalue. ! ! If ALPHA is integral, then A is integral. ! If A is integral, then det ( A ) is integral, and ! det ( A ) * inverse ( A ) is integral. ! ! The family of matrices is nested as a function of N. ! ! Licensing: ! ! This code is distributed under the MIT license. ! ! Modified: ! ! 15 April 1999 ! ! Author: ! ! John Burkardt ! ! Reference: ! ! John Nash, ! Compact Numerical Methods for Computers: Linear Algebra and ! Function Minimisation, ! Second Edition, ! Taylor & Francis, 1990, ! ISBN: 085274319X, ! LC: QA184.N37. ! ! Input: ! ! real ( kind = rk ) ALPHA, the parameter. ! ! integer M, N, the order of the matrix. ! ! Output: ! ! real ( kind = rk ) A(M,N), the matrix. ! implicit none integer, parameter :: rk = kind ( 1.0D+00 ) integer m integer n real ( kind = rk ) a(m,n) real ( kind = rk ) alpha integer i integer j do i = 1, m do j = 1, n if ( i == j ) then a(i,j) = real ( min ( i-1, j-1 ), kind = rk ) * alpha ** 2 + 1.0D+00 else a(i,j) = real ( min ( i-1, j-1 ), kind = rk ) * alpha ** 2 + alpha end if end do end do return end subroutine moler1_determinant ( alpha, n, determ ) !*****************************************************************************80 ! !! moler1_determinant() returns the determinant of the MOLER1 matrix. ! ! Licensing: ! ! This code is distributed under the MIT license. ! ! Modified: ! ! 25 October 2007 ! ! Author: ! ! John Burkardt ! ! Input: ! ! real ( kind = rk ) ALPHA, the parameter. ! ! integer N, the order of the matrix. ! ! Output: ! ! real ( kind = rk ) DETERM, the determinant. ! implicit none integer, parameter :: rk = kind ( 1.0D+00 ) real ( kind = rk ) alpha real ( kind = rk ) determ integer n call r8_fake_use ( alpha ) call i4_fake_use ( n ) determ = 1.0D+00 return end subroutine moler1_inverse ( alpha, n, a ) !*****************************************************************************80 ! !! moler1_inverse() returns the inverse of the MOLER1 matrix. ! ! Example: ! ! ALPHA = 2.0, N = 5 ! ! 17 -14 10 -6 2 ! -14 13 -10 6 -2 ! 10 -10 9 -6 2 ! -6 6 -6 5 -2 ! 2 -2 2 -2 1 ! ! Licensing: ! ! This code is distributed under the MIT license. ! ! Modified: ! ! 27 June 2011 ! ! Author: ! ! John Burkardt ! ! Input: ! ! real ( kind = rk ) ALPHA, the parameter. ! ! integer N, the order of the matrix. ! ! Output: ! ! real ( kind = rk ) A(N,N), the matrix. ! implicit none integer, parameter :: rk = kind ( 1.0D+00 ) integer n real ( kind = rk ) a(n,n) real ( kind = rk ) alpha integer i integer j real ( kind = rk ) 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 <= j ) then a(i,j) = dot_product ( v(1+j-i:n+1-i), v(1 :n+1-j) ) else a(i,j) = dot_product ( v(1 :n+1-i), v(1+i-j:n+1-j) ) end if end do end do return end subroutine moler1_llt ( alpha, n, a ) !*****************************************************************************80 ! !! moler1_llt() returns the lower triangular Cholesky factor of the MOLER1 matrix. ! ! Example: ! ! ALPHA = 2, N = 5 ! ! 1 0 0 0 0 ! 2 1 0 0 0 ! 2 2 1 0 0 ! 2 2 2 1 0 ! 2 2 2 2 1 ! ! Licensing: ! ! This code is distributed under the MIT license. ! ! Modified: ! ! 16 March 2015 ! ! Author: ! ! John Burkardt ! ! Input: ! ! real ( kind = rk ) ALPHA, the parameter. ! ! integer N, the order of the matrix. ! ! Output: ! ! real ( kind = rk ) A(N,N), the matrix. ! implicit none integer, parameter :: rk = kind ( 1.0D+00 ) integer n real ( kind = rk ) a(n,n) real ( kind = rk ) 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_lu ( alpha, n, l, u ) !*****************************************************************************80 ! !! moler1_lu() returns the LU factors of the MOLER1 matrix. ! ! Licensing: ! ! This code is distributed under the MIT license. ! ! Modified: ! ! 28 October 2021 ! ! Author: ! ! John Burkardt ! ! Reference: ! ! John Nash, ! Compact Numerical Methods for Computers: Linear Algebra and ! Function Minimisation, ! Second Edition, ! Taylor & Francis, 1990, ! ISBN: 085274319X, ! LC: QA184.N37. ! ! Input: ! ! real ( kind = rk ) ALPHA, the parameter. ! ! integer N, the order of the matrix. ! ! Output: ! ! real ( kind = rk ) L(N,N), U(N,N), the factors. ! implicit none integer, parameter :: rk = kind ( 1.0D+00 ) integer n real ( kind = rk ) alpha integer i integer j real ( kind = rk ) l(n,n) real ( kind = rk ) u(n,n) do j = 1, n do i = 1, n if ( i == j ) then l(i,j) = 1.0D+00 else if ( j < 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 == j ) then u(i,j) = 1.0D+00 else if ( i < j ) then u(i,j) = alpha else u(i,j) = 0.0D+00 end if end do end do return end subroutine moler1_plu ( alpha, n, p, l, u ) !*****************************************************************************80 ! !! moler1_plu() returns the PLU factors of the MOLER1 matrix. ! ! Licensing: ! ! This code is distributed under the MIT license. ! ! Modified: ! ! 17 August 2008 ! ! Author: ! ! John Burkardt ! ! Reference: ! ! John Nash, ! Compact Numerical Methods for Computers: Linear Algebra and ! Function Minimisation, ! Second Edition, ! Taylor & Francis, 1990, ! ISBN: 085274319X, ! LC: QA184.N37. ! ! Input: ! ! real ( kind = rk ) ALPHA, the parameter. ! ! integer N, the order of the matrix. ! ! Output: ! ! real ( kind = rk ) P(N,N), L(N,N), U(N,N), the PLU factors. ! implicit none integer, parameter :: rk = kind ( 1.0D+00 ) integer n real ( kind = rk ) alpha integer i integer j real ( kind = rk ) l(n,n) real ( kind = rk ) p(n,n) real ( kind = rk ) u(n,n) do j = 1, n do i = 1, n if ( i == 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 == j ) then l(i,j) = 1.0D+00 else if ( j < 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 == j ) then u(i,j) = 1.0D+00 else if ( i < j ) then u(i,j) = alpha else u(i,j) = 0.0D+00 end if end do end do return end subroutine moler2_matrix ( a ) !*****************************************************************************80 ! !! moler2_matrix() returns the MOLER2 matrix. ! ! Discussion: ! ! This is a 5 by 5 matrix for which the challenge is to find the EXACT ! eigenvalues and eigenvectors. ! ! Example: ! ! -9 11 -21 63 -252 ! 70 -69 141 -421 1684 ! -575 575 -1149 3451 -13801 ! 3891 -3891 7782 -23345 93365 ! 1024 -1024 2048 -6144 24572 ! ! Properties: ! ! A is defective. ! ! The Jordan normal form of A has just one block, with eigenvalue ! zero, because A^k is nonzero for K = 0, 1, 2, 3, 4, but A^5=0. ! ! det ( A ) = 0. ! ! TRACE(A) = 0. ! ! Licensing: ! ! This code is distributed under the MIT license. ! ! Modified: ! ! 16 June 2011 ! ! Author: ! ! John Burkardt ! ! Output: ! ! real ( kind = rk ) A(5,5), the matrix. ! implicit none integer, parameter :: rk = kind ( 1.0D+00 ) real ( kind = rk ) a(5,5) ! ! Note that the matrix entries are listed by column. ! real ( kind = rk ), dimension ( 5, 5 ), save :: a_save = reshape ( (/ & -9.0D+00, 70.0D+00, -575.0D+00, 3891.0D+00, 1024.0D+00, & 11.0D+00, -69.0D+00, 575.0D+00, -3891.0D+00, -1024.0D+00, & -21.0D+00, 141.0D+00, -1149.0D+00, 7782.0D+00, 2048.0D+00, & 63.0D+00, -421.0D+00, 3451.0D+00, -23345.0D+00, -6144.0D+00, & -252.0D+00, 1684.0D+00, -13801.0D+00, 93365.0D+00, 24572.0D+00 /), & (/ 5, 5 /) ) call r8mat_copy ( 5, 5, a_save, a ) return end subroutine moler2_determinant ( determ ) !*****************************************************************************80 ! !! moler2_determinant() returns the determinant of the MOLER2 matrix. ! ! Licensing: ! ! This code is distributed under the MIT license. ! ! Modified: ! ! 13 October 2007 ! ! Author: ! ! John Burkardt ! ! Output: ! ! real ( kind = rk ) DETERM, the determinant. ! implicit none integer, parameter :: rk = kind ( 1.0D+00 ) real ( kind = rk ) determ determ = 0.0D+00 return end subroutine moler2_eigenvalues ( lambda ) !*****************************************************************************80 ! !! moler2_eigenvalues() returns the eigenvalues of the MOLER2 matrix. ! ! Licensing: ! ! This code is distributed under the MIT license. ! ! Modified: ! ! 15 October 2007 ! ! Author: ! ! John Burkardt ! ! Output: ! ! real ( kind = rk ) LAMBDA(5), the eigenvalues. ! implicit none integer, parameter :: rk = kind ( 1.0D+00 ) real ( kind = rk ) lambda(5) lambda(1:5) = 0.0D+00 return end subroutine moler2_null_left ( x ) !*****************************************************************************80 ! !! moler2_null_left() returns a left null vector for the MOLER2 matrix. ! ! Licensing: ! ! This code is distributed under the MIT license. ! ! Modified: ! ! 08 March 2015 ! ! Author: ! ! John Burkardt ! ! Output: ! ! real ( kind = rk ) X(5), the null vector. ! implicit none integer, parameter :: rk = kind ( 1.0D+00 ) real ( kind = rk ) x(5) real ( kind = rk ), dimension ( 5 ), save :: 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 ) !*****************************************************************************80 ! !! moler2_null_right() returns a right null vector for the MOLER2 matrix. ! ! Licensing: ! ! This code is distributed under the MIT license. ! ! Modified: ! ! 16 June 2011 ! ! Author: ! ! John Burkardt ! ! Output: ! ! real ( kind = rk ) X(5), the null vector. ! implicit none integer, parameter :: rk = kind ( 1.0D+00 ) real ( kind = rk ) x(5) real ( kind = rk ), dimension ( 5 ), save :: 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_condition ( n, c ) !*****************************************************************************80 ! !! moler3_condition() returns the L1 condition of the Moler3 matrix. ! ! Licensing: ! ! This code is distributed under the MIT license. ! ! Modified: ! ! 04 November 2021 ! ! Author: ! ! John Burkardt ! ! Input: ! ! integer N, the order of the matrix. ! ! Output: ! ! real ( kind = rk ) C, the L1 condition. ! implicit none integer, parameter :: rk = kind ( 1.0D+00 ) integer n real ( kind = rk ) A(n,n) real ( kind = rk ) anorm real ( kind = rk ) B(n,n) real ( kind = rk ) bnorm real ( kind = rk ) c real ( kind = rk ) r8mat_norm_l1 call moler3_matrix ( n, n, a ) anorm = r8mat_norm_l1 ( n, n, a ) call moler3_inverse ( n, b ) bnorm = r8mat_norm_l1 ( n, n, b ) c = anorm * bnorm return end subroutine moler3_determinant ( n, determ ) !*****************************************************************************80 ! !! moler3_determinant() returns the determinant of the MOLER3 matrix. ! ! Licensing: ! ! This code is distributed under the MIT license. ! ! Modified: ! ! 03 November 2007 ! ! Author: ! ! John Burkardt ! ! Input: ! ! integer N, the order of the matrix. ! ! Output: ! ! real ( kind = rk ) DETERM, the determinant. ! implicit none integer, parameter :: rk = kind ( 1.0D+00 ) real ( kind = rk ) determ integer n call i4_fake_use ( n ) determ = 1.0D+00 return end subroutine moler3_inverse ( n, a ) !*****************************************************************************80 ! !! moler3_inverse() returns the inverse of the MOLER3 matrix. ! ! Example: ! ! N = 5 ! ! 86 43 22 12 8 ! 43 22 11 6 4 ! 22 11 6 3 2 ! 12 6 3 2 1 ! 8 4 2 1 1 ! ! Licensing: ! ! This code is distributed under the MIT license. ! ! Modified: ! ! 20 October 2007 ! ! Author: ! ! John Burkardt ! ! Input: ! ! integer N, the order of the matrix. ! ! Output: ! ! real ( kind = rk ) A(N,N), the matrix. ! implicit none integer, parameter :: rk = kind ( 1.0D+00 ) integer n real ( kind = rk ) a(n,n) integer i integer j real ( kind = rk ) l(n,n) real ( kind = rk ) value l(1:n,1:n) = 0.0D+00 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 a(1:n,1:n) = matmul ( transpose ( l(1:n,1:n) ), l(1:n,1:n) ) return end subroutine moler3_llt ( n, a ) !*****************************************************************************80 ! !! moler3_llt() returns the Cholesky factor of the MOLER3 matrix. ! ! Discussion: ! ! This is an instance of the ANTISUMMATION matrix. ! ! Example: ! ! N = 5 ! ! 1 0 0 0 0 ! -1 1 0 0 0 ! -1 -1 1 0 0 ! -1 -1 -1 1 0 ! -1 -1 -1 -1 1 ! ! Licensing: ! ! This code is distributed under the MIT license. ! ! Modified: ! ! 26 May 2002 ! ! Author: ! ! John Burkardt ! ! Input: ! ! integer N, the order of the matrix. ! ! Output: ! ! real ( kind = rk ) A(N,N), the matrix. ! implicit none integer, parameter :: rk = kind ( 1.0D+00 ) integer n real ( kind = rk ) a(n,n) integer i do i = 1, n a(i,1:i-1) = -1.0D+00 a(i,i) = 1.0D+00 a(i,i+1:n) = 0.0D+00 end do return end subroutine moler3_lu ( n, l, u ) !*****************************************************************************80 ! !! moler3_lu() returns the LU factors of the MOLER3 matrix. ! ! Licensing: ! ! This code is distributed under the MIT license. ! ! Modified: ! ! 28 October 2021 ! ! Author: ! ! John Burkardt ! ! Input: ! ! integer N, the order of the matrix. ! ! Output: ! ! real ( kind = rk ) L(N,N), U(N,N), the factors. ! implicit none integer, parameter :: rk = kind ( 1.0D+00 ) integer n integer i integer j real ( kind = rk ) l(n,n) real ( kind = rk ) u(n,n) do i = 1, n l(i,1:i-1 ) = -1.0D+00 l(i, i ) = 1.0D+00 l(i, i+1:n) = 0.0D+00 end do do j = 1, n u(1:j-1, j) = -1.0D+00 u( j, j) = 1.0D+00 u( j+1:n,j) = 0.0D+00 end do return end subroutine moler3_matrix ( m, n, a ) !*****************************************************************************80 ! !! moler3_matrix() returns the MOLER3 matrix. ! ! Formula: ! ! if ( I == J ) then ! A(I,J) = I ! else ! A(I,J) = min(I,J) - 2 ! ! Example: ! ! N = 5 ! ! 1 -1 -1 -1 -1 ! -1 2 0 0 0 ! -1 0 3 1 1 ! -1 0 1 4 2 ! -1 0 1 2 5 ! ! Properties: ! ! A is integral, therefore det ( A ) is integral, and ! det ( A ) * inverse ( A ) is integral. ! ! A is positive definite. ! ! A is symmetric: A' = A. ! ! Because A is symmetric, it is normal. ! ! Because A is normal, it is diagonalizable. ! ! A has a simple Cholesky factorization. ! ! A has one small eigenvalue. ! ! The family of matrices is nested as a function of N. ! ! Licensing: ! ! This code is distributed under the MIT license. ! ! Modified: ! ! 26 May 2002 ! ! Author: ! ! John Burkardt ! ! Input: ! ! integer M, N, the order of the matrix. ! ! Output: ! ! real ( kind = rk ) A(M,N), the matrix. ! implicit none integer, parameter :: rk = kind ( 1.0D+00 ) integer m integer n real ( kind = rk ) a(m,n) integer i integer j do i = 1, m do j = 1, n if ( i == j ) then a(i,j) = real ( i, kind = rk ) else a(i,j) = real ( min ( i, j ) - 2, kind = rk ) end if end do end do return end subroutine moler3_plu ( n, p, l, u ) !*****************************************************************************80 ! !! moler3_plu() returns the PLU factors of the MOLER3 matrix. ! ! Licensing: ! ! This code is distributed under the MIT license. ! ! Modified: ! ! 26 May 2002 ! ! Author: ! ! John Burkardt ! ! Input: ! ! integer N, the order of the matrix. ! ! Output: ! ! real ( kind = rk ) P(N,N), L(N,N), U(N,N), the PLU factors. ! implicit none integer, parameter :: rk = kind ( 1.0D+00 ) integer n integer i integer j real ( kind = rk ) l(n,n) real ( kind = rk ) p(n,n) real ( kind = rk ) u(n,n) do j = 1, n do i = 1, n if ( i == 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 l(i,1:i-1 ) = -1.0D+00 l(i, i ) = 1.0D+00 l(i, i+1:n) = 0.0D+00 end do do j = 1, n u(1:j-1, j) = -1.0D+00 u( j, j) = 1.0D+00 u( j+1:n,j) = 0.0D+00 end do return end subroutine moler4_matrix ( a ) !*****************************************************************************80 ! !! moler4_matrix() returns the MOLER4 matrix. ! ! Example: ! ! 0 2 0 -1 ! 1 0 0 0 ! 0 1 0 0 ! 0 0 1 0 ! ! Properties: ! ! A is integral, therefore det ( A ) is integral, and ! det ( A ) * inverse ( A ) is integral. ! ! A is the companion matrix of the polynomial X^4-2X^2+1=0. ! ! A has eigenvalues -1, -1, +1, +1. ! ! A can cause problems to a standard QR algorithm, which ! can fail to converge. ! ! Licensing: ! ! This code is distributed under the MIT license. ! ! Modified: ! ! 24 February 2015 ! ! Author: ! ! John Burkardt ! ! Output: ! ! real ( kind = rk ) A(4,4), the matrix. ! implicit none integer, parameter :: rk = kind ( 1.0D+00 ) real ( kind = rk ) a(4,4) ! ! Note that the matrix entries are listed by column. ! real ( kind = rk ), dimension ( 4, 4 ), save :: a_save = reshape ( (/ & 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 /), (/ 4, 4 /) ) call r8mat_copy ( 4, 4, a_save, a ) return end subroutine moler4_condition ( value ) !*****************************************************************************80 ! !! moler4_condition() returns the L1 condition of the MOLER4 matrix. ! ! Licensing: ! ! This code is distributed under the MIT license. ! ! Modified: ! ! 24 February 2015 ! ! Author: ! ! John Burkardt ! ! Output: ! ! real ( kind = rk ) VALUE, the L1 condition. ! implicit none integer, parameter :: rk = kind ( 1.0D+00 ) real ( kind = rk ) a_norm real ( kind = rk ) b_norm real ( kind = rk ) value a_norm = 3.0D+00 b_norm = 3.0D+00 value = a_norm * b_norm return end subroutine moler4_determinant ( value ) !*****************************************************************************80 ! !! moler4_determinant() returns the determinant of the MOLER4 matrix. ! ! Licensing: ! ! This code is distributed under the MIT license. ! ! Modified: ! ! 24 February 2015 ! ! Author: ! ! John Burkardt ! ! Output: ! ! real ( kind = rk ) VALUE, the determinant. ! implicit none integer, parameter :: rk = kind ( 1.0D+00 ) real ( kind = rk ) value value = 1.0D+00 return end subroutine moler4_eigenvalues ( lambda ) !*****************************************************************************80 ! !! moler4_eigenvalues() returns the eigenvalues of the MOLER4 matrix. ! ! Licensing: ! ! This code is distributed under the MIT license. ! ! Modified: ! ! 24 February 2015 ! ! Author: ! ! John Burkardt ! ! Output: ! ! real ( kind = rk ) LAMBDA(4), the eigenvalues. ! implicit none integer, parameter :: rk = kind ( 1.0D+00 ) real ( kind = rk ) lambda(4) lambda(1:2) = -1.0D+00 lambda(3:4) = +1.0D+00 return end subroutine moler4_inverse ( a ) !*****************************************************************************80 ! !! moler4_inverse() returns the inverse of the MOLER4 matrix. ! ! Example: ! ! 0 1 0 0 ! 0 0 1 0 ! 0 0 0 1 ! -1 0 2 0 ! ! Licensing: ! ! This code is distributed under the MIT license. ! ! Modified: ! ! 24 February 2015 ! ! Author: ! ! John Burkardt ! ! Output: ! ! real ( kind = rk ) A(4,4), the matrix. ! implicit none integer, parameter :: rk = kind ( 1.0D+00 ) real ( kind = rk ) a(4,4) ! ! Note that the matrix entries are listed by column. ! real ( kind = rk ), dimension ( 4, 4 ), save :: a_save = reshape ( (/ & 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 /), (/ 4, 4 /) ) call r8mat_copy ( 4, 4, a_save, a ) return end subroutine neumann_matrix ( nrow, ncol, a ) !*****************************************************************************80 ! !! neumann_matrix() returns the NEUMANN matrix. ! ! Formula: ! ! I1 = 1 + ( I - 1 ) / NROW ! I2 = I - ( I1 - 1 ) * NROW ! J1 = 1 + ( J - 1 ) / NROW ! ! if ( I = J ) ! A(I,J) = 4 ! else If ( I = J-1 ) ! If ( I2 = 1 ) ! A(I,J) = -2 ! else ! A(I,J) = -1 ! else if ( I = J+1 ) ! If ( I2 = NROW ) ! A(I,J) = -2 ! else ! A(I,J) = -1 ! else if ( I = J - NROW ) ! if ( J1 = 2 ) ! A(I,J) = -2 ! else ! A(I,J) = -1 ! else if ( I = J + NROW ) ! if ( J1 = NCOL-1 ) ! A(I,J) = -2 ! else ! A(I,J) = -1 ! else ! A(I,J) = 0.0D+00 ! ! Example: ! ! NROW = NCOL = 3 ! ! 4 -2 0 | -2 0 0 | 0 0 0 ! -1 4 -1 | 0 -2 0 | 0 0 0 ! 0 -2 4 | 0 0 -2 | 0 0 0 ! ---------------------------- ! -1 0 0 | 4 -1 0 | -1 0 0 ! 0 -1 0 | -1 4 -1 | 0 -1 0 ! 0 0 -1 | 0 -1 4 | 0 0 -1 ! ---------------------------- ! 0 0 0 | -2 0 0 | 4 -2 0 ! 0 0 0 | 0 -2 0 | -1 4 -1 ! 0 0 0 | 0 0 -2 | 0 -2 4 ! ! Properties: ! ! A is integral, therefore det ( A ) is integral, and ! det ( A ) * inverse ( A ) is integral. ! ! A is block tridiagonal. ! ! A results from discretizing Neumann's equation with the ! 5 point operator on a mesh of NROW by NCOL points. ! ! A is singular. ! ! A has the null vector ( 1, 1, ..., 1 ). ! ! det ( A ) = 0. ! ! Licensing: ! ! This code is distributed under the MIT license. ! ! Modified: ! ! 25 October 2007 ! ! Author: ! ! John Burkardt ! ! Reference: ! ! Gene Golub, Charles Van Loan, ! Matrix Computations, second edition, ! Johns Hopkins University Press, Baltimore, Maryland, 1989 ! (Section 4.5.4). ! ! Input: ! ! integer NROW, NCOL, the number of rows and columns ! in the grid. ! ! Output: ! ! real ( kind = rk ) A(NROW*NCOL,NROW*NCOL), the NROW*NCOL ! by NROW*NCOL matrix. ! implicit none integer, parameter :: rk = kind ( 1.0D+00 ) integer ncol integer nrow real ( kind = rk ) a(nrow*ncol,nrow*ncol) integer i integer i1 integer j integer j1 integer n n = nrow * ncol a(1:n,1:n) = 0.0D+00 i = 0 do i1 = 1, nrow do j1 = 1, ncol i = i + 1 if ( 1 < i1 ) then j = i - nrow else j = i + nrow end if a(i,j) = a(i,j) - 1.0D+00 if ( 1 < 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 < ncol ) then j = i + 1 else j = i - 1 end if a(i,j) = a(i,j) - 1.0D+00 if ( i1 < 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 ) !*****************************************************************************80 ! !! neumann_determinant() returns the determinant of the NEUMANN matrix. ! ! Licensing: ! ! This code is distributed under the MIT license. ! ! Modified: ! ! 02 October 2007 ! ! Author: ! ! John Burkardt ! ! Input: ! ! integer N, the order of the matrix. ! ! Output: ! ! real ( kind = rk ) DETERM, the determinant. ! implicit none integer, parameter :: rk = kind ( 1.0D+00 ) real ( kind = rk ) determ integer n call i4_fake_use ( n ) determ = 0.0D+00 return end subroutine neumann_null_right ( nrow, ncol, x ) !*****************************************************************************80 ! !! neumann_null_right() returns a right null vector of the NEUMANN matrix. ! ! Licensing: ! ! This code is distributed under the MIT license. ! ! Modified: ! ! 23 May 2002 ! ! Author: ! ! John Burkardt ! ! Input: ! ! integer NROW, NCOL, the number of rows and columns ! in the grid. ! ! Output: ! ! real ( kind = rk ) X(NROW*NCOL), the null vector. ! implicit none integer, parameter :: rk = kind ( 1.0D+00 ) integer ncol integer nrow real ( kind = rk ) x(nrow*ncol) x(1:nrow*ncol) = 1.0D+00 return end subroutine one_matrix ( m, n, a ) !*****************************************************************************80 ! !! one_matrix() returns the ONE matrix. ! ! Discussion: ! ! The matrix is sometimes symbolized by "J". ! ! Example: ! ! N = 5 ! ! 1 1 1 1 1 ! 1 1 1 1 1 ! 1 1 1 1 1 ! 1 1 1 1 1 ! 1 1 1 1 1 ! ! Properties: ! ! Every entry of A is 1. ! ! A is symmetric. ! ! A is Toeplitz: constant along diagonals. ! ! A is Hankel: constant along antidiagonals. ! ! A is a circulant matrix: each row is shifted once to get the next row. ! ! A has constant row sums of M. ! ! A has constant column sums of N. ! ! If 1 < N, A is singular. ! ! If 1 < N, det ( A ) = 0. ! ! LAMBDA(1:N-1) = 0 ! LAMBDA(N) = N ! ! The eigenvectors associated with LAMBDA = 0 can be written as ! ( 1, -1, 0, ..., 0 ) ! ( 1, 0, -1, ..., 0 ) ! ... ! ( 1, 0, 0, ..., -1 ). ! The eigenvector associated with LAMBDA = N is ( 1, 1, ..., 1 ). ! ! A * A = N * A ! ! The family of matrices is nested as a function of N. ! ! Licensing: ! ! This code is distributed under the MIT license. ! ! Modified: ! ! 24 May 2002 ! ! Author: ! ! John Burkardt ! ! Input: ! ! integer M, N, the order of the matrix. ! ! Output: ! ! real ( kind = rk ) A(M,N), the matrix. ! implicit none integer, parameter :: rk = kind ( 1.0D+00 ) integer m integer n real ( kind = rk ) a(m,n) a(1:m,1:n) = 1.0D+00 return end subroutine one_determinant ( n, determ ) !*****************************************************************************80 ! !! one_determinant() returns the determinant of the ONE matrix. ! ! Licensing: ! ! This code is distributed under the MIT license. ! ! Modified: ! ! 13 October 2007 ! ! Author: ! ! John Burkardt ! ! Input: ! ! integer N, the order of the matrix. ! ! Output: ! ! real ( kind = rk ) DETERM, the determinant. ! implicit none integer, parameter :: rk = kind ( 1.0D+00 ) real ( kind = rk ) determ integer n if ( n == 1 ) then determ = 1.0D+00 else determ = 0.0D+00 end if return end subroutine one_eigen_right ( n, x ) !*****************************************************************************80 ! !! one_eigen_right() returns the right eigenvectors of the ONE matrix. ! ! Licensing: ! ! This code is distributed under the MIT license. ! ! Modified: ! ! 25 November 2007 ! ! Author: ! ! John Burkardt ! ! Input: ! ! integer N, the order of the matrix. ! ! Output: ! ! real ( kind = rk ) X(N,N), the right eigenvectors. ! implicit none integer, parameter :: rk = kind ( 1.0D+00 ) integer n integer j real ( kind = rk ) x(n,n) x(1:n,1:n) = 0.0D+00 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 ) !*****************************************************************************80 ! !! one_eigenvalues() returns the eigenvalues of the ONE matrix. ! ! Licensing: ! ! This code is distributed under the MIT license. ! ! Modified: ! ! 13 October 2007 ! ! Author: ! ! John Burkardt ! ! Input: ! ! integer N, the order of the matrix. ! ! Output: ! ! real ( kind = rk ) LAMBDA(N), the eigenvalues. ! implicit none integer, parameter :: rk = kind ( 1.0D+00 ) integer n real ( kind = rk ) lambda(n) lambda(1:n-1) = 0.0D+00 lambda(n) = real ( n, kind = rk ) return end subroutine one_null_left ( m, n, x ) !*****************************************************************************80 ! !! one_null_left() returns a left null vector of the ONE matrix. ! ! Licensing: ! ! This code is distributed under the MIT license. ! ! Modified: ! ! 12 March 2015 ! ! Author: ! ! John Burkardt ! ! Input: ! ! integer M, N, the order of the matrix. ! ! Output: ! ! real ( kind = rk ) X(M), the null vector. ! implicit none integer, parameter :: rk = kind ( 1.0D+00 ) integer m integer n real ( kind = rk ) x(m) if ( n == 1 ) then write ( *, '(a)' ) ' ' write ( *, '(a)' ) 'one_NULL_LEFT - Fatal error!' write ( *, '(a)' ) ' Matrix is nonsingular for N = 1.' stop 1 end if x(1) = 1.0D+00 x(2:m-1) = 0.0D+00 x(m) = -1.0D+00 return end subroutine one_null_right ( m, n, x ) !*****************************************************************************80 ! !! one_null_right() returns a right null vector of the ONE matrix. ! ! Licensing: ! ! This code is distributed under the MIT license. ! ! Modified: ! ! 23 May 2002 ! ! Author: ! ! John Burkardt ! ! Input: ! ! integer M, N, the order of the matrix. ! ! Output: ! ! real ( kind = rk ) X(N), the null vector. ! implicit none integer, parameter :: rk = kind ( 1.0D+00 ) integer m integer n real ( kind = rk ) x(n) call i4_fake_use ( m ) if ( n == 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 x(2:n-1) = 0.0D+00 x(n) = -1.0D+00 return end subroutine ortega_matrix ( n, u, v, d, a ) !*****************************************************************************80 ! !! ortega_matrix() returns the ORTEGA matrix. ! ! Licensing: ! ! This code is distributed under the MIT license. ! ! Modified: ! ! 06 September 2008 ! ! Author: ! ! John Burkardt ! ! Reference: ! ! James Ortega, ! Generation of Test Matrices by Similarity Transformations, ! Communications of the ACM, ! Volume 7, 1964, pages 377-378. ! ! Input: ! ! integer N, the order of the matrix. ! 2 <= N. ! ! real ( kind = rk ) U(N), V(N), vectors which define the matrix. ! U'V must not equal -1.0. If, in fact, U'V = 0, and U, V and D are ! integers, then the matrix, inverse, eigenvalues, and eigenvectors ! will be integers. ! ! real ( kind = rk ) D(N), the desired eigenvalues. ! ! Output: ! ! real ( kind = rk ) A(N,N), the matrix. ! implicit none integer, parameter :: rk = kind ( 1.0D+00 ) integer n real ( kind = rk ) a(n,n) real ( kind = rk ) beta real ( kind = rk ) bik real ( kind = rk ) ckj real ( kind = rk ) d(n) integer i integer j integer k real ( kind = rk ) u(n) real ( kind = rk ) v(n) real ( kind = rk ) vtu vtu = dot_product ( v(1:n), u(1:n) ) 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 == k ) then bik = 1.0D+00 + u(i) * v(k) else bik = u(i) * v(k) end if if ( k == 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 ) !*****************************************************************************80 ! !! ortega_determinant() returns the determinant of the ORTEGA matrix. ! ! Licensing: ! ! This code is distributed under the MIT license. ! ! Modified: ! ! 06 September 2008 ! ! Author: ! ! John Burkardt ! ! Reference: ! ! James Ortega, ! Generation of Test Matrices by Similarity Transformations, ! Communications of the ACM, ! Volume 7, 1964, pages 377-378. ! ! Input: ! ! integer N, the order of the matrix. ! 2 <= N. ! ! real ( kind = rk ) U(N), V(N), vectors which define the matrix. ! U'V must not equal -1.0. If, in fact, U'V = 0, and U, V and D are ! integers, then the matrix, inverse, eigenvalues, and eigenvectors ! will be integers. ! ! real ( kind = rk ) D(N), the desired eigenvalues. ! ! Output: ! ! real ( kind = rk ) DETERM, the determinant. ! implicit none integer, parameter :: rk = kind ( 1.0D+00 ) integer n real ( kind = rk ) d(n) real ( kind = rk ) determ real ( kind = rk ) u(n) real ( kind = rk ) v(n) call r8_fake_use ( u(1) ) call r8_fake_use ( v(1) ) determ = product ( d(1:n) ) return end subroutine ortega_eigen_right ( n, u, v, d, x ) !*****************************************************************************80 ! !! ortega_eigen_right() returns the right eigenvectors of the ORTEGA matrix. ! ! Licensing: ! ! This code is distributed under the MIT license. ! ! Modified: ! ! 06 September 2008 ! ! Author: ! ! John Burkardt ! ! Reference: ! ! James Ortega, ! Generation of Test Matrices by Similarity Transformations, ! Communications of the ACM, ! Volume 7, 1964, pages 377-378. ! ! Input: ! ! integer N, the order of the matrix. ! 2 <= N. ! ! real ( kind = rk ) U(N), V(N), vectors which define the matrix. ! U'V must not equal -1.0. If, in fact, U'V = 0, and U, V and D are ! integers, then the matrix, inverse, eigenvalues, and eigenvectors ! will be integers. ! ! real ( kind = rk ) D(N), the desired eigenvalues. ! ! Output: ! ! real ( kind = rk ) X(N,N), the determinant. ! implicit none integer, parameter :: rk = kind ( 1.0D+00 ) integer n real ( kind = rk ) d(n) integer i integer j real ( kind = rk ) u(n) real ( kind = rk ) v(n) real ( kind = rk ) x(n,n) call r8_fake_use ( d(1) ) do j = 1, n do i = 1, n if ( i == 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 ) !*****************************************************************************80 ! !! ortega_eigenvalues() returns the eigenvalues of the ORTEGA matrix. ! ! Licensing: ! ! This code is distributed under the MIT license. ! ! Modified: ! ! 06 September 2008 ! ! Author: ! ! John Burkardt ! ! Reference: ! ! James Ortega, ! Generation of Test Matrices by Similarity Transformations, ! Communications of the ACM, ! Volume 7, 1964, pages 377-378. ! ! Input: ! ! integer N, the order of the matrix. ! 2 <= N. ! ! real ( kind = rk ) U(N), V(N), vectors which define the matrix. ! U'V must not equal -1.0. If, in fact, U'V = 0, and U, V and D are ! integers, then the matrix, inverse, eigenvalues, and eigenvectors ! will be integers. ! ! real ( kind = rk ) D(N), the desired eigenvalues. ! ! Output: ! ! real ( kind = rk ) LAMBDA(N), the determinant. ! implicit none integer, parameter :: rk = kind ( 1.0D+00 ) integer n real ( kind = rk ) d(n) real ( kind = rk ) lambda(n) real ( kind = rk ) u(n) real ( kind = rk ) v(n) call r8_fake_use ( lambda(1) ) call r8_fake_use ( u(1) ) call r8_fake_use ( v(1) ) lambda(1:n) = d(1:n) return end subroutine ortega_inverse ( n, u, v, d, a ) !*****************************************************************************80 ! !! ortega_inverse() returns the inverse of the ORTEGA matrix. ! ! Licensing: ! ! This code is distributed under the MIT license. ! ! Modified: ! ! 06 September 2008 ! ! Author: ! ! John Burkardt ! ! Reference: ! ! James Ortega, ! Generation of Test Matrices by Similarity Transformations, ! Communications of the ACM, ! Volume 7, 1964, pages 377-378. ! ! Input: ! ! integer N, the order of the matrix. ! 2 <= N. ! ! real ( kind = rk ) U(N), V(N), vectors which define the matrix. ! U'V must not equal -1.0. If, in fact, U'V = 0, and U, V and D are ! integers, then the matrix, inverse, eigenvalues, and eigenvectors ! will be integers. ! ! real ( kind = rk ) D(N), the desired eigenvalues. ! ! Output: ! ! real ( kind = rk ) A(N,N), the matrix. ! implicit none integer, parameter :: rk = kind ( 1.0D+00 ) integer n real ( kind = rk ) a(n,n) real ( kind = rk ) beta real ( kind = rk ) bik real ( kind = rk ) ckj real ( kind = rk ) d(n) integer i integer j integer k real ( kind = rk ) u(n) real ( kind = rk ) v(n) real ( kind = rk ) vtu vtu = dot_product ( v(1:n), u(1:n) ) if ( any ( d(1:n) == 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 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 == k ) then bik = 1.0D+00 + u(i) * v(k) else bik = + u(i) * v(k) end if if ( k == 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 orthogonal_random_matrix ( n, key, a ) !*****************************************************************************80 ! !! orthogonal_random_matrix() returns the orthogonal_random matrix. ! ! Discussion: ! ! The matrix is a random orthogonal matrix. ! ! Properties: ! ! The inverse of A is equal to A'. ! ! A is orthogonal: A * A' = A' * A = I. ! ! Because A is orthogonal, it is normal: A' * A = A * A'. ! ! Columns and rows of A have unit Euclidean norm. ! ! Distinct pairs of columns of A are orthogonal. ! ! Distinct pairs of rows of A are orthogonal. ! ! The L2 vector norm of A*x = the L2 vector norm of x for any vector x. ! ! The L2 matrix norm of A*B = the L2 matrix norm of B for any matrix B. ! ! det ( A ) = +1 or -1. ! ! A is unimodular. ! ! All the eigenvalues of A have modulus 1. ! ! All singular values of A are 1. ! ! All entries of A are between -1 and 1. ! ! Discussion: ! ! Thanks to Eugene Petrov, B I Stepanov Institute of Physics, ! National Academy of Sciences of Belarus, for convincingly ! pointing out the severe deficiencies of an earlier version of ! this routine. ! ! Essentially, the computation involves saving the Q factor of the ! QR factorization of a matrix whose entries are normally distributed. ! However, it is only necessary to generate this matrix a column at ! a time, since it can be shown that when it comes time to annihilate ! the subdiagonal elements of column K, these (transformed) elements of ! column K are still normally distributed random values. Hence, there ! is no need to generate them at the beginning of the process and ! transform them K-1 times. ! ! For computational efficiency, the individual Householder transformations ! could be saved, as recommended in the reference, instead of being ! accumulated into an explicit matrix format. ! ! Licensing: ! ! This code is distributed under the MIT license. ! ! Modified: ! ! 26 March 2000 ! ! Author: ! ! John Burkardt ! ! Reference: ! ! Pete Stewart, ! Efficient Generation of Random Orthogonal Matrices With an Application ! to Condition Estimators, ! SIAM Journal on Numerical Analysis, ! Volume 17, Number 3, June 1980, pages 403-409. ! ! Input: ! ! integer N, the order of the matrix. ! ! integer KEY, a seed for the random number generator. ! ! Output: ! ! real ( kind = rk ) A(N,N), the matrix. ! implicit none integer, parameter :: rk = kind ( 1.0D+00 ) integer n real ( kind = rk ) a(n,n) integer i integer j integer key real ( kind = rk ) r8_normal_01 real ( kind = rk ) v(n) real ( kind = rk ) x(n) call random_seed_initialize ( key ) ! ! Start with A = the identity matrix. ! do i = 1, n do j = 1, n if ( i == j ) then a(i,j) = 1.0D+00 else a(i,j) = 0.0D+00 end if end do end do ! ! Now behave as though we were computing the QR factorization of ! some other random matrix. Generate the N elements of the first column, ! compute the Householder matrix H1 that annihilates the subdiagonal elements, ! and set A := A * H1' = A * H. ! ! On the second step, generate the lower N-1 elements of the second column, ! compute the Householder matrix H2 that annihilates them, ! and set A := A * H2' = A * H2 = H1 * H2. ! ! On the N-1 step, generate the lower 2 elements of column N-1, ! compute the Householder matrix HN-1 that annihilates them, and ! and set A := A * H(N-1)' = A * H(N-1) = H1 * H2 * ... * H(N-1). ! This is our random orthogonal matrix. ! do j = 1, n - 1 ! ! Set the vector that represents the J-th column to be annihilated. ! x(1:j-1) = 0.0D+00 do i = j, n x(i) = r8_normal_01 ( ) end do ! ! Compute the vector V that defines a Householder transformation matrix ! H(V) that annihilates the subdiagonal elements of X. ! call r8vec_house_column ( n, x, j, v ) ! ! Postmultiply the matrix A by H'(V) = H(V). ! call r8mat_house_axh ( n, a, v, a ) end do return end subroutine orthogonal_random_determinant ( n, seed, determinant ) !*****************************************************************************80 ! !! orthogonal_random_determinant(): determinant of the orthogonal_random matrix. ! ! Licensing: ! ! This code is distributed under the MIT license. ! ! Modified: ! ! 17 June 2011 ! ! Author: ! ! John Burkardt ! ! Input: ! ! integer N, the order of the matrix. ! ! integer SEED, a seed for the random number ! generator. ! ! Output: ! ! real ( kind = rk ) DETERMINANT, the determinant. ! implicit none integer, parameter :: rk = kind ( 1.0D+00 ) integer n real ( kind = rk ) determinant integer seed call i4_fake_use ( n ) call i4_fake_use ( seed ) determinant = 1.0D+00 return end subroutine orthogonal_random_inverse ( n, seed, a ) !*****************************************************************************80 ! !! orthogonal_random_inverse() returns the inverse of the orthogonal_random matrix. ! ! Discussion: ! ! This routine will only work properly if the input value of SEED ! is exactly the same as the value used to generate the original matrix. ! ! Licensing: ! ! This code is distributed under the MIT license. ! ! Modified: ! ! 27 October 2007 ! ! Author: ! ! John Burkardt ! ! Input: ! ! integer N, the order of the matrix. ! ! integer SEED, a seed for the random number generator. ! ! Output: ! ! real ( kind = rk ) A(N,N), the matrix. ! ! integer SEED, an updated seed. ! implicit none integer, parameter :: rk = kind ( 1.0D+00 ) integer n real ( kind = rk ) a(n,n) integer seed call orthogonal_random_matrix ( n, seed, a ) return end subroutine orthogonal_symmetric_matrix ( n, a ) !*****************************************************************************80 ! !! orthogonal_symmetric_matrix() returns the orthogonal_symmetric matrix. ! ! Formula: ! ! A(I,J) = sqrt ( 2 ) * sin ( I * J * pi / ( N + 1 ) ) / sqrt ( N + 1 ) ! ! Example: ! ! N = 5 ! ! 0.326019 0.548529 0.596885 0.455734 0.169891 ! 0.548529 0.455734 -0.169891 -0.596885 -0.326019 ! 0.596885 -0.169891 -0.548529 0.326019 0.455734 ! 0.455734 -0.596885 0.326019 0.169891 -0.548528 ! 0.169891 -0.326019 0.455734 -0.548528 0.596885 ! ! Properties: ! ! A is orthogonal: A' * A = A * A' = I. ! ! A is symmetric: A' = A. ! ! A is not positive definite (unless N = 1 ). ! ! Because A is symmetric, it is normal. ! ! Because A is symmetric, its eigenvalues are real. ! ! Because A is orthogonal, its eigenvalues have unit norm. ! ! Only +1 and -1 can be eigenvalues of A. ! ! Because A is normal, it is diagonalizable. ! ! A is involutory: A * A = I. ! ! If N is even, trace ( A ) = 0; if N is odd, trace ( A ) = 1. ! ! LAMBDA(1:(N+1)/2) = 1; LAMBDA((N+1)/2+1:N) = -1. ! ! A is the left and right eigenvector matrix for the ! second difference matrix. ! ! Licensing: ! ! This code is distributed under the MIT license. ! ! Modified: ! ! 28 May 2002 ! ! Author: ! ! John Burkardt ! ! Reference: ! ! Morris Newman, John Todd, ! The evaluation of matrix inversion programs, ! Journal of the Society for Industrial and Applied Mathematics, ! Volume 6, Number 4, pages 466-476, 1958. ! ! Input: ! ! integer N, the order of the matrix. ! ! Output: ! ! real ( kind = rk ) A(N,N), the matrix. ! implicit none integer, parameter :: rk = kind ( 1.0D+00 ) integer n real ( kind = rk ) a(n,n) real ( kind = rk ) angle integer i integer j real ( kind = rk ), parameter :: r8_pi = 3.141592653589793D+00 do i = 1, n do j = 1, n angle = 2.0D+00 * real ( i * j, kind = rk ) * r8_pi & / real ( 2 * n + 1, kind = rk ) a(i,j) = 2.0D+00 * sin ( angle ) / sqrt ( real ( 2 * n + 1, kind = rk ) ) end do end do return end subroutine orthogonal_symmetric_condition ( n, cond ) !*****************************************************************************80 ! !! orthogonal_symmetric_condition(): L1 condition of the orthogonal_symmetric matrix. ! ! Licensing: ! ! This code is distributed under the MIT license. ! ! Modified: ! ! 28 January 2015 ! ! Author: ! ! John Burkardt ! ! Input: ! ! integer N, the order of the matrix. ! ! Output: ! ! real ( kind = rk ) COND, the L1 condition. ! implicit none integer, parameter :: rk = kind ( 1.0D+00 ) integer n real ( kind = rk ) a_norm real ( kind = rk ) angle real ( kind = rk ) b_norm real ( kind = rk ) cond integer i integer j real ( kind = rk ), parameter :: r8_pi = 3.141592653589793D+00 a_norm = 0.0D+00 j = 1 do i = 1, n angle = 2.0D+00 * real ( i * j, kind = rk ) * r8_pi & / real ( 2 * n + 1, kind = rk ) a_norm = a_norm + 2.0D+00 * abs ( sin ( angle ) ) & / sqrt ( real ( 2 * n + 1, kind = rk ) ) end do b_norm = a_norm cond = a_norm * b_norm return end subroutine orthogonal_symmetric_determinant ( n, determ ) !*****************************************************************************80 ! !! orthogonal_symmetric_determinant(): determinant of the orthogonal_symmetric matrix. ! ! Licensing: ! ! This code is distributed under the MIT license. ! ! Modified: ! ! 17 October 2007 ! ! Author: ! ! John Burkardt ! ! Input: ! ! integer N, the order of the matrix. ! ! Output: ! ! real ( kind = rk ) DETERM, the determinant. ! implicit none integer, parameter :: rk = kind ( 1.0D+00 ) integer n real ( kind = rk ) determ call i4_fake_use ( n ) determ = 1.0D+00 return end subroutine orthogonal_symmetric_eigenvalues ( n, lambda ) !*****************************************************************************80 ! !! orthogonal_symmetric_eigenvalues(): eigenvalues of the orthogonal_symmetric matrix. ! ! Licensing: ! ! This code is distributed under the MIT license. ! ! Modified: ! ! 28 May 2002 ! ! Author: ! ! John Burkardt ! ! Input: ! ! integer N, the order of the matrix. ! ! Output: ! ! real ( kind = rk ) LAMBDA(N), the eigenvalues. ! implicit none integer, parameter :: rk = kind ( 1.0D+00 ) integer n real ( kind = rk ) lambda(n) lambda(1:(n+1)/2) = +1.0D+00 lambda((n+1)/2+1:n) = -1.0D+00 return end subroutine orthogonal_symmetric_inverse ( n, a ) !*****************************************************************************80 ! !! orthogonal_symmetric_inverse(): inverse of the orthogonal_symmetric matrix. ! ! Licensing: ! ! This code is distributed under the MIT license. ! ! Modified: ! ! 17 October 2007 ! ! Author: ! ! John Burkardt ! ! Input: ! ! integer N, the order of the matrix. ! ! Output: ! ! real ( kind = rk ) A(N,N), the matrix. ! implicit none integer, parameter :: rk = kind ( 1.0D+00 ) integer n real ( kind = rk ) a(n,n) call orthogonal_symmetric_matrix ( n, a ) return end subroutine oto_matrix ( m, n, a ) !*****************************************************************************80 ! !! oto_matrix() returns the OTO matrix. ! ! Discussion: ! ! The name is meant to suggest "One, Two, One". ! ! Example: ! ! N = 5 ! ! 2 1 . . . ! 1 2 1 . . ! . 1 2 1 . ! . . 1 2 1 ! . . . 1 2 ! ! Properties: ! ! A is banded, with bandwidth 3. ! ! A is tridiagonal. ! ! Because A is tridiagonal, it has property A (bipartite). ! ! A is integral: int ( A ) = A. ! ! A is Toeplitz: constant along diagonals. ! ! A is symmetric: A' = A. ! ! Because A is symmetric, it is normal. ! ! Because A is normal, it is diagonalizable. ! ! A is persymmetric: A(I,J) = A(N+1-J,N+1-I). ! ! A is weakly diagonally dominant, but not strictly diagonally dominant. ! ! The family of matrices is nested as a function of N. ! ! Licensing: ! ! This code is distributed under the MIT license. ! ! Modified: ! ! 05 November 2007 ! ! Author: ! ! John Burkardt ! ! Input: ! ! integer M, N, the order of the matrix. ! ! Output: ! ! real ( kind = rk ) A(M,N), the matrix. ! implicit none integer, parameter :: rk = kind ( 1.0D+00 ) integer m integer n real ( kind = rk ) a(m,n) integer i integer j do i = 1, m do j = 1, n if ( j == i - 1 ) then a(i,j) = 1.0D+00 else if ( j == i ) then a(i,j) = 2.0D+00 else if ( j == 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 ) !*****************************************************************************80 ! !! oto_condition() returns the L1 condition of the OTO matrix. ! ! Discussion: ! ! I knew it had to be possible to work out this condition number! ! ! Licensing: ! ! This code is distributed under the MIT license. ! ! Modified: ! ! 14 March 2015 ! ! Author: ! ! John Burkardt ! ! Input: ! ! integer N, the order of the matrix. ! ! Output: ! ! real ( kind = rk ) VALUE, the L1 condition number. ! implicit none integer, parameter :: rk = kind ( 1.0D+00 ) real ( kind = rk ) a_norm real ( kind = rk ) b_norm integer i1 integer i2 integer n integer n1 integer n2 integer s real ( kind = rk ) value if ( n == 1 ) then a_norm = 2.0D+00 else if ( n == 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 do while ( i2 < n2 ) i2 = i2 + 1 s = s + i1 * i2 end do do while ( 1 < i1 ) i1 = i1 - 1 s = s + i1 * i2 end do b_norm = real ( s, kind = rk ) / real ( n + 1, kind = rk ) value = a_norm * b_norm return end subroutine oto_determinant ( n, determ ) !*****************************************************************************80 ! !! oto_determinant() returns the determinant of the OTO matrix. ! ! Licensing: ! ! This code is distributed under the MIT license. ! ! Modified: ! ! 05 November 2007 ! ! Author: ! ! John Burkardt ! ! Input: ! ! integer N, the order of the matrix. ! ! Output: ! ! real ( kind = rk ) DETERM, the determinant of the matrix. ! implicit none integer, parameter :: rk = kind ( 1.0D+00 ) real ( kind = rk ) determ integer n determ = real ( n + 1, kind = rk ) return end subroutine oto_eigen_right ( n, a ) !*****************************************************************************80 ! !! oto_eigen_right() returns the right eigenvectors of the OTO matrix. ! ! Licensing: ! ! This code is distributed under the MIT license. ! ! Modified: ! ! 05 November 2007 ! ! Author: ! ! John Burkardt ! ! Input: ! ! integer N, the order of the matrix. ! ! Output: ! ! real ( kind = rk ) A(N,N), the right eigenvector matrix. ! implicit none integer, parameter :: rk = kind ( 1.0D+00 ) integer n real ( kind = rk ) a(n,n) real ( kind = rk ) angle integer i integer j real ( kind = rk ) r8_mop real ( kind = rk ), parameter :: r8_pi = 3.141592653589793D+00 do i = 1, n do j = 1, n angle = real ( i * j, kind = rk ) * r8_pi / real ( n + 1, kind = rk ) a(i,j) = r8_mop ( i + j ) & * sqrt ( 2.0D+00 / real ( n + 1, kind = rk ) ) * sin ( angle ) end do end do return end subroutine oto_eigenvalues ( n, lambda ) !*****************************************************************************80 ! !! oto_eigenvalues() returns the eigenvalues of the OTO matrix. ! ! Licensing: ! ! This code is distributed under the MIT license. ! ! Modified: ! ! 05 November 2007 ! ! Author: ! ! John Burkardt ! ! Input: ! ! integer N, the order of the matrix. ! ! Output: ! ! real ( kind = rk ) LAMBDA(N), the eigenvalues. ! implicit none integer, parameter :: rk = kind ( 1.0D+00 ) integer n real ( kind = rk ) angle integer i real ( kind = rk ) lambda(n) real ( kind = rk ), parameter :: r8_pi = 3.141592653589793D+00 do i = 1, n angle = real ( i, kind = rk ) * r8_pi / real ( 2 * ( n + 1 ), kind = rk ) lambda(i) = 4.0D+00 * ( sin ( angle ) ) ** 2 end do return end subroutine oto_inverse ( n, a ) !*****************************************************************************80 ! !! oto_inverse() returns the inverse of the OTO matrix. ! ! Formula: ! ! if ( I <= J ) ! A(I,J) = (-1)^(I+J) * I * (N-J+1) / (N+1) ! else ! A(I,J) = (-1)^(I+J) * J * (N-I+1) / (N+1) ! ! Example: ! ! N = 5 ! ! 0.8333 -0.6667 0.5000 -0.3333 0.1667 ! -0.6667 1.3333 -1.0000 0.6667 -0.3333 ! 0.5000 -1.0000 1.5000 -1.0000 0.5000 ! -0.3333 0.6667 -1.0000 1.3333 -0.6667 ! 0.1667 -0.3333 0.5000 -0.6667 0.8333 ! ! Licensing: ! ! This code is distributed under the MIT license. ! ! Modified: ! ! 08 November 2007 ! ! Author: ! ! John Burkardt ! ! Input: ! ! integer N, the order of the matrix. ! ! Output: ! ! real ( kind = rk ) A(N,N), the matrix. ! implicit none integer, parameter :: rk = kind ( 1.0D+00 ) integer n real ( kind = rk ) a(n,n) integer i integer j real ( kind = rk ) r8_mop do i = 1, n do j = 1, n if ( i <= j ) then a(i,j) = r8_mop ( i + j ) & * real ( i * ( n - j + 1 ), kind = rk ) / real ( n + 1, kind = rk ) else a(i,j) = r8_mop ( i + j ) & * real ( j * ( n - i + 1 ), kind = rk ) / real ( n + 1, kind = rk ) end if end do end do return end subroutine oto_llt ( n, a ) !*****************************************************************************80 ! !! oto_llt() returns the Cholesky factor of the OTO matrix. ! ! Example: ! ! N = 5 ! ! 1.4142 0 0 0 0 ! 0.7071 1.2247 0 0 0 ! 0 0.8165 1.1547 0 0 ! 0 0 0.8660 1.1180 0 ! 0 0 0 0.8944 1.0954 ! ! Licensing: ! ! This code is distributed under the MIT license. ! ! Modified: ! ! 09 April 2015 ! ! Author: ! ! John Burkardt ! ! Input: ! ! integer N, the order of the matrix. ! ! Output: ! ! real ( kind = rk ) A(N,N), the matrix. ! implicit none integer, parameter :: rk = kind ( 1.0D+00 ) integer n real ( kind = rk ) a(n,n) integer i a(1:n,1:n) = 0.0D+00 do i = 1, n a(i,i) = sqrt ( real ( i + 1, kind = rk ) / real ( i, kind = rk ) ) end do do i = 2, n a(i,i-1) = sqrt ( real ( i - 1, kind = rk ) / real ( i, kind = rk ) ) end do return end subroutine oto_lu ( n, l, u ) !*****************************************************************************80 ! !! oto_lu() returns the LU factors of the OTO matrix. ! ! Licensing: ! ! This code is distributed under the MIT license. ! ! Modified: ! ! 28 October 2021 ! ! Author: ! ! John Burkardt ! ! Input: ! ! integer N, the order of the matrix. ! ! Output: ! ! real ( kind = rk ) L(N,N), U(N,N), the factors. ! implicit none integer, parameter :: rk = kind ( 1.0D+00 ) integer n integer i integer j real ( kind = rk ) l(n,n) real ( kind = rk ) u(n,n) do j = 1, n do i = 1, n if ( i == j ) then l(i,j) = 1.0D+00 else if ( i == j + 1 ) then l(i,j) = real ( j, kind = rk ) / real ( j + 1, kind = rk ) else l(i,j) = 0.0D+00 end if end do end do do j = 1, n do i = 1, n if ( i == j ) then u(i,j) = real ( i + 1, kind = rk ) / real ( i, kind = rk ) else if ( i == 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 oto_plu ( n, p, l, u ) !*****************************************************************************80 ! !! oto_plu() returns the PLU factors of the OTO matrix. ! ! Licensing: ! ! This code is distributed under the MIT license. ! ! Modified: ! ! 17 August 2008 ! ! Author: ! ! John Burkardt ! ! Input: ! ! integer N, the order of the matrix. ! ! Output: ! ! real ( kind = rk ) P(N,N), L(N,N), U(N,N), the PLU factors. ! implicit none integer, parameter :: rk = kind ( 1.0D+00 ) integer n integer i integer j real ( kind = rk ) l(n,n) real ( kind = rk ) p(n,n) real ( kind = rk ) u(n,n) do j = 1, n do i = 1, n if ( i == 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 == j ) then l(i,j) = 1.0D+00 else if ( i == j + 1 ) then l(i,j) = real ( j, kind = rk ) / real ( j + 1, kind = rk ) else l(i,j) = 0.0D+00 end if end do end do do j = 1, n do i = 1, n if ( i == j ) then u(i,j) = real ( i + 1, kind = rk ) / real ( i, kind = rk ) else if ( i == 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_matrix ( a ) !*****************************************************************************80 ! !! parlett_matrix() returns the PARLETT matrix. ! ! Formula: ! ! N = 100 ! ! if ( I < J ) ! if ( I = 1 and J = 2 ) ! A(I,J) = 40 / 102 ! else if ( I = 1 and J = 100 ) ! A(I,J) = 40 ! else ! A(I,J) = 0 ! else if ( I = J ) ! A(I,J) = 101 - I ! else if ( J < I ) ! A(I,J) = (-1)^(I+J+1) * 40 / ( I + J - 2 ) ! ! Example: ! ! 100.00 0.39 0 0 0 ... 40.00 ! 40.00 99.00 0 0 0 ... 0 ! -20.00 13.33 98.00 0 0 ... 0 ! 13.33 -10.00 8.00 97.00 0 ... 0 ! -10.00 8.00 -6.67 5.71 96.00 ... 0 ! ... ... ... ... ... ... ... ! 0.40 -0.40 0.39 -0.39 0.38 ... 1.00 ! ! Properties: ! ! A is not symmetric: A' /= A. ! ! The eigenvalues of A are ! ! LAMBDA(I) = I. ! ! det ( A ) = 100! ! ! Licensing: ! ! This code is distributed under the MIT license. ! ! Modified: ! ! 15 April 1999 ! ! Author: ! ! John Burkardt ! ! Reference: ! ! Robert Gregory, David Karney, ! A Collection of Matrices for Testing Computational Algorithms, ! Wiley, 1969, ! ISBN: 0882756494, ! LC: QA263.G68. ! ! Joan Westlake, ! A Handbook of Numerical Matrix Inversion and Solution of ! Linear Equations, ! John Wiley, 1968, ! ISBN13: 978-0471936756, ! LC: QA263.W47. ! ! Output: ! ! real ( kind = rk ) A(100,100), the matrix. ! implicit none integer, parameter :: rk = kind ( 1.0D+00 ) integer, parameter :: n = 100 real ( kind = rk ) a(n,n) integer i integer j real ( kind = rk ) r8_mop do i = 1, n do j = 1, n if ( i < j ) then if ( i == 1 .and. j == 2 ) then a(i,j) = 40.0D+00 / 102.0D+00 else if ( i == 1 .and. j == 100 ) then a(i,j) = 40.0D+00 else a(i,j) = 0.0D+00 end if else if ( i == j ) then a(i,j) = 101.0D+00 - real ( i, kind = rk ) else if ( j < i ) then a(i,j) = r8_mop ( i + j + 1 ) * 40.0D+00 & / real ( i + j - 2, kind = rk ) end if end do end do return end subroutine parlett_eigenvalues ( lambda ) !*****************************************************************************80 ! !! parlett_eigenvalues() returns the eigenvalues of the PARLETT matrix. ! ! Licensing: ! ! This code is distributed under the MIT license. ! ! Modified: ! ! 15 April 1999 ! ! Author: ! ! John Burkardt ! ! Output: ! ! real ( kind = rk ) LAMBDA(100), the eigenvalues. ! implicit none integer, parameter :: rk = kind ( 1.0D+00 ) integer i real ( kind = rk ) lambda(100) do i = 1, 100 lambda(i) = real ( i, kind = rk ) end do return end subroutine parter_matrix ( m, n, a ) !*****************************************************************************80 ! !! parter_matrix() returns the PARTER matrix. ! ! Formula: ! ! A(I,J) = 1 / ( i - j + 0.5 ) ! ! Example: ! ! N = 5 ! ! 2 -2 -2/3 -2/5 -2/7 ! 2/3 2 -2 -2/3 -2/5 ! 2/5 2/3 2 -2 -2/3 ! 2/7 2/5 2/3 2 -2 ! 2/9 2/7 2/5 2/3 2 ! ! Properties: ! ! The diagonal entries are all 2, the first superdiagonals all -2. ! ! A is Toeplitz: constant along diagonals. ! ! A is generally not symmetric: A' /= A. ! ! A is persymmetric: A(I,J) = A(N+1-J,N+1-I). ! ! The PARTER matrix is a special case of the CAUCHY matrix. ! ! Most of the singular values are very close to Pi. ! ! The family of matrices is nested as a function of N. ! ! Licensing: ! ! This code is distributed under the MIT license. ! ! Modified: ! ! 15 April 1999 ! ! Author: ! ! John Burkardt ! ! Reference: ! ! Seymour Parter, ! On the distribution of the singular values of Toeplitz matrices, ! Linear Algebra and Applications, ! Volume 80, August 1986, pages 115-130. ! ! Evgeny Tyrtyshnikov, ! Cauchy-Toeplitz matrices and some applications, ! Linear Algebra and Applications, ! Volume 149, 15 April 1991, pages 1-18. ! ! Input: ! ! integer M, N, the order of the matrix. ! ! Output: ! ! real ( kind = rk ) A(M,N), the matrix. ! implicit none integer, parameter :: rk = kind ( 1.0D+00 ) integer m integer n real ( kind = rk ) a(m,n) integer i integer j do i = 1, m do j = 1, n a(i,j) = 1.0D+00 / ( real ( i - j, kind = rk ) + 0.5D+00 ) end do end do return end subroutine parter_determinant ( n, determ ) !*****************************************************************************80 ! !! parter_determinant() returns the determinant of the PARTER matrix. ! ! Licensing: ! ! This code is distributed under the MIT license. ! ! Modified: ! ! 23 May 2002 ! ! Author: ! ! John Burkardt ! ! Input: ! ! integer N, the order of the matrix. ! ! Output: ! ! real ( kind = rk ) DETERM, the determinant. ! implicit none integer, parameter :: rk = kind ( 1.0D+00 ) integer n real ( kind = rk ) bottom real ( kind = rk ) determ integer i integer j real ( kind = rk ) top top = 1.0D+00 do i = 1, n do j = i + 1, n top = top * real ( j - i, kind = rk ) * real ( i - j, kind = rk ) end do end do bottom = 1.0D+00 do i = 1, n do j = 1, n bottom = bottom * ( real ( i - j, kind = rk ) + 0.5D+00 ) end do end do determ = top / bottom return end subroutine parter_inverse ( n, a ) !*****************************************************************************80 ! !! parter_inverse() returns the inverse of the PARTER matrix. ! ! Example: ! ! N = 5 ! ! 0.3365 0.1923 0.1730 0.1923 0.3365 ! -0.1495 0.2563 0.1282 0.1196 0.1923 ! -0.0320 -0.1648 0.2472 0.1282 0.1730 ! -0.0128 -0.0366 -0.1648 0.2563 0.1923 ! -0.0053 -0.0128 -0.0320 -0.1495 0.3365 ! ! Licensing: ! ! This code is distributed under the MIT license. ! ! Modified: ! ! 23 May 2002 ! ! Author: ! ! John Burkardt ! ! Input: ! ! integer N, the order of the matrix. ! ! Output: ! ! real ( kind = rk ) A(N,N), the matrix. ! implicit none integer, parameter :: rk = kind ( 1.0D+00 ) integer n real ( kind = rk ) a(n,n) real ( kind = rk ) bot1 real ( kind = rk ) bot2 integer i integer j integer k real ( kind = rk ) 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 + real ( j - k, kind = rk ) ) & * ( 0.5D+00 + real ( k - i, kind = rk ) ) if ( k /= j ) then bot1 = bot1 * real ( j - k, kind = rk ) end if if ( k /= i ) then bot2 = bot2 * real ( k - i, kind = rk ) end if end do a(i,j) = top / ( ( 0.5D+00 + real ( j - i, kind = rk ) ) * bot1 * bot2 ) end do end do return end subroutine pascal1_matrix ( n, a ) !*****************************************************************************80 ! !! pascal1_matrix() returns the PASCAL1 matrix. ! ! Formula: ! ! if ( J = 1 ) then ! A(I,J) = 1 ! else if ( I = 0 ) then ! A(1,J) = 0 ! else ! A(I,J) = A(I-1,J) + A(I-1,J-1) ! ! Example: ! ! N = 5 ! ! 1 0 0 0 0 ! 1 1 0 0 0 ! 1 2 1 0 0 ! 1 3 3 1 0 ! 1 4 6 4 1 ! ! Properties: ! ! A is a "chunk" of the Pascal binomial combinatorial triangle. ! ! A is generally not symmetric: A' /= A. ! ! A is nonsingular. ! ! A is lower triangular. ! ! A is integral, therefore det ( A ) is integral, and ! det ( A ) * inverse ( A ) is integral. ! ! det ( A ) = 1. ! ! A is unimodular. ! ! LAMBDA(1:N) = 1. ! ! (0, 0, ..., 0, 1) is an eigenvector. ! ! The inverse of A is the same as A, except that entries in "odd" ! positions have changed sign: ! ! B(I,J) = (-1)^(I+J) * A(I,J) ! ! The product A*A' is a Pascal matrix ! of the sort created by subroutine PASCAL2. ! ! Let the matrix C have the same entries as A, except that ! the even columns are negated. Then Inverse(C) = C, and ! C' * C = the Pascal matrix created by PASCAL2. ! ! The family of matrices is nested as a function of N. ! ! Licensing: ! ! This code is distributed under the MIT license. ! ! Modified: ! ! 15 April 1999 ! ! Author: ! ! John Burkardt ! ! Reference: ! ! Robert Gregory, David Karney, ! A Collection of Matrices for Testing Computational Algorithms, ! Wiley, 1969, ! ISBN: 0882756494, ! LC: QA263.68 ! ! Input: ! ! integer N, the order of the matrix. ! ! Output: ! ! real ( kind = rk ) A(N,N), the matrix. ! implicit none integer, parameter :: rk = kind ( 1.0D+00 ) integer n real ( kind = rk ) a(n,n) integer i integer j do i = 1, n do j = 1, n if ( j == 1 ) then a(i,j) = 1.0D+00 else if ( i == 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 ) !*****************************************************************************80 ! !! pascal1_condition() returns the L1 condition of the PASCAL1 matrix. ! ! Licensing: ! ! This code is distributed under the MIT license. ! ! Modified: ! ! 13 March 2015 ! ! Author: ! ! John Burkardt ! ! Input: ! ! integer N, the order of the matrix. ! ! Output: ! ! real ( kind = rk ) VALUE, the L1 condition. ! implicit none integer, parameter :: rk = kind ( 1.0D+00 ) real ( kind = rk ) a_norm real ( kind = rk ) b_norm integer n integer nhalf real ( kind = rk ) r8_choose real ( kind = rk ) 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 ) !*****************************************************************************80 ! !! pascal1_determinant() returns the determinant of the PASCAL1 matrix. ! ! Licensing: ! ! This code is distributed under the MIT license. ! ! Modified: ! ! 08 October 2007 ! ! Author: ! ! John Burkardt ! ! Input: ! ! integer N, the order of the matrix. ! ! Output: ! ! real ( kind = rk ) DETERM, the determinant. ! implicit none integer, parameter :: rk = kind ( 1.0D+00 ) real ( kind = rk ) determ integer n call i4_fake_use ( n ) determ = 1.0D+00 return end subroutine pascal1_eigenvalues ( n, lambda ) !*****************************************************************************80 ! !! pascal1_eigenvalues() returns eigenvalues of the PASCAL1 matrix. ! ! Licensing: ! ! This code is distributed under the MIT license. ! ! Modified: ! ! 21 May 2002 ! ! Author: ! ! John Burkardt ! ! Input: ! ! integer N, the order of the matrix. ! ! Output: ! ! real ( kind = rk ) LAMBDA(N), the eigenvalues. ! implicit none integer, parameter :: rk = kind ( 1.0D+00 ) integer n real ( kind = rk ) lambda(n) lambda(1:n) = 1.0D+00 return end subroutine pascal1_inverse ( n, a ) !*****************************************************************************80 ! !! pascal1_inverse() returns the inverse of the PASCAL1 matrix. ! ! Formula: ! ! if ( J = 1 ) ! A(I,J) = (-1)^(I+J) ! else if ( I = 1 ) ! A(I,J) = 0 ! else ! A(I,J) = A(I-1,J) - A(I,J-1) ! ! Example: ! ! N = 5 ! ! 1 0 0 0 0 ! -1 1 0 0 0 ! 1 -2 1 0 0 ! -1 3 -3 1 0 ! 1 -4 6 -4 1 ! ! Properties: ! ! A is nonsingular. ! ! A is lower triangular. ! ! A is integral, therefore det ( A ) is integral, and ! det ( A ) * inverse ( A ) is integral. ! ! det ( A ) = 1. ! ! A is unimodular. ! ! LAMBDA(1:N) = 1. ! ! (0, 0, ..., 0, 1) is an eigenvector. ! ! The inverse of A is the same as A, except that entries in "odd" ! positions have changed sign: ! ! B(I,J) = (-1)^(I+J) * A(I,J) ! ! Licensing: ! ! This code is distributed under the MIT license. ! ! Modified: ! ! 02 June 2008 ! ! Author: ! ! John Burkardt ! ! Input: ! ! integer N, the order of the matrix. ! ! Output: ! ! real ( kind = rk ) A(N,N), the matrix. ! implicit none integer, parameter :: rk = kind ( 1.0D+00 ) integer n real ( kind = rk ) a(n,n) integer i integer j real ( kind = rk ) r8_mop do i = 1, n do j = 1, n if ( j == 1 ) then a(i,j) = r8_mop ( i + j ) else if ( i == 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_matrix ( n, a ) !*****************************************************************************80 ! !! pascal2_matrix() returns the PASCAL2 matrix. ! ! Discussion: ! ! See page 172 of the Todd reference. ! ! Formula: ! ! If ( I = 1 or J = 1 ) ! A(I,J) = 1 ! else ! A(I,J) = A(I-1,J) + A(I,J-1) ! ! Example: ! ! N = 5 ! ! 1 1 1 1 1 ! 1 2 3 4 5 ! 1 3 6 10 15 ! 1 4 10 20 35 ! 1 5 15 35 70 ! ! Properties: ! ! A is a "chunk" of the Pascal binomial combinatorial triangle. ! ! A is positive definite. ! ! A is symmetric: A' = A. ! ! Because A is symmetric, it is normal. ! ! Because A is normal, it is diagonalizable. ! ! A is integral, therefore det ( A ) is integral, and ! det ( A ) * inverse ( A ) is integral. ! ! A is nonsingular. ! ! det ( A ) = 1. ! ! A is unimodular. ! ! Eigenvalues of A occur in reciprocal pairs. ! ! The condition number of A is approximately 16^N / ( N*PI ). ! ! The elements of the inverse of A are integers. ! ! A(I,J) = (I+J-2)! / ( (I-1)! * (J-1)! ) ! ! The Cholesky factor of A is a lower triangular matrix R, ! such that A = R * R'. The matrix R is a Pascal ! matrix of the type generated by subroutine PASCAL. In other ! words, PASCAL2 = PASCAL * PASCAL'. ! ! If the (N,N) entry of A is decreased by 1, the matrix is singular. ! ! Gregory and Karney consider a generalization of this matrix as ! their test matrix 3.7, in which every element is multiplied by a ! nonzero constant K. They point out that if K is the reciprocal of ! an integer, then the inverse matrix has all integer entries. ! ! The family of matrices is nested as a function of N. ! ! Licensing: ! ! This code is distributed under the MIT license. ! ! Modified: ! ! 15 April 1999 ! ! Author: ! ! John Burkardt ! ! Reference: ! ! Robert Brawer, Magnus Pirovino, ! The linear algebra of the Pascal matrix, ! Linear Algebra and Applications, ! Volume 174, 1992, pages 13-23. ! ! Robert Gregory, David Karney, ! A Collection of Matrices for Testing Computational Algorithms, ! Wiley, 1969, ! ISBN: 0882756494, ! LC: QA263.68 ! ! Nicholas Higham, ! Accuracy and Stability of Numerical Algorithms, ! Society for Industrial and Applied Mathematics, ! Philadelphia, PA, USA, 1996; section 26.4. ! ! Sam Karlin, ! Total Positivity, Volume 1, ! Stanford University Press, 1968. ! ! Morris Newman, John Todd, ! The evaluation of matrix inversion programs, ! Journal of the Society for Industrial and Applied Mathematics, ! Volume 6, Number 4, pages 466-476, 1958. ! ! Heinz Rutishauser, ! On test matrices, ! Programmation en Mathematiques Numeriques, ! Centre National de la Recherche Scientifique, ! 1966, pages 349-365. ! ! John Todd, ! Basic Numerical Mathematics, ! Volume 2: Numerical Algebra, ! Birkhauser, 1980, ! ISBN: 0817608117, ! LC: QA297.T58. ! ! HW Turnbull, ! The Theory of Determinants, Matrices, and Invariants, ! Blackie, 1929. ! ! Input: ! ! integer N, the order of the matrix. ! ! Output: ! ! real ( kind = rk ) A(N,N), the matrix. ! implicit none integer, parameter :: rk = kind ( 1.0D+00 ) integer n real ( kind = rk ) a(n,n) integer i integer j do j = 1, n do i = 1, n if ( i == 1 ) then a(i,j) = 1.0D+00 else if ( j == 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 ) !*****************************************************************************80 ! !! pascal2_determinant() returns the determinant of the PASCAL2 matrix. ! ! Licensing: ! ! This code is distributed under the MIT license. ! ! Modified: ! ! 08 October 2007 ! ! Author: ! ! John Burkardt ! ! Input: ! ! integer N, the order of the matrix. ! ! Output: ! ! real ( kind = rk ) DETERM, the determinant. ! implicit none integer, parameter :: rk = kind ( 1.0D+00 ) real ( kind = rk ) determ integer n call i4_fake_use ( n ) determ = 1.0D+00 return end subroutine pascal2_inverse ( n, a ) !*****************************************************************************80 ! !! pascal2_inverse() returns the inverse of the PASCAL2 matrix. ! ! Formula: ! ! A(I,J) = sum ( max(I,J) <= K <= N ) ! (-1)^(J+I) * COMB(K-1,I-1) * COMB(K-1,J-1) ! ! Example: ! ! N = 5 ! ! 5 -10 10 -5 1 ! -10 30 -35 19 -4 ! 10 -35 46 -27 6 ! -5 19 -27 17 -4 ! 1 -4 6 -4 1 ! ! Properties: ! ! A is symmetric: A' = A. ! ! Because A is symmetric, it is normal. ! ! Because A is normal, it is diagonalizable. ! ! A is integral, therefore det ( A ) is integral, and ! det ( A ) * inverse ( A ) is integral. ! ! The first row sums to 1, the others to 0. ! ! The first column sums to 1, the others to 0. ! ! Licensing: ! ! This code is distributed under the MIT license. ! ! Modified: ! ! 02 June 2008 ! ! Author: ! ! John Burkardt ! ! Input: ! ! integer N, the order of the matrix. ! ! Output: ! ! real ( kind = rk ) A(N,N), the matrix. ! implicit none integer, parameter :: rk = kind ( 1.0D+00 ) integer n real ( kind = rk ) a(n,n) integer i integer j integer k integer klo real ( kind = rk ) r8_choose real ( kind = rk ) 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 ) !*****************************************************************************80 ! !! pascal2_llt() returns the Cholesky factor of the PASCAL2 matrix. ! ! Example: ! ! N = 5 ! ! 1 0 0 0 0 ! 1 1 0 0 0 ! 1 2 1 0 0 ! 1 3 3 1 0 ! 1 4 6 4 1 ! ! Licensing: ! ! This code is distributed under the MIT license. ! ! Modified: ! ! 26 May 2002 ! ! Author: ! ! John Burkardt ! ! Input: ! ! integer N, the order of the matrix. ! ! Output: ! ! real ( kind = rk ) A(N,N), the matrix. ! implicit none integer, parameter :: rk = kind ( 1.0D+00 ) integer n real ( kind = rk ) a(n,n) call pascal1_matrix ( n, a ) return end subroutine pascal2_lu ( n, l, u ) !*****************************************************************************80 ! !! pascal2_lu() returns the LU factors of the PASCAL2 matrix. ! ! Licensing: ! ! This code is distributed under the MIT license. ! ! Modified: ! ! 28 October 2021 ! ! Author: ! ! John Burkardt ! ! Input: ! ! integer N, the order of the matrix. ! ! Output: ! ! real ( kind = rk ) L(N,N), U(N,N), the factors. ! implicit none integer, parameter :: rk = kind ( 1.0D+00 ) integer n real ( kind = rk ) l(n,n) real ( kind = rk ) u(n,n) call pascal1_matrix ( n, l ) u(1:n,1:n) = transpose ( l(1:n,1:n) ) return end subroutine pascal2_plu ( n, p, l, u ) !*****************************************************************************80 ! !! pascal2_plu() returns the PLU factors of the PASCAL2 matrix. ! ! Licensing: ! ! This code is distributed under the MIT license. ! ! Modified: ! ! 17 August 2008 ! ! Author: ! ! John Burkardt ! ! Input: ! ! integer N, the order of the matrix. ! ! Output: ! ! real ( kind = rk ) P(N,N), L(N,N), U(N,N), the PLU factors. ! implicit none integer, parameter :: rk = kind ( 1.0D+00 ) integer n integer i integer j real ( kind = rk ) l(n,n) real ( kind = rk ) p(n,n) real ( kind = rk ) u(n,n) do j = 1, n do i = 1, n if ( i == j ) then p(i,j) = 1.0D+00 else p(i,j) = 0.0D+00 end if end do end do call pascal1_matrix ( n, l ) u(1:n,1:n) = transpose ( l(1:n,1:n) ) return end subroutine pascal3_matrix ( n, alpha, a ) !*****************************************************************************80 ! !! pascal3_matrix() returns the PASCAL3 matrix. ! ! Formula: ! ! if ( J = 1 ) then ! A(I,J) = 1 ! else if ( I = 0 ) then ! A(1,J) = 0 ! else ! A(I,J) = ALPHA * A(I-1,J) + A(I-1,J-1) ) ! ! Example: ! ! N = 5, ALPHA = 2 ! ! 1 0 0 0 0 ! 2 1 0 0 0 ! 4 4 1 0 0 ! 8 12 6 1 0 ! 16 32 24 8 1 ! ! Properties: ! ! A is generally not symmetric: A' /= A. ! ! A[0] is the identity matrix. ! ! A[1] is the usual (lower triangular) Pascal matrix. ! ! A is nonsingular. ! ! A is lower triangular. ! ! If ALPHA is integral, then A is integral. ! If A is integral, then det ( A ) is integral, and ! det ( A ) * inverse ( A ) is integral. ! ! det ( A ) = 1. ! ! A is unimodular. ! ! LAMBDA(1:N) = 1. ! ! (0, 0, ..., 0, 1) is an eigenvector. ! ! The inverse of A[X] is A[-X]. ! ! A[ALPHA] * A[BETA] = A[ALPHA*BETA]. ! ! A[1/2] is the "square root" of A[1], and so on. ! ! The family of matrices is nested as a function of N. ! ! Licensing: ! ! This code is distributed under the MIT license. ! ! Modified: ! ! 13 October 2000 ! ! Author: ! ! John Burkardt ! ! Reference: ! ! Gregory Call, Daniel Velleman, ! Pascal's Matrices, ! American Mathematical Monthly, ! Volume 100, Number 4, April 1993, pages 372-376. ! ! Input: ! ! integer N, the order of the matrix. ! ! real ( kind = rk ) ALPHA, the parameter. ! ! Output: ! ! real ( kind = rk ) A(N,N), the matrix. ! implicit none integer, parameter :: rk = kind ( 1.0D+00 ) integer n real ( kind = rk ) a(n,n) real ( kind = rk ) alpha integer i integer j do i = 1, n do j = 1, n if ( i == 1 ) then if ( j == 1 ) then a(i,j) = 1.0D+00 else a(i,j) = 0.0D+00 end if else if ( j == 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 ) !*****************************************************************************80 ! !! pascal3_condition() returns the L1 condition of the PASCAL3 matrix. ! ! Licensing: ! ! This code is distributed under the MIT license. ! ! Modified: ! ! 04 April 2015 ! ! Author: ! ! John Burkardt ! ! Input: ! ! integer N, the order of the matrix. ! ! real ( kind = rk ) ALPHA, the parameter. ! ! Output: ! ! real ( kind = rk ) VALUE, the L1 condition. ! implicit none integer, parameter :: rk = kind ( 1.0D+00 ) integer n real ( kind = rk ) a(n,n) real ( kind = rk ) a_norm real ( kind = rk ) alpha real ( kind = rk ) b_norm real ( kind = rk ) r8mat_norm_l1 real ( kind = rk ) value call pascal3_matrix ( 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, value ) !*****************************************************************************80 ! !! pascal3_determinant() returns the determinant of the PASCAL3 matrix. ! ! Licensing: ! ! This code is distributed under the MIT license. ! ! Modified: ! ! 08 October 2007 ! ! Author: ! ! John Burkardt ! ! Input: ! ! integer N, the order of the matrix. ! ! real ( kind = rk ) ALPHA, the parameter. ! ! Output: ! ! real ( kind = rk ) VALUE, the determinant. ! implicit none integer, parameter :: rk = kind ( 1.0D+00 ) real ( kind = rk ) alpha integer n real ( kind = rk ) value call r8_fake_use ( alpha ) call i4_fake_use ( n ) value = 1.0D+00 return end subroutine pascal3_inverse ( n, alpha, a ) !*****************************************************************************80 ! !! pascal3_inverse() returns the inverse of the PASCAL3 matrix. ! ! Example: ! ! N = 5 ! ! 1 0 0 0 0 ! -2 1 0 0 0 ! 4 -4 1 0 0 ! -8 12 -6 1 0 ! 16 -32 24 -8 1 ! ! Licensing: ! ! This code is distributed under the MIT license. ! ! Modified: ! ! 28 May 2002 ! ! Author: ! ! John Burkardt ! ! Input: ! ! integer N, the order of the matrix. ! ! real ( kind = rk ) ALPHA, the parameter. ! ! Output: ! ! real ( kind = rk ) A(N,N), the matrix. ! implicit none integer, parameter :: rk = kind ( 1.0D+00 ) integer n real ( kind = rk ) a(n,n) real ( kind = rk ) alpha integer i integer j do i = 1, n do j = 1, n if ( i == 1 ) then if ( j == 1 ) then a(i,j) = 1.0D+00 else a(i,j) = 0.0D+00 end if else if ( j == 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 pei_matrix ( alpha, n, a ) !*****************************************************************************80 ! !! pei_matrix() returns the PEI matrix. ! ! Formula: ! ! if ( I = J ) then ! A(I,J) = 1.0 + ALPHA ! else ! A(I,J) = 1.0 ! ! Example: ! ! ALPHA = 2, N = 5 ! ! 3 1 1 1 1 ! 1 3 1 1 1 ! 1 1 3 1 1 ! 1 1 1 3 1 ! 1 1 1 1 3 ! ! Properties: ! ! A is symmetric: A' = A. ! ! Because A is symmetric, it is normal. ! ! Because A is normal, it is diagonalizable. ! ! A is persymmetric: A(I,J) = A(N+1-J,N+1-I). ! ! A is positive definite for 0 < ALPHA. ! ! A is Toeplitz: constant along diagonals. ! ! A is a circulant matrix: each row is shifted once to get the next row. ! ! A is singular if and only if ALPHA = 0 or ALPHA = -N. ! ! A becomes more ill-conditioned as ALPHA approaches 0. ! ! The condition number under the spectral norm is ! abs ( ( ALPHA + N ) / ALPHA ) ! ! The eigenvalues of A are ! ! LAMBDA(1:N-1) = ALPHA ! LAMBDA(N) = ALPHA + N ! ! A has constant row sum of ALPHA + N. ! ! Because it has a constant row sum of ALPHA + N, ! A has an eigenvalue of ALPHA + N, and ! a right eigenvector of ( 1, 1, 1, ..., 1 ). ! ! A has constant column sum of ALPHA + N. ! ! Because it has a constant column sum of ALPHA + N, ! A has an eigenvalue of ALPHA + N, and ! a left eigenvector of ( 1, 1, 1, ..., 1 ). ! ! The eigenvectors are: ! ! V1 = 1 / sqrt ( N ) * ( 1, 1, 1, ... , 1 ) ! VR = 1 / sqrt ( R * (R-1) ) * ( 1, 1, 1, ... 1, -R+1, 0, 0, 0, ... 0 ) ! ! where the "-R+1" occurs at index R. ! ! det ( A ) = ALPHA^(N-1) * ( N + ALPHA ). ! ! The family of matrices is nested as a function of N. ! ! Licensing: ! ! This code is distributed under the MIT license. ! ! Modified: ! ! 15 April 1999 ! ! Author: ! ! John Burkardt ! ! Reference: ! ! Morris Newman, John Todd, ! Example A3, ! The evaluation of matrix inversion programs, ! Journal of the Society for Industrial and Applied Mathematics, ! Volume 6, Number 4, pages 466-476, 1958. ! ! ML Pei, ! A test matrix for inversion procedures, ! Communications of the ACM, ! Volume 5, 1962, page 508. ! ! Joan Westlake, ! A Handbook of Numerical Matrix Inversion and Solution of ! Linear Equations, ! John Wiley, 1968, ! ISBN13: 978-0471936756, ! LC: QA263.W47. ! ! Input: ! ! real ( kind = rk ) ALPHA, the scalar that defines the Pei matrix. A ! typical value of ALPHA is 1.0. ! ! integer N, the order of the matrix. ! ! Output: ! ! real ( kind = rk ) A(N,N), the matrix. ! implicit none integer, parameter :: rk = kind ( 1.0D+00 ) integer n real ( kind = rk ) a(n,n) real ( kind = rk ) alpha integer i integer j do i = 1, n do j = 1, n if ( i == 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 ) !*****************************************************************************80 ! !! pei_condition() returns the L1 condition of the PEI matrix. ! ! Licensing: ! ! This code is distributed under the MIT license. ! ! Modified: ! ! 27 January 2015 ! ! Author: ! ! John Burkardt ! ! Input: ! ! real ( kind = rk ) ALPHA, the scalar that defines the Pei matrix. A ! typical value of ALPHA is 1.0. ! ! integer N, the order of the matrix. ! ! Output: ! ! real ( kind = rk ) COND, the L1 condition. ! implicit none integer, parameter :: rk = kind ( 1.0D+00 ) real ( kind = rk ) a_norm real ( kind = rk ) alpha real ( kind = rk ) b_norm real ( kind = rk ) cond integer n real ( kind = rk ) n_r8 n_r8 = real ( n, kind = rk ) 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 ) !*****************************************************************************80 ! !! pei_determinant() returns the determinant of the PEI matrix. ! ! Licensing: ! ! This code is distributed under the MIT license. ! ! Modified: ! ! 21 May 2002 ! ! Author: ! ! John Burkardt ! ! Input: ! ! real ( kind = rk ) ALPHA, the scalar that defines the Pei matrix. A ! typical value of ALPHA is 1.0. ! ! integer N, the order of the matrix. ! ! Output: ! ! real ( kind = rk ) DETERM, the determinant. ! implicit none integer, parameter :: rk = kind ( 1.0D+00 ) real ( kind = rk ) alpha real ( kind = rk ) determ integer n determ = alpha ** ( n - 1 ) * ( alpha + real ( n, kind = rk ) ) return end subroutine pei_eigen_right ( alpha, n, x ) !*****************************************************************************80 ! !! pei_eigen_right() returns the right eigenvectors of the PEI matrix. ! ! Licensing: ! ! This code is distributed under the MIT license. ! ! Modified: ! ! 25 November 2007 ! ! Author: ! ! John Burkardt ! ! Input: ! ! real ( kind = rk ) ALPHA, the scalar that defines A. ! ! integer N, the order of the matrix. ! ! Output: ! ! real ( kind = rk ) X(N,N), the right eigenvectors. ! implicit none integer, parameter :: rk = kind ( 1.0D+00 ) integer n real ( kind = rk ) alpha integer j real ( kind = rk ) x(n,n) call r8_fake_use ( alpha ) x(1:n,1:n) = 0.0D+00 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 pei_eigenvalues ( alpha, n, lambda ) !*****************************************************************************80 ! !! pei_eigenvalues() returns the eigenvalues of the PEI matrix. ! ! Licensing: ! ! This code is distributed under the MIT license. ! ! Modified: ! ! 21 May 2002 ! ! Author: ! ! John Burkardt ! ! Input: ! ! real ( kind = rk ) ALPHA, the scalar that defines the Pei matrix. A ! typical value of ALPHA is 1.0. ! ! integer N, the order of the matrix. ! ! Output: ! ! real ( kind = rk ) LAMBDA(N), the eigenvalues. ! implicit none integer, parameter :: rk = kind ( 1.0D+00 ) integer n real ( kind = rk ) alpha real ( kind = rk ) lambda(n) lambda(1:n-1) = alpha lambda(n) = alpha + real ( n, kind = rk ) return end subroutine pei_inverse ( alpha, n, a ) !*****************************************************************************80 ! !! pei_inverse() returns the inverse of the PEI matrix. ! ! Formula: ! ! if ( I = J ) ! A(I,J) = (ALPHA+N-1) / ( (ALPHA+1)*(ALPHA+N-1)-(N-1) ) ! else ! A(I,J) = -1 / ( (ALPHA+1)*(ALPHA+N-1)-(N-1) ) ! ! Example: ! ! ALPHA = 2, N = 5 ! ! 6 -1 -1 -1 -1 ! -1 6 -1 -1 -1 ! 1/14 * -1 -1 6 -1 -1 ! -1 -1 -1 6 -1 ! -1 -1 -1 -1 6 ! ! Properties: ! ! A is symmetric: A' = A. ! ! Because A is symmetric, it is normal. ! ! Because A is normal, it is diagonalizable. ! ! A is persymmetric: A(I,J) = A(N+1-J,N+1-I). ! ! A is a "combinatorial" matrix. See routine COMBIN. ! ! A is Toeplitz: constant along diagonals. ! ! A is a circulant matrix: each row is shifted once to get the next row. ! ! A has constant row sum. ! ! Because it has a constant row sum of 1 / ( ALPHA + N ), ! A has an eigenvalue of 1 / ( ALPHA + N ), and ! a right eigenvector of ( 1, 1, 1, ..., 1 ). ! ! A has constant column sum. ! ! Because it has constant column sum of 1 / ( ALPHA + N ), ! A has an eigenvalue of 1 / ( ALPHA + N ), and ! a left eigenvector of ( 1, 1, 1, ..., 1 ). ! ! The eigenvalues of A are ! LAMBDA(1:N-1) = 1 / ALPHA ! LAMBDA(N) = 1 / ( ALPHA + N ) ! ! Licensing: ! ! This code is distributed under the MIT license. ! ! Modified: ! ! 15 April 1999 ! ! Author: ! ! John Burkardt ! ! Reference: ! ! ML Pei, ! A test matrix for inversion procedures, ! Communications of the ACM, ! Volume 5, 1962, page 508. ! ! Input: ! ! real ( kind = rk ) ALPHA, the scalar that defines the inverse ! of the Pei matrix. ! ! integer N, the order of the matrix. ! ! Output: ! ! real ( kind = rk ) A(N,N), the matrix. ! implicit none integer, parameter :: rk = kind ( 1.0D+00 ) integer n real ( kind = rk ) a(n,n) real ( kind = rk ) alpha real ( kind = rk ) alpha1 real ( kind = rk ) beta1 real ( kind = rk ) bottom integer i integer j bottom = ( alpha + 1.0D+00 ) * & ( alpha + real ( n, kind = rk ) - 1.0D+00 ) - real ( n, kind = rk ) + 1.0D+00 if ( bottom == 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 + real ( n, kind = rk ) - 1.0D+00 ) / bottom beta1 = - 1.0D+00 / bottom do i = 1, n do j = 1, n if ( i == 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 ) !*****************************************************************************80 ! !! perm_check() checks that a vector represents a permutation. ! ! Discussion: ! ! The routine verifies that each of the integers from 1 ! to N occurs among the N entries of the permutation. ! ! Licensing: ! ! This code is distributed under the MIT license. ! ! Modified: ! ! 15 April 1999 ! ! Author: ! ! John Burkardt ! ! Input: ! ! integer N, the number of entries. ! ! integer P(N), the array to check. ! ! Output: ! ! integer IERROR, error flag. ! 0, the array does represent a permutation. ! nonzero, the array does not represent a permutation. The smallest ! missing value is equal to IERROR. ! implicit none integer, parameter :: rk = kind ( 1.0D+00 ) integer n integer i integer ierror integer ifind integer iseek integer p(n) ierror = 0 do iseek = 1, n ifind = 0 do i = 1, n if ( p(i) == iseek ) then ifind = i exit end if end do if ( ifind == 0 ) then ierror = iseek return end if end do return end subroutine perm_inverse ( n, p ) !*****************************************************************************80 ! !! perm_inverse() inverts a permutation "in place". ! ! Licensing: ! ! This code is distributed under the MIT license. ! ! Modified: ! ! 02 January 2006 ! ! Author: ! ! FORTRAN90 version by John Burkardt ! ! Input: ! ! integer N, the number of objects being permuted. ! ! integer P(N), the permutation, in standard index form. ! ! Output: ! ! integer P(N), the inverse permutation ! implicit none integer, parameter :: rk = kind ( 1.0D+00 ) integer n integer i integer i0 integer i1 integer i2 integer i4_sign integer ierror integer is integer p(n) if ( n <= 0 ) then write ( *, '(a)' ) ' ' write ( *, '(a)' ) 'PERM_INVERSE - Fatal error!' write ( *, '(a,i8)' ) ' Input value of N = ', n stop 1 end if call perm_check ( n, p, ierror ) is = 1 do i = 1, n i1 = p(i) do while ( i < i1 ) i2 = p(i1) p(i1) = -i2 i1 = i2 end do is = - i4_sign ( p(i) ) p(i) = is * abs ( p(i) ) end do do i = 1, n i1 = -p(i) if ( 0 <= i1 ) then i0 = i do i2 = p(i1) p(i1) = i0 if ( i2 < 0 ) then exit end if i0 = i1 i1 = i2 end do end if end do return end subroutine perm_mat_to_vec ( n, a, p ) !*****************************************************************************80 ! !! perm_mat_to_vec() returns a permutation from a permutation matrix. ! ! Example: ! ! N = 5 ! ! A = 0 1 0 0 0 ! 0 0 0 1 0 ! 1 0 0 0 0 ! 0 0 1 0 0 ! 0 0 0 0 1 ! ! p = ( 2, 4, 1, 3, 5 ) ! ! Licensing: ! ! This code is distributed under the MIT license. ! ! Modified: ! ! 21 May 2002 ! ! Author: ! ! John Burkardt ! ! Input: ! ! integer N, the order of the matrix. ! ! real ( kind = rk ) A(N,N), the permutation matrix. ! ! Output: ! ! integer P(N), a permutation of the indices 1 through ! N, which corresponds to the matrix. ! implicit none integer, parameter :: rk = kind ( 1.0D+00 ) integer n real ( kind = rk ) a(n,n) integer i integer ival integer j integer p(n) call r8mat_is_permutation ( n, n, a, ival ) if ( ival /= 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_PERMUTATION returned IVAL = ', ival stop 1 end if do i = 1, n do j = 1, n if ( a(i,j) == 1.0D+00 ) then p(i) = j end if end do end do return end subroutine perm_sign ( n, p, p_sign ) !*****************************************************************************80 ! !! perm_sign() returns the sign of a permutation. ! ! Discussion: ! ! A permutation can always be replaced by a sequence of pairwise ! transpositions. A given permutation can be represented by ! many different such transposition sequences, but the number of ! such transpositions will always be odd or always be even. ! If the number of transpositions is even or odd, the permutation is ! said to be even or odd. ! ! Example: ! ! Input: ! ! N = 9 ! P = 2, 3, 9, 6, 7, 8, 5, 4, 1 ! ! Output: ! ! P_SIGN = +1 ! ! Licensing: ! ! This code is distributed under the MIT license. ! ! Modified: ! ! 01 February 2000 ! ! Author: ! ! Original FORTRAN77 version by Albert Nijenhuis, Herbert Wilf. ! FORTRAN90 version by John Burkardt ! ! Reference: ! ! Albert Nijenhuis, Herbert Wilf, ! Combinatorial Algorithms, ! Academic Press, 1978, second edition, ! ISBN 0-12-519260-6. ! ! Input: ! ! integer N, the number of objects permuted. ! ! integer P(N), a permutation, in standard index form. ! ! Output: ! ! integer P_SIGN, the "sign" of the permutation. ! +1, the permutation is even, ! -1, the permutation is odd. ! implicit none integer, parameter :: rk = kind ( 1.0D+00 ) integer n integer i integer ierror integer i4vec_index integer j integer p(n) integer p_sign integer q(n) integer t call perm_check ( n, p, ierror ) if ( ierror /= 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 ! ! Make a temporary copy of the permutation. ! q(1:n) = p(1:n) ! ! Start with P_SIGN indicating an even permutation. ! Restore each element of the permutation to its correct position, ! updating P_SIGN as you go. ! p_sign = 1 do i = 1, n - 1 j = i4vec_index ( n, q, i ) if ( j /= i ) then t = q(i) q(i) = q(j) q(j) = t p_sign = - p_sign end if end do return end subroutine perm_vec_to_mat ( n, p, a ) !*****************************************************************************80 ! !! perm_vec_to_mat() returns a permutation matrix. ! ! Formula: ! ! if ( J = P(I) ) ! A(I,J) = 1 ! else ! A(I,J) = 0 ! ! Example: ! ! N = 5, P = ( 2, 4, 1, 3, 5 ) ! ! 0 1 0 0 0 ! 0 0 0 1 0 ! 1 0 0 0 0 ! 0 0 1 0 0 ! 0 0 0 0 1 ! ! Properties: ! ! A is integral, therefore det ( A ) is integral, and ! det ( A ) * inverse ( A ) is integral. ! ! A is a zero/one matrix. ! ! P is a proper definition of a permutation if and only if ! every value from 1 to N occurs exactly once. The matrix A ! will be a permutation matrix if and only if P is a proper ! definition of a permutation. ! ! A is nonsingular. ! ! The inverse of A is the transpose of A, inverse ( A ) = A'. ! ! The inverse of A is the permutation matrix corresponding to the ! inverse permutation of the one that formed A. ! ! det ( A ) = +1 or -1. ! ! A is unimodular. ! ! The determinant of A is +1 or -1, depending on the sign of ! the permutation; Any permutation can be written as the product ! of pairwise transpositions. An odd permutation can be written ! as an odd number of such transpositions, and the corresponding ! matrix has a determinant of -1. ! ! The product of two permutation matrices is a permutation matrix. ! ! Licensing: ! ! This code is distributed under the MIT license. ! ! Modified: ! ! 09 November 1998 ! ! Author: ! ! John Burkardt ! ! Input: ! ! integer N, the order of the matrix. ! ! integer P(N), contains the permutation. The ! entries of P should be a permutation of the indices 1 through N. ! ! Output: ! ! real ( kind = rk ) A(N,N), the matrix. ! implicit none integer, parameter :: rk = kind ( 1.0D+00 ) integer n real ( kind = rk ) a(n,n) integer i integer ierror integer j integer p(n) call perm_check ( n, p, ierror ) if ( ierror /= 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 == 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 ) !*****************************************************************************80 ! !! permutation_determinant() returns the determinant of a PERMUTATION matrix. ! ! Licensing: ! ! This code is distributed under the MIT license. ! ! Modified: ! ! 27 October 2007 ! ! Author: ! ! John Burkardt ! ! Input: ! ! integer N, the order of the matrix. ! ! real ( kind = rk ) A(N,N), the matrix. ! ! Output: ! ! real ( kind = rk ) DETERM, the determinant. ! implicit none integer, parameter :: rk = kind ( 1.0D+00 ) integer n real ( kind = rk ) a(n,n) real ( kind = rk ) determ integer p(n) integer p_sign call perm_mat_to_vec ( n, a, p ) call perm_sign ( n, p, p_sign ) determ = real ( p_sign, kind = rk ) return end subroutine permutation_random_matrix ( n, key, a ) !*****************************************************************************80 ! !! permutation_random_matrix() returns the PERMUTATION_RANDOM matrix. ! ! Licensing: ! ! This code is distributed under the MIT license. ! ! Modified: ! ! 27 October 2007 ! ! Author: ! ! John Burkardt ! ! Reference: ! ! Albert Nijenhuis, Herbert Wilf, ! Combinatorial Algorithms, ! Academic Press, 1978, second edition, ! ISBN 0-12-519260-6. ! ! Input: ! ! integer N, the order of the matrix. ! ! integer KEY, a seed for the random number generator. ! ! Output: ! ! real ( kind = rk ) A(N,N), the matrix. ! implicit none integer, parameter :: rk = kind ( 1.0D+00 ) integer n real ( kind = rk ) a(n,n) integer i integer i4_uniform_ab integer j integer key integer p(n) integer t call random_seed_initialize ( key ) call i4vec_indicator ( n, p ) do i = 1, n j = i4_uniform_ab ( i, n ) 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 ) !*****************************************************************************80 ! !! permutation_random_determinant(): determinant of PERMUTATION_RANDOM matrix. ! ! Discussion: ! ! This routine will only work properly if it is given as input the ! same value of KEY that was given to PERMUTATION_RANDOM_MATRIX. ! ! Licensing: ! ! This code is distributed under the MIT license. ! ! Modified: ! ! 28 October 2021 ! ! Author: ! ! John Burkardt ! ! Input: ! ! integer N, the order of the matrix. ! ! integer KEY, a seed for the random number generator. ! ! Output: ! ! real ( kind = rk ) DETERM, the determinant. ! implicit none integer, parameter :: rk = kind ( 1.0D+00 ) integer n real ( kind = rk ) determ integer i integer i4_uniform_ab integer j integer key integer p(n) integer p_sign integer t call random_seed_initialize ( key ) call i4vec_indicator ( n, p ) do i = 1, n j = i4_uniform_ab ( i, n ) t = p(j) p(j) = p(i) p(i) = t end do call perm_sign ( n, p, p_sign ) determ = real ( p_sign, kind = rk ) return end subroutine permutation_random_inverse ( n, key, a ) !*****************************************************************************80 ! !! permutation_random_inverse(): inverse of PERMUTATION_RANDOM matrix. ! ! Discussion: ! ! This routine will only work properly if it is given as input the ! same value of KEY that was given to PERMUTATION_RANDOM_MATRIX. ! ! Licensing: ! ! This code is distributed under the MIT license. ! ! Modified: ! ! 27 October 2007 ! ! Author: ! ! John Burkardt ! ! Input: ! ! integer N, the order of the matrix. ! ! integer KEY, a seed for the random number generator. ! ! Output: ! ! real ( kind = rk ) A(N,N), the inverse matrix. ! implicit none integer, parameter :: rk = kind ( 1.0D+00 ) integer n real ( kind = rk ) a(n,n) integer i integer i4_uniform_ab integer j integer key integer p(n) integer t call random_seed_initialize ( key ) call i4vec_indicator ( n, p ) do i = 1, n j = i4_uniform_ab ( i, n ) 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_matrix ( n, w, z, a ) !*****************************************************************************80 ! !! pick_matrix() returns the PICK matrix. ! ! Formula: ! ! A(I,J) = ( 1 - conjg ( W(I) ) * W(J) ) ! / ( 1 - conjg ( Z(I) ) * Z(J) ) ! ! Properties: ! ! A is Hermitian: A* = A. ! ! Discussion: ! ! Pick's matrix is related to an interpolation problem in the ! complex unit disk |z| < 1. ! ! If z(1:n) are distinct points in the complex unit disk, and ! w(1:n) are complex values, then Pick's matrix is positive ! semidefinite if and only if there is a holomorphic function ! phi from the unit disk to itself such that phi(z(i)) = w(i). ! ! phi is unique if and only if Pick's matrix is singular. ! ! Licensing: ! ! This code is distributed under the MIT license. ! ! Modified: ! ! 23 January 2003 ! ! Author: ! ! John Burkardt ! ! Reference: ! ! John McCarthy, ! Pick's Theorem: What's the Big Deal? ! American Mathematical Monthly, ! Volume 110, Number 1, January 2003, pages 36-45. ! ! Input: ! ! integer N, the order of the matrix. ! ! complex ( kind = ck ) W(N), the parameters associated with the ! numerator. ! ! complex ( kind = ck ) Z(N), the parameters associated with the ! denominator. Normally, the z's are distinct, and each of norm less ! than 1. ! ! Output: ! ! complex ( kind = ck ) A(N,N), the matrix. ! implicit none integer, parameter :: rk = kind ( 1.0D+00 ) integer, parameter :: ck = kind ( ( 1.0D+00, 1.0D+00 ) ) integer n complex ( kind = ck ) a(n,n) integer i integer j complex ( kind = ck ) one complex ( kind = ck ) w(n) complex ( kind = ck ) z(n) one = cmplx ( 1.0D+00, 0.0D+00, kind = ck ) do j = 1, n do i = 1, n a(i,j) = ( one - conjg ( w(i) ) * w(j) ) & / ( one - conjg ( z(i) ) * z(j) ) end do end do return end subroutine plu_matrix ( n, pivot, a ) !*****************************************************************************80 ! !! plu_matrix() returns a PLU matrix. ! ! Example: ! ! Input: ! ! N = 5 ! PIVOT = ( 1, 3, 3, 5, 5 ) ! ! Output: ! ! A: ! ! 11 12 13 14 15 ! 1.375 9.75 43.25 44.75 46.25 ! 2.75 25 26.25 27.5 28.75 ! 0.34375 2.4375 7.71875 17.625 73.125 ! 0.6875 4.875 15.4375 60 61.5625 ! ! P: ! ! 1 0 0 0 0 ! 0 0 1 0 0 ! 0 1 0 0 0 ! 0 0 0 0 1 ! 0 0 0 1 0 ! ! L: ! ! 1 0 0 0 0 ! 0.25 1 0 0 0 ! 0.125 0.375 1 0 0 ! 0.0625 0.1875 0.3125 1 0 ! 0.03125 0.09375 0.15625 0.21875 1 ! ! U: ! ! 11 12 13 14 15 ! 0 22 23 24 25 ! 0 0 33 34 35 ! 0 0 0 44 45 ! 0 0 0 0 55 ! ! Note: ! ! The LINPACK routine DGEFA will factor the above A as: ! ! 11 12 13 14 15 ! -0.125 22 23 24 25 ! -0.25 -0.375 33 34 35 ! -0.03125 -0.09375 -0.15625 44 45 ! -0.0625 -0.1875 -0.3125 -0.21875 55 ! ! and the pivot information in the vector IPVT as: ! ! ( 1, 3, 3, 5, 5 ). ! ! The LAPACK routine DGETRF will factor the above A as: ! ! 11 12 13 14 15 ! 0.25 22 23 24 25 ! 0.125 0.375 33 34 35 ! 0.0625 0.1875 0.3125 44 45 ! 0.03125 0.09375 0.15625 0.21875 55 ! ! and the pivot information in the vector PIVOT as: ! ! ( 1, 3, 3, 5, 5 ). ! ! Method: ! ! The L factor will have unit diagonal, and subdiagonal entries ! L(I,J) = ( 2 * J - 1 ) / 2^I, which should result in a unique ! value for every entry. ! ! The U factor of A will have entries ! U(I,J) = 10 * I + J, which should result in "nice" entries as long ! as N < 10. ! ! The P factor can be deduced by applying the pivoting operations ! specified by PIVOT in reverse order to the rows of the identity. ! ! Licensing: ! ! This code is distributed under the MIT license. ! ! Modified: ! ! 25 March 2015 ! ! Author: ! ! John Burkardt ! ! Input: ! ! integer N, the order of the matrix. ! ! integer PIVOT(N), the list of pivot rows. PIVOT(I) ! must be a value between I and N, reflecting the choice of ! pivot row on the I-th step. For no pivoting, set PIVOT(I) = I. ! ! Output: ! ! real ( kind = rk ) A(N,N), the matrix. ! implicit none integer, parameter :: rk = kind ( 1.0D+00 ) integer n real ( kind = rk ) a(n,n) real ( kind = rk ) l(n,n) real ( kind = rk ) p(n,n) integer pivot(n) real ( kind = rk ) u(n,n) call plu_plu ( n, pivot, p, l, u ) a = matmul ( p, matmul ( l, u ) ) return end subroutine plu_determinant ( n, pivot, value ) !*****************************************************************************80 ! !! plu_determinant() returns the determinant of the PLU matrix. ! ! Licensing: ! ! This code is distributed under the MIT license. ! ! Modified: ! ! 25 March 2015 ! ! Author: ! ! John Burkardt ! ! Input: ! ! integer N, the order of the matrix. ! ! integer PIVOT(N), the list of pivot rows. PIVOT(I) ! must be a value between I and N, reflecting the choice of ! pivot row on the I-th step. For no pivoting, set PIVOT(I) = I. ! ! Output: ! ! real ( kind = rk ) VALUE, the determinant. ! implicit none integer, parameter :: rk = kind ( 1.0D+00 ) integer n logical found integer i integer i2 real ( kind = rk ) l(n,n) real ( kind = rk ) p(n,n) integer pivot(n) real ( kind = rk ) prow(n) real ( kind = rk ) u(n,n) real ( kind = rk ) 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) == 1.0D+00 ) then found = .true. if ( i2 /= i ) then prow(1:n) = p(i2,1:n) p(i2,1:n) = p(i,1:n) p(i,1:n) = prow(1:n) 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 ) !*****************************************************************************80 ! !! plu_inverse() returns the inverse of the PLU matrix. ! ! Licensing: ! ! This code is distributed under the MIT license. ! ! Modified: ! ! 25 March 2015 ! ! Author: ! ! John Burkardt ! ! Input: ! ! integer N, the order of the matrix. ! ! integer PIVOT(N), the list of pivot rows. PIVOT(I) ! must be a value between I and N, reflecting the choice of ! pivot row on the I-th step. For no pivoting, set PIVOT(I) = I. ! ! Output: ! ! real ( kind = rk ) A(N,N), the inverse matrix. ! implicit none integer, parameter :: rk = kind ( 1.0D+00 ) integer n real ( kind = rk ) a(n,n) real ( kind = rk ) l(n,n) real ( kind = rk ) l_inverse(n,n) real ( kind = rk ) p(n,n) real ( kind = rk ) p_inverse(n,n) integer pivot(n) real ( kind = rk ) u(n,n) real ( kind = rk ) 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 ) a = matmul ( u_inverse, matmul ( l_inverse, p_inverse ) ) return end subroutine plu_plu ( n, pivot, p, l, u ) !*****************************************************************************80 ! !! plu_plu() returns the PLU factors of the PLU matrix. ! ! Example: ! ! Input: ! ! N = 5 ! PIVOT = ( 1, 3, 3, 5, 5 ) ! ! Output: ! ! P: ! ! 1 0 0 0 0 ! 0 0 1 0 0 ! 0 1 0 0 0 ! 0 0 0 0 1 ! 0 0 0 1 0 ! ! L: ! ! 1 0 0 0 0 ! 0.25 1 0 0 0 ! 0.125 0.375 1 0 0 ! 0.0625 0.1875 0.3125 1 0 ! 0.03125 0.09375 0.15625 0.21875 1 ! ! U: ! ! 11 12 13 14 15 ! 0 22 23 24 25 ! 0 0 33 34 35 ! 0 0 0 44 45 ! 0 0 0 0 55 ! ! Licensing: ! ! This code is distributed under the MIT license. ! ! Modified: ! ! 25 March 2015 ! ! Author: ! ! John Burkardt ! ! Input: ! ! integer N, the order of the matrix. ! ! integer PIVOT(N), the list of pivot rows. PIVOT(I) ! must be a value between I and N, reflecting the choice of ! pivot row on the I-th step. For no pivoting, set PIVOT(I) = I. ! ! Output: ! ! real ( kind = rk ) P(N,N), L(N,N), U(N,N), the P, L and U factors ! of A, as defined by Gaussian elimination with partial pivoting. ! P is a permutation matrix, L is unit lower triangular, and U ! is upper triangular. ! implicit none integer, parameter :: rk = kind ( 1.0D+00 ) integer n integer i integer j real ( kind = rk ) l(n,n) real ( kind = rk ) p(n,n) integer pivot(n) real ( kind = rk ) t real ( kind = rk ) u(n,n) ! ! Check that the pivot vector is legal. ! do i = 1, n if ( pivot(i) < 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 < 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 ! ! Compute U. ! do i = 1, n do j = 1, n if ( i <= j ) then u(i,j) = real ( 10 * i + j, kind = rk ) else u(i,j) = 0.0D+00 end if end do end do ! ! Compute L. ! do i = 1, n do j = 1, n if ( i < j ) then l(i,j) = 0.0D+00 else if ( j == i ) then l(i,j) = 1.0D+00 else l(i,j) = real ( 2 * j - 1, kind = rk ) / real ( 2 ** i, kind = rk ) end if end do end do ! ! Compute P. ! do i = 1, n do j = 1, n if ( i == j ) then p(i,j) = 1.0D+00 else p(i,j) = 0.0D+00 end if end do end do ! ! Apply the pivot permutations, in reverse order. ! do i = n, 1, -1 if ( pivot(i) /= 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_matrix ( nrow, ncol, a ) !*****************************************************************************80 ! !! poisson_matrix() returns the POISSON matrix. ! ! Formula: ! ! if ( I = J ) ! A(I,J) = 4.0D+00 ! else if ( I = J+1 or I = J-1 or I = J+NROW or I = J-NROW ) ! A(I,J) = -1.0D+00 ! else ! A(I,J) = 0.0D+00 ! ! Example: ! ! NROW = NCOL = 3 ! ! 4 -1 0 | -1 0 0 | 0 0 0 ! -1 4 -1 | 0 -1 0 | 0 0 0 ! 0 -1 4 | 0 0 -1 | 0 0 0 ! ---------------------------- ! -1 0 0 | 4 -1 0 | -1 0 0 ! 0 -1 0 | -1 4 -1 | 0 -1 0 ! 0 0 -1 | 0 -1 4 | 0 0 -1 ! ---------------------------- ! 0 0 0 | -1 0 0 | 4 -1 0 ! 0 0 0 | 0 -1 0 | -1 4 -1 ! 0 0 0 | 0 0 -1 | 0 -1 4 ! ! Properties: ! ! A is symmetric: A' = A. ! ! Because A is symmetric, it is normal. ! ! Because A is normal, it is diagonalizable. ! ! A is integral, therefore det ( A ) is integral, and ! det ( A ) * inverse ( A ) is integral. ! ! A is persymmetric: A(I,J) = A(N+1-J,N+1-I). ! ! A results from discretizing Poisson's equation with the ! 5 point operator on a mesh of NROW by NCOL points. ! ! A has eigenvalues ! ! LAMBDA(I,J) = 4 - 2 * COS(I*PI/(NROW+1)) ! - 2 * COS(J*PI/(NCOL+1)), I = 1 to NROW, J = 1 to NCOL. ! ! Licensing: ! ! This code is distributed under the MIT license. ! ! Modified: ! ! 05 March 2015 ! ! Author: ! ! John Burkardt ! ! Reference: ! ! Gene Golub, Charles Van Loan, ! Matrix Computations, second edition, ! Johns Hopkins University Press, Baltimore, Maryland, 1989 ! (Section 4.5.4). ! ! Input: ! ! integer NROW, NCOL, the number of rows and columns ! in the grid. ! ! Output: ! ! real ( kind = rk ) A(NROW*NCOL,NROW*NCOL), the matrix. ! implicit none integer, parameter :: rk = kind ( 1.0D+00 ) integer ncol integer nrow real ( kind = rk ) a(nrow*ncol,nrow*ncol) integer i integer i1 integer j integer j1 integer n n = nrow * ncol a(1:n,1:n) = 0.0D+00 i = 0 do i1 = 1, nrow do j1 = 1, ncol i = i + 1 if ( 1 < i1 ) then j = i - ncol a(i,j) = -1.0D+00 end if if ( 1 < j1 ) then j = i - 1 a(i,j) = -1.0D+00 end if j = i a(i,j) = 4.0D+00 if ( j1 < ncol ) then j = i + 1 a(i,j) = -1.0D+00 end if if ( i1 < 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 ) !*****************************************************************************80 ! !! poisson_determinant() returns the determinant of the POISSON matrix. ! ! Licensing: ! ! This code is distributed under the MIT license. ! ! Modified: ! ! 05 March 2015 ! ! Author: ! ! John Burkardt ! ! Input: ! ! integer NROW, NCOL, the number of rows and columns in the grid. ! ! Output: ! ! real ( kind = rk ) DETERM, the determinant. ! implicit none integer, parameter :: rk = kind ( 1.0D+00 ) integer ncol integer nrow real ( kind = rk ) angle real ( kind = rk ) cc(ncol) real ( kind = rk ) cr(nrow) real ( kind = rk ) determ integer i integer j real ( kind = rk ), parameter :: r8_pi = 3.141592653589793D+00 do i = 1, nrow angle = real ( i, kind = rk ) * r8_pi / real ( nrow + 1, kind = rk ) cr(i) = cos ( angle ) end do do i = 1, ncol angle = real ( i, kind = rk ) * r8_pi / real ( ncol + 1, kind = rk ) 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 ) !*****************************************************************************80 ! !! poisson_eigenvalues() returns the eigenvalues of the POISSON matrix. ! ! Licensing: ! ! This code is distributed under the MIT license. ! ! Modified: ! ! 05 March 2015 ! ! Author: ! ! John Burkardt ! ! Input: ! ! integer NROW, NCOL, the number of rows and columns ! in the grid. ! ! Output: ! ! real ( kind = rk ) LAMBDA(NROW*NCOL), the eigenvalues. ! implicit none integer, parameter :: rk = kind ( 1.0D+00 ) integer ncol integer nrow real ( kind = rk ) angle real ( kind = rk ) cc(ncol) real ( kind = rk ) cr(nrow) real ( kind = rk ) lambda(nrow*ncol) integer i integer j integer k real ( kind = rk ), parameter :: r8_pi = 3.141592653589793D+00 do i = 1, nrow angle = real ( i, kind = rk ) * r8_pi / real ( nrow + 1, kind = rk ) cr(i) = cos ( angle ) end do do i = 1, ncol angle = real ( i, kind = rk ) * r8_pi / real ( ncol + 1, kind = rk ) 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 ) !*****************************************************************************80 ! !! poisson_rhs() returns the right hand side of a Poisson linear system. ! ! Discussion: ! ! The Poisson matrix is associated with an NROW by NCOL rectangular ! grid of points. ! ! Assume that the points are numbered from left to right, bottom to top. ! ! If the K-th point is in row I and column J, set X = I + J. ! ! This will be the solution to the linear system. ! ! The right hand side is easily determined from X. It is 0 for every ! interior point. ! ! Example: ! ! NROW = 3, NCOL = 3 ! ! ^ ! | 7 8 9 ! J 4 5 6 ! | 1 2 3 ! | ! +-----I----> ! ! Solution vector X = ( 2, 3, 4, 3, 4, 5, 4, 5, 6 ) ! ! Right hand side B = ( 2, 2, 8, 2, 0, 6, 8, 6, 14 ). ! ! Licensing: ! ! This code is distributed under the MIT license. ! ! Modified: ! ! 05 March 2015 ! ! Author: ! ! John Burkardt ! ! Reference: ! ! Gene Golub, Charles Van Loan, ! Matrix Computations, second edition, ! Johns Hopkins University Press, Baltimore, Maryland, 1989 ! (Section 4.5.4). ! ! Input: ! ! integer NROW, NCOL, the number of rows and columns ! in the grid. ! ! Output: ! ! real ( kind = rk ) B(NROW*NCOL), the right hand side. ! implicit none integer, parameter :: rk = kind ( 1.0D+00 ) integer ncol integer nrow real ( kind = rk ) b(nrow*ncol) integer i integer j integer k k = 0 do j = 1, nrow do i = 1, ncol k = k + 1 b(k) = 0.0D+00 if ( i == 1 ) then b(k) = b(k) + real ( i + j - 1, kind = rk ) end if if ( j == 1 ) then b(k) = b(k) + real ( i + j - 1, kind = rk ) end if if ( i == ncol ) then b(k) = b(k) + real ( i + j + 1, kind = rk ) end if if ( j == nrow ) then b(k) = b(k) + real ( i + j + 1, kind = rk ) end if end do end do return end subroutine poisson_solution ( nrow, ncol, x ) !*****************************************************************************80 ! !! poisson_solution() returns the solution of a Poisson linear system. ! ! Discussion: ! ! The Poisson matrix is associated with an NROW by NCOL rectangular ! grid of points. ! ! Assume that the points are numbered from left to right, bottom to top. ! ! If the K-th point is in row I and column J, set X = I + J. ! ! This will be the solution to the linear system. ! ! Example: ! ! NROW = 3, NCOL = 3 ! ! ^ ! | 7 8 9 ! J 4 5 6 ! | 1 2 3 ! | ! +-----I----> ! ! Solution vector X = ( 2, 3, 4, 3, 4, 5, 4, 5, 6 ) ! ! Licensing: ! ! This code is distributed under the MIT license. ! ! Modified: ! ! 05 March 2015 ! ! Author: ! ! John Burkardt ! ! Reference: ! ! Gene Golub, Charles Van Loan, ! Matrix Computations, second edition, ! Johns Hopkins University Press, Baltimore, Maryland, 1989 ! (Section 4.5.4). ! ! Input: ! ! integer NROW, NCOL, the number of rows and columns ! in the grid. ! ! Output: ! ! real ( kind = rk ) X(NROW*NCOL), the solution. ! implicit none integer, parameter :: rk = kind ( 1.0D+00 ) integer ncol integer nrow integer i integer j integer k real ( kind = rk ) x(nrow*ncol) k = 0 do j = 1, nrow do i = 1, ncol k = k + 1 x(k) = real ( i + j, kind = rk ) end do end do return end function prime ( n ) !*****************************************************************************80 ! !! prime() returns any of the first PRIME_MAX prime numbers. ! ! Discussion: ! ! PRIME_MAX is 1600, and the largest prime stored is 13499. ! ! Thanks to Bart Vandewoestyne for pointing out a typo, 18 February 2005. ! ! Licensing: ! ! This code is distributed under the MIT license. ! ! Modified: ! ! 18 February 2005 ! ! Author: ! ! John Burkardt ! ! Reference: ! ! Milton Abramowitz, Irene Stegun, ! Handbook of Mathematical Functions, ! US Department of Commerce, 1964, pages 870-873. ! ! Daniel Zwillinger, ! CRC Standard Mathematical Tables and Formulae, ! 30th Edition, ! CRC Press, 1996, pages 95-98. ! ! Input: ! ! integer N, the index of the desired prime number. ! In general, is should be true that 0 <= N <= PRIME_MAX. ! N = -1 returns PRIME_MAX, the index of the largest prime available. ! N = 0 is legal, returning PRIME = 1. ! ! Output: ! ! integer PRIME, the N-th prime. If N is out of range, ! PRIME is returned as -1. ! implicit none integer, parameter :: rk = kind ( 1.0D+00 ) integer, parameter :: prime_max = 1600 integer, save :: icall = 0 integer n integer, dimension ( prime_max ), save :: npvec integer prime if ( icall == 0 ) then icall = 1 npvec(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 /) npvec(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 /) npvec(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 /) npvec(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 /) npvec(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 /) npvec(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 /) npvec(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 /) npvec(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 /) npvec(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 /) npvec(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 /) npvec(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 /) npvec(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 /) npvec(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 /) npvec(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 /) npvec(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 /) npvec(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 /) end if if ( n == -1 ) then prime = prime_max else if ( n == 0 ) then prime = 1 else if ( n <= 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_matrix ( alpha, n, a ) !*****************************************************************************80 ! !! prolate_matrix() returns the PROLATE matrix. ! ! Formula: ! ! If ( I == J ) then ! A(I,J) = 2 * ALPHA ! else ! K = abs ( I - J ) + 1 ! A(I,J) = sin ( 2 * pi * ALPHA * K ) / ( pi * K ) ! ! Example: ! ! N = 5, ALPHA = 0.25 ! ! 0.5 0.0 -0.106103 0.0 0.0636620 ! 0.0 0.5 0.0 -0.106103 0.0 ! -0.106103 0.0 0.5 0.0 -0.106103 ! 0.0 -0.106103 0.0 0.5 0.0 ! 0.0636620 0.0 -0.106103 0.0 0.5 ! ! Properties: ! ! A is symmetric: A' = A. ! ! Because A is symmetric, it is normal. ! ! Because A is normal, it is diagonalizable. ! ! A is persymmetric: A(I,J) = A(N+1-J,N+1-I). ! ! A is centrosymmetric: A(I,J) = A(N+1-I,N+1-J). ! ! A is Toeplitz: constant along diagonals. ! ! If 0 < ALPHA < 0.5, then ! A is positive definite, ! the eigenvalues of A are distinct, ! the eigenvalues lie in (0,1) and cluster around 0 and 1. ! ! The family of matrices is nested as a function of N. ! ! Licensing: ! ! This code is distributed under the MIT license. ! ! Modified: ! ! 15 April 1999 ! ! Author: ! ! John Burkardt ! ! Reference: ! ! James Varah, ! The Prolate Matrix, ! Linear Algebra and Applications, ! Volume 187, July 1993, pages 269-278. ! ! Input: ! ! real ( kind = rk ) ALPHA, the parameter. ! ! integer N, the order of the matrix. ! ! Output: ! ! real ( kind = rk ) A(N,N), the matrix. ! implicit none integer, parameter :: rk = kind ( 1.0D+00 ) integer n real ( kind = rk ) a(n,n) real ( kind = rk ) alpha real ( kind = rk ) angle integer i integer j integer k real ( kind = rk ), parameter :: r8_pi = 3.141592653589793D+00 do j = 1, n do i = 1, n if ( i == j ) then a(i,j) = 2.0D+00 * alpha else k = abs ( i - j ) + 1 angle = 2.0D+00 * r8_pi * alpha * real ( k, kind = rk ) a(i,j) = sin ( angle ) / ( r8_pi * real ( k, kind = rk ) ) end if end do end do return end subroutine propa_no_random_matrix ( prob, k, n, key, a ) !*****************************************************************************80 ! !! propa_no_random_matrix() returns a PROPA_NO_RANDOM matrix. ! ! Discussion: ! ! The matrix is a random matrix that does not have property A. ! ! Licensing: ! ! This code is distributed under the MIT license. ! ! Modified: ! ! 23 May 2002 ! ! Author: ! ! John Burkardt ! ! Input: ! ! real ( kind = rk ) PROB, the probability that a link between ! two eligible nodes will be made. ! ! integer K, the number of illegal links between nodes ! to make. The routine will TRY to make this many illegal links. However, ! it is obviously possible to make K too big. ! ! integer N, the order of the matrix. ! ! integer KEY, a seed for the random number generator. ! ! Output: ! ! real ( kind = rk ) A(N,N), the matrix. ! implicit none integer, parameter :: rk = kind ( 1.0D+00 ) integer n real ( kind = rk ) a(n,n) integer bad real ( kind = rk ) chance integer i integer i4_uniform_ab integer j integer k integer key real ( kind = rk ) prob integer set(n) integer tries call random_seed_initialize ( key ) a(1:n,1:n) = 0.0D+00 ! ! Assign each index randomly to one of two sets. ! SET(I) is 0 if I is in set 0, and 1 if it is in set 1. ! call subset_random ( n, set ) do j = 1, n do i = 1, n if ( set(i) /= set(j) ) then call random_number ( harvest = chance ) if ( chance <= prob ) then a(i,j) = 1.0D+00 end if end if end do end do ! ! Now repeatedly pick a pair of indices, and consider setting the ! corresponding entry of A to 1. ! bad = 0 tries = 0 do tries = tries + 1 if ( 1000 < tries ) then exit end if if ( k <= bad ) then exit end if i = i4_uniform_ab ( 1, n ) j = i4_uniform_ab ( 1, n ) if ( i == j ) then cycle end if if ( set(i) /= set(j) ) then cycle end if if ( a(i,j) /= 0.0D+00 .and. a(j,i) /= 0.0D+00 ) then cycle end if if ( a(i,j) == 0.0D+00 ) then a(i,j) = 1.0D+00 else a(j,i) = 1.0D+00 end if bad = bad + 1 end do return end subroutine propa_yes_random_matrix ( prob, n, key, a ) !*****************************************************************************80 ! !! propa_yes_random_matrix() returns a PROPA_YES_RANDOM matrix. ! ! Discussion: ! ! The matrix is a random matrix with property A. ! ! Licensing: ! ! This code is distributed under the MIT license. ! ! Modified: ! ! 23 May 2002 ! ! Author: ! ! John Burkardt ! ! Input: ! ! real ( kind = rk ) PROB, the probability that a link between ! two eligible nodes will be made. ! ! integer N, the order of the matrix. ! ! integer KEY, a seed for the random number generator. ! ! Output: ! ! real ( kind = rk ) A(N,N), the matrix. ! implicit none integer, parameter :: rk = kind ( 1.0D+00 ) integer n real ( kind = rk ) a(n,n) real ( kind = rk ) chance integer i integer j integer key real ( kind = rk ) prob integer set(n) call random_seed_initialize ( key ) a(1:n,1:n) = 0.0D+00 ! ! Assign each index randomly to one of two sets. ! SET(I) is 0 if I is in set 0, and 1 if it is in set 1. ! call subset_random ( n, set ) do i = 1, n do j = 1, n if ( set(i) /= set(j) ) then call random_number ( harvest = chance ) if ( chance <= prob ) then a(i,j) = 1.0D+00 end if end if end do end do return end subroutine quaternion_i_matrix ( a ) !*****************************************************************************80 ! !! quaternion_i_matrix() returns a 4 by 4 matrix that behaves like the quaternion unit I. ! ! Example: ! ! 0 1 0 0 ! -1 0 0 0 ! 0 0 0 -1 ! 0 0 1 0 ! ! Properties: ! ! I * 1 = I ! I * I = - 1 ! I * J = K ! I * K = - J ! ! Licensing: ! ! This code is distributed under the MIT license. ! ! Modified: ! ! 16 June 2011 ! ! Author: ! ! John Burkardt ! ! Output: ! ! real ( kind = rk ) A(4,4), the matrix. ! implicit none integer, parameter :: rk = kind ( 1.0D+00 ) real ( kind = rk ) a(4,4) ! ! Note that the matrix entries are listed by column. ! real ( kind = rk ), dimension ( 4, 4 ), save :: a_save = reshape ( (/ & 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 /), (/ 4, 4 /) ) call r8mat_copy ( 4, 4, a_save, a ) return end subroutine quaternion_j_matrix ( a ) !*****************************************************************************80 ! !! quaternion_j_matrix() returns a 4 by 4 matrix that behaves like the quaternion unit J. ! ! Example: ! ! 0 0 1 0 ! 0 0 0 1 ! -1 0 0 0 ! 0 -1 0 0 ! ! Properties: ! ! J * 1 = J ! J * I = - K ! J * J = - 1 ! J * K = I ! ! Licensing: ! ! This code is distributed under the MIT license. ! ! Modified: ! ! 10 March 2001 ! ! Author: ! ! John Burkardt ! ! Output: ! ! real ( kind = rk ) A(4,4), the matrix. ! implicit none integer, parameter :: rk = kind ( 1.0D+00 ) real ( kind = rk ) a(4,4) ! ! Note that the matrix entries are listed by column. ! real ( kind = rk ), dimension ( 4, 4 ), save :: a_save = reshape ( (/ & 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 /), (/ 4, 4 /) ) call r8mat_copy ( 4, 4, a_save, a ) return end subroutine quaternion_k_matrix ( a ) !*****************************************************************************80 ! !! quaternion_k_matrix() returns a 4 by 4 matrix that behaves like the quaternion unit K. ! ! Example: ! ! 0 0 0 1 ! 0 0 -1 0 ! 0 1 0 0 ! -1 0 0 0 ! ! Properties: ! ! K * 1 = K ! K * I = J ! K * J = - I ! K * K = - 1 ! ! Licensing: ! ! This code is distributed under the MIT license. ! ! Modified: ! ! 26 June 2011 ! ! Author: ! ! John Burkardt ! ! Output: ! ! real ( kind = rk ) A(4,4), the matrix. ! implicit none integer, parameter :: rk = kind ( 1.0D+00 ) real ( kind = rk ) a(4,4) ! ! Note that the matrix entries are listed by column. ! real ( kind = rk ), dimension ( 4, 4 ), save :: a_save = reshape ( (/ & 0.0D+00, 0.0D+00, 0.0D+00, -1.0D+00, & 0.0D+00, 0.0D+00, 1.0D+00, 0.0D+00, & 0.0D+00, -1.0D+00, 0.0D+00, 0.0D+00, & 1.0D+00, 0.0D+00, 0.0D+00, 0.0D+00 /), (/ 4, 4 /) ) call r8mat_copy ( 4, 4, a_save, a ) return end function r8_choose ( n, k ) !*****************************************************************************80 ! !! r8_choose() computes the binomial coefficient C(N,K) as an R8. ! ! Discussion: ! ! The value is calculated in such a way as to avoid overflow and ! roundoff. The calculation is done in R8 arithmetic. ! ! The formula used is: ! ! C(N,K) = N! / ( K! * (N-K)! ) ! ! Licensing: ! ! This code is distributed under the MIT license. ! ! Modified: ! ! 24 March 2008 ! ! Author: ! ! John Burkardt ! ! Reference: ! ! ML Wolfson, HV Wright, ! Algorithm 160: ! Combinatorial of M Things Taken N at a Time, ! Communications of the ACM, ! Volume 6, Number 4, April 1963, page 161. ! ! Input: ! ! integer N, K, are the values of N and K. ! ! Output: ! ! real ( kind = rk ) R8_CHOOSE, the number of combinations of N ! things taken K at a time. ! implicit none integer, parameter :: rk = kind ( 1.0D+00 ) integer i integer k integer mn integer mx integer n real ( kind = rk ) r8_choose real ( kind = rk ) value mn = min ( k, n - k ) if ( mn < 0 ) then value = 0.0D+00 else if ( mn == 0 ) then value = 1.0D+00 else mx = max ( k, n - k ) value = real ( mx + 1, kind = rk ) do i = 2, mn value = ( value * real ( mx + i, kind = rk ) ) / real ( i, kind = rk ) end do end if r8_choose = value return end function r8_cube_root ( x ) !*****************************************************************************80 ! !! r8_cube_root() returns the cube root of an R8. ! ! Discussion: ! ! This routine is designed to avoid the possible problems that can occur ! when formulas like 0.0^(1/3) or (-1.0)^(1/3) are to be evaluated. ! ! Licensing: ! ! This code is distributed under the MIT license. ! ! Modified: ! ! 01 March 1999 ! ! Author: ! ! John Burkardt ! ! Input: ! ! real ( kind = rk ) X, the number whose cube root is desired. ! ! Output: ! ! real ( kind = rk ) R8_CUBE_ROOT, the cube root of X. ! implicit none integer, parameter :: rk = kind ( 1.0D+00 ) real ( kind = rk ) r8_cube_root real ( kind = rk ) value real ( kind = rk ) x if ( 0.0D+00 < x ) then value = x ** ( 1.0D+00 / 3.0D+00 ) else if ( x == 0.0D+00 ) then value = 0.0D+00 else value = -( abs ( x ) ) ** ( 1.0D+00 / 3.0D+00 ) end if r8_cube_root = value return end function r8_epsilon ( ) !*****************************************************************************80 ! !! r8_epsilon() returns the R8 roundoff unit. ! ! Discussion: ! ! The roundoff unit is a number R which is a power of 2 with the ! property that, to the precision of the computer's arithmetic, ! 1 < 1 + R ! but ! 1 = ( 1 + R / 2 ) ! ! FORTRAN90 provides the superior library routine ! ! EPSILON ( X ) ! ! Licensing: ! ! This code is distributed under the MIT license. ! ! Modified: ! ! 01 September 2012 ! ! Author: ! ! John Burkardt ! ! Output: ! ! real ( kind = rk ) R8_EPSILON, the round-off unit. ! implicit none integer, parameter :: rk = kind ( 1.0D+00 ) real ( kind = rk ) r8_epsilon r8_epsilon = 2.220446049250313D-016 return end function r8_factorial ( n ) !*****************************************************************************80 ! !! r8_factorial() computes the factorial of N, also denoted "N!". ! ! Formula: ! ! factorial ( N ) = N! = product ( 1 <= I <= N ) I ! ! Licensing: ! ! This code is distributed under the MIT license. ! ! Modified: ! ! 16 January 1999 ! ! Author: ! ! John Burkardt ! ! Input: ! ! integer N, the argument of the factorial function. ! If N is less than 1, the function value is returned as 1. ! ! Output: ! ! real ( kind = rk ) R8_FACTORIAL, the factorial of N. ! implicit none integer, parameter :: rk = kind ( 1.0D+00 ) real ( kind = rk ) r8_factorial integer i integer n r8_factorial = 1.0D+00 do i = 1, n r8_factorial = r8_factorial * real ( i, kind = rk ) end do return end subroutine r8_fake_use ( x ) !*****************************************************************************80 ! !! r8_fake_use() pretends to use a variable. ! ! Discussion: ! ! Some compilers will issue a warning if a variable is unused. ! Sometimes there's a good reason to include a variable in a program, ! but not to use it. Calling this function with that variable as ! the argument will shut the compiler up. ! ! Licensing: ! ! This code is distributed under the MIT license. ! ! Modified: ! ! 21 April 2020 ! ! Author: ! ! John Burkardt ! ! Input: ! ! real ( kind = rk ) X, the variable to be "used". ! implicit none integer, parameter :: rk = kind ( 1.0D+00 ) real ( kind = rk ) x if ( x /= x ) then write ( *, '(a)' ) ' r8_fake_use: variable is NAN.' end if return end function r8_huge ( ) !*****************************************************************************80 ! !! r8_huge() returns a very large R8. ! ! Discussion: ! ! The value returned by this function is NOT required to be the ! maximum representable R8. This value varies from machine to machine, ! from compiler to compiler, and may cause problems when being printed. ! We simply want a "very large" but non-infinite number. ! ! FORTRAN90 provides a built-in routine HUGE ( X ) that ! can return the maximum representable number of the same datatype ! as X, if that is what is really desired. ! ! Licensing: ! ! This code is distributed under the MIT license. ! ! Modified: ! ! 12 October 2007 ! ! Author: ! ! John Burkardt ! ! Output: ! ! real ( kind = rk ) R8_HUGE, a "huge" value. ! implicit none integer, parameter :: rk = kind ( 1.0D+00 ) real ( kind = rk ) r8_huge r8_huge = 1.0D+30 return end function r8_mop ( i ) !*****************************************************************************80 ! !! r8_mop() returns the I-th power of -1 as an R8 value. ! ! Discussion: ! ! An R8 is a real ( kind = rk ) value. ! ! Licensing: ! ! This code is distributed under the MIT license. ! ! Modified: ! ! 07 November 2007 ! ! Author: ! ! John Burkardt ! ! Input: ! ! integer I, the power of -1. ! ! Output: ! ! real ( kind = rk ) R8_MOP, the I-th power of -1. ! implicit none integer, parameter :: rk = kind ( 1.0D+00 ) integer i real ( kind = rk ) r8_mop if ( mod ( i, 2 ) == 0 ) then r8_mop = + 1.0D+00 else r8_mop = - 1.0D+00 end if return end function r8_normal_01 ( ) !*****************************************************************************80 ! !! r8_normal_01() returns a unit pseudonormal R8. ! ! Discussion: ! ! The standard normal probability distribution function (PDF) has ! mean 0 and standard deviation 1. ! ! Because this routine uses the Box Muller method, it requires pairs ! of uniform random values to generate a pair of normal random values. ! This means that on every other call, essentially, the input value of ! SEED is ignored, since the code saves the second normal random value. ! ! If you didn't know this, you might be confused since, usually, the ! output of a random number generator can be completely controlled by ! the input value of the SEED. If I were more careful, I could rewrite ! this routine so that it would distinguish between cases where the input ! value of SEED is the output value from the previous call (all is well) ! and those cases where it is not (the user has decided to do something ! new. Restart the uniform random number sequence.) But I'll leave ! that for later. ! ! Licensing: ! ! This code is distributed under the MIT license. ! ! Modified: ! ! 27 October 2021 ! ! Author: ! ! John Burkardt ! ! Output: ! ! real ( kind = rk ) R8_NORMAL_01, a sample of the standard normal PDF. ! implicit none integer, parameter :: rk = kind ( 1.0D+00 ) real ( kind = rk ), parameter :: r8_pi = 3.141592653589793D+00 real ( kind = rk ) r1 real ( kind = rk ) r2 real ( kind = rk ) r8_normal_01 integer, save :: used = 0 real ( kind = rk ) x real ( kind = rk ), save :: y = 0.0D+00 ! ! On odd numbered calls, generate two uniforms, create two normals, ! return the first normal and its corresponding seed. ! if ( mod ( used, 2 ) == 0 ) then call random_number ( harvest = r1 ) call random_number ( harvest = r2 ) x = sqrt ( -2.0D+00 * log ( r1 ) ) * cos ( 2.0D+00 * r8_pi * r2 ) y = sqrt ( -2.0D+00 * log ( r1 ) ) * sin ( 2.0D+00 * r8_pi * r2 ) ! ! On odd calls, return the second normal and its corresponding seed. ! else x = y end if used = used + 1 r8_normal_01 = x return end function r8_pi ( ) !*****************************************************************************80 ! !! r8_pi() returns the value of pi. ! ! Licensing: ! ! This code is distributed under the MIT license. ! ! Modified: ! ! 04 December 1998 ! ! Author: ! ! John Burkardt ! ! Output: ! ! real ( kind = rk ) R8_PI, the value of pi. ! implicit none integer, parameter :: rk = kind ( 1.0D+00 ) real ( kind = rk ) r8_pi r8_pi = 3.141592653589793D+00 return end subroutine r8_swap ( x, y ) !*****************************************************************************80 ! !! r8_swap() switches two real values. ! ! Licensing: ! ! This code is distributed under the MIT license. ! ! Modified: ! ! 30 November 1998 ! ! Author: ! ! John Burkardt ! ! Input: ! ! real ( kind = rk ) X, Y, two values to be interchanged. ! ! Output: ! ! real ( kind = rk ) X, Y, the values have been interchanged. ! implicit none integer, parameter :: rk = kind ( 1.0D+00 ) real ( kind = rk ) z real ( kind = rk ) x real ( kind = rk ) y z = x x = y y = z return end function r8_uniform_ab ( a, b ) !*****************************************************************************80 ! !! r8_uniform_ab() returns a scaled pseudorandom R8. ! ! Discussion: ! ! An R8 is a real ( kind = rk ) value. ! ! The pseudorandom number should be uniformly distributed ! between A and B. ! ! Licensing: ! ! This code is distributed under the MIT license. ! ! Modified: ! ! 05 July 2006 ! ! Author: ! ! John Burkardt ! ! Input: ! ! real ( kind = rk ) A, B, the limits of the interval. ! ! Output: ! ! real ( kind = rk ) R8_UNIFORM_AB, a number strictly between A and B. ! implicit none integer, parameter :: rk = kind ( 1.0D+00 ) real ( kind = rk ) a real ( kind = rk ) b real ( kind = rk ) r real ( kind = rk ) r8_uniform_ab call random_number ( harvest = r ) r8_uniform_ab = a + ( b - a ) * r return end subroutine r8col_swap ( m, n, a, i, j ) !*****************************************************************************80 ! !! r8col_swap() swaps columns I and J of a real array of column data. ! ! Example: ! ! Input: ! ! M = 3, N = 4, I = 2, J = 4 ! ! A = ( ! 1. 2. 3. 4. ! 5. 6. 7. 8. ! 9. 10. 11. 12. ) ! ! Output: ! ! A = ( ! 1. 4. 3. 2. ! 5. 8. 7. 6. ! 9. 12. 11. 10. ) ! ! Licensing: ! ! This code is distributed under the MIT license. ! ! Modified: ! ! 22 July 1998 ! ! Author: ! ! John Burkardt ! ! Input: ! ! integer M, N, the order of the matrix. ! ! real ( kind = rk ) A(M,N), the array. ! ! integer I, J, the columns to be swapped. ! ! Output: ! ! real ( kind = rk ) A(N,N), the array after column swapping. ! implicit none integer, parameter :: rk = kind ( 1.0D+00 ) integer m integer n real ( kind = rk ) a(m,n) integer i integer j integer k real ( kind = rk ) t if ( 1 <= i .and. i <= n .and. 1 <= j .and. j <= n ) then do k = 1, m t = a(k,i) a(k,i) = a(k,j) a(k,j) = t end do else write ( *, '(a)' ) ' ' write ( *, '(a)' ) 'R8COL_SWAP - Fatal error!' write ( *, '(a)' ) ' I or J is out of bounds.' write ( *, '(a,i8)' ) ' I = ', i write ( *, '(a,i8)' ) ' J = ', j write ( *, '(a,i8)' ) ' NCOL = ', n stop 1 end if return end subroutine r8col_to_r8vec ( m, n, a, x ) !*****************************************************************************80 ! !! r8col_to_r8vec() converts a matrix of columns into a vector. ! ! Example: ! ! M = 3, N = 4 ! ! A = ! 11 12 13 14 ! 21 22 23 24 ! 31 32 33 34 ! ! X = ( 11, 21, 31, 12, 22, 32, 13, 23, 33, 14, 24, 34 ) ! ! Licensing: ! ! This code is distributed under the MIT license. ! ! Modified: ! ! 13 July 2000 ! ! Author: ! ! John Burkardt ! ! Input: ! ! integer M, N, the order of the matrix. ! ! real ( kind = rk ) A(M,N), the matrix. ! ! Output: ! ! real ( kind = rk ) X(M*N), a vector containing the N columns of A. ! implicit none integer, parameter :: rk = kind ( 1.0D+00 ) integer m integer n real ( kind = rk ) a(m,n) integer i integer j real ( kind = rk ) x(m*n) i = 1 do j = 1, n x(i:i+m-1) = a(1:m,j) i = i + m end do return end subroutine r8mat_analyze ( m, n, a ) !*****************************************************************************80 ! !! r8mat_analyze() analyzes an R8MAT for linear algebraic properties. ! ! Discussion: ! ! An R8MAT is a matrix of real ( kind = rk ) values. ! ! Licensing: ! ! This code is distributed under the MIT license. ! ! Modified: ! ! 14 April 2017 ! ! Author: ! ! John Burkardt ! ! Input: ! ! integer M, N, the row and column dimensions ! of the matrix. M and N must be positive. ! ! real ( kind = rk ) A(M,N), the matrix. ! implicit none integer, parameter :: rk = kind ( 1.0D+00 ) integer m integer n real ( kind = rk ) a(m,n) real ( kind = rk ) error_frobenius real ( kind = rk ) error_sum real ( kind = rk ) fnorm integer ival integer jval integer kval integer lval real ( kind = rk ) r8mat_norm_l1 real ( kind = rk ) r8mat_norm_l2 real ( kind = rk ) r8mat_norm_eis real ( kind = rk ) r8mat_norm_fro real ( kind = rk ) r8mat_norm_li real ( kind = rk ) r8mat_norm_spec real ( kind = rk ), parameter :: tol = 0.00001D+00 write ( *, '(a)' ) ' ' ! ! Check properties based on the location of zero and nonzero entries. ! ! Triangular ! call r8mat_is_triangular ( m, n, a, ival, jval ) if ( ival == 1 ) then write ( *, '(a)' ) 'Upper triangular' else if ( ival == 2 ) then write ( *, '(a)' ) 'Unit upper triangular' else write ( *, '(a)' ) 'Not (unit) upper triangular' end if if ( jval == 1 ) then write ( *, '(a)' ) 'Lower triangular' else if ( jval == 2 ) then write ( *, '(a)' ) 'Unit lower triangular' else write ( *, '(a)' ) 'Not (unit) lower triangular' end if ! ! Banded? ! call r8mat_is_banded ( m, n, a, ival, jval ) if ( ival == 0 .and. jval == 0 ) then write ( *, '(a)' ) 'Zero matrix' else if ( ival == 1 .and. jval == 1 ) then write ( *, '(a)' ) 'Diagonal' else if ( ival == 1 .and. jval == 2 ) then write ( *, '(a)' ) 'Upper bidiagonal' else if ( ival == 2 .and. jval == 1 ) then write ( *, '(a)' ) 'Lower bidiagonal' else if ( ival == 2 .and. jval == 2 ) then write ( *, '(a)' ) 'Tridiagonal' else if ( ival == 2 ) then write ( *, '(a)' ) 'Upper Hessenberg' else if ( jval == 2 ) then write ( *, '(a)' ) 'Lower Hessenberg' else if ( ival < m .or. jval < n ) then write ( *, '(a,i8)' ) 'Lower bandwidth = ', max ( ival - 1, 0 ) write ( *, '(a,i8)' ) 'Upper bandwidth = ', max ( jval - 1, 0 ) else write ( *, '(a)' ) 'No band matrix structure detected.' end if call r8mat_is_cyclic_tridiagonal ( m, n, a, ival ) if ( ival == 1 ) then write ( *, '(a)' ) 'Cyclic tridiagonal.' else write ( *, '(a)' ) 'Not cyclic tridiagonal' end if ! ! Diagonals? ! call r8mat_is_diag2 ( m, n, a, ival ) write ( *, '(a,g14.6)' ) 'Diagonality = ', ival ! ! Sparse? ! call r8mat_is_sparse ( m, n, a, fnorm ) write ( *, '(a,g14.6)' ) 'Relative sparseness = ', fnorm ! ! Irreducible. ! if ( m == n ) then call r8mat_is_irreducible ( m, n, a, ival ) if ( ival == 1 ) then write ( *, '(a)' ) 'Irreducible.' else write ( *, '(a)' ) 'Reducible.' end if end if ! ! Property A. ! if ( m == n ) then call r8mat_is_propa ( n, a, ival ) if ( ival == 1 ) then write ( *, '(a)' ) 'Property A.' else write ( *, '(a)' ) 'Not property A.' end if end if ! ! Permutation? ! if ( m == n ) then if ( ival == 3 ) then write ( *, '(a)' ) 'Permutation matrix' else write ( *, '(a)' ) 'Not a permutation matrix' end if end if ! ! Check symmetries. ! ! Symmetric? ! call r8mat_is_symmetric ( m, n, a, error_frobenius ) if ( error_frobenius <= tol ) then write ( *, '(a)' ) 'Symmetric' else write ( *, '(a)' ) 'Not symmetric' end if call r8mat_is_antisymmetric ( m, n, a, error_frobenius ) if ( error_frobenius <= tol ) then write ( *, '(a)' ) 'Antisymmetric' else write ( *, '(a)' ) 'Not antisymmetric' end if call r8mat_is_tournament ( n, a, error_frobenius ) if ( error_frobenius <= tol ) then write ( *, '(a)' ) 'Tournament' else write ( *, '(a)' ) 'Not a Tournament matrix' end if if ( m == n ) then call r8mat_is_transition ( m, n, a, error_frobenius ) if ( error_frobenius <= tol ) then write ( *, '(a)' ) 'Transition' else write ( *, '(a)' ) 'Not a transition matrix' end if end if call r8mat_is_persymmetric ( m, n, a, error_frobenius ) if ( error_frobenius <= tol ) then write ( *, '(a)' ) 'Persymmetric' else write ( *, '(a)' ) 'Not persymmetric' end if call r8mat_is_antipersymmetric ( m, n, a, error_frobenius ) if ( error_frobenius <= tol ) then write ( *, '(a)' ) 'Antipersymmetric' else write ( *, '(a)' ) 'Not antipersymmetric' end if call r8mat_is_centrosymmetric ( m, n, a, ival ) if ( ival == 1 ) then write ( *, '(a)' ) 'Centrosymmetric' else write ( *, '(a)' ) 'Not centrosymmetric' end if ! ! Symmetric positive definite? ! call r8mat_is_spd ( m, n, a, ival ) if ( ival == 0 ) then write ( *, '(a)' ) 'Symmetric Positive Semi-Definite' else if ( ival == 1 ) then write ( *, '(a)' ) 'Symmetric Positive Definite' else write ( *, '(a)' ) 'Not symmetric positive (semi)-definite' end if ! ! Circulant? ! call r8mat_is_circulant ( m, n, a, ival ) if ( ival == 1 ) then write ( *, '(a)' ) 'Circulant' else write ( *, '(a)' ) 'Not circulant' end if ! ! Anticirculant? ! call r8mat_is_anticirculant ( m, n, a, ival ) if ( ival == 1 ) then write ( *, '(a)' ) 'Anticirculant' else write ( *, '(a)' ) 'Not anticirculant' end if ! ! Check some matrix properties. ! ! Positive? ! call r8mat_is_positive ( m, n, a, ival, jval ) if ( ival == 1 ) then write ( *, '(a)' ) 'Positive' else if ( ival == 0 ) then write ( *, '(a)' ) 'Nonnegative' else write ( *, '(a)' ) 'Not positive or nonnegative' end if if ( jval == 1 ) then write ( *, '(a)' ) 'Negative' else if ( jval == 0 ) then write ( *, '(a)' ) 'Nonpositive' else write ( *, '(a)' ) 'Not negative or nonpositive' end if ! ! Diagonally dominant (row)? ! call r8mat_is_diagonally_dominant_row ( m, n, a, ival ) if ( ival == 2 ) then write ( *, '(a)' ) 'Strictly row diagonally dominant' else if ( ival == 1 ) then write ( *, '(a)' ) 'Row diagonally dominant' else write ( *, '(a)' ) 'Not (strictly) row diagonally dominant.' end if ! ! Diagonally dominant (column)? ! call r8mat_is_diagonally_dominant_column ( m, n, a, ival ) if ( ival == 2 ) then write ( *, '(a)' ) 'Strictly column diagonally dominant' else if ( ival == 1 ) then write ( *, '(a)' ) 'Column diagonally dominant' else write ( *, '(a)' ) 'Not (strictly) column diagonally dominant.' end if ! ! Unit rows? ! call r8mat_is_unit_row ( m, n, a, error_sum ) if ( error_sum <= tol ) then write ( *, '(a)' ) 'Matrix rows have unit Euclidean norm.' else write ( *, '(a)' ) 'Matrix rows do not have unit Euclidean norm.' end if ! ! Unit columns? ! call r8mat_is_unit_column ( m, n, a, error_sum ) if ( error_sum <= tol ) then write ( *, '(a)' ) 'Matrix columns have unit Euclidean norm.' else write ( *, '(a)' ) 'Matrix columns do not all have unit Euclidean norm.' end if ! ! Orthogonal rows? ! call r8mat_is_orthogonal_row ( m, n, a, error_sum ) if ( error_sum <= tol ) then write ( *, '(a)' ) 'Matrix is row orthogonal' else write ( *, '(a)' ) 'Not row orthogonal' end if ! ! Orthogonal columns? ! call r8mat_is_orthogonal_column ( m, n, a, error_sum ) if ( error_sum <= tol ) then write ( *, '(a)' ) 'Matrix is column orthogonal' else write ( *, '(a)' ) 'Not column orthogonal' end if call r8mat_is_orthogonal ( m, n, a, error_frobenius ) if ( error_frobenius <= tol ) then write ( *, '(a)' ) 'Matrix is orthogonal' else write ( *, '(a)' ) 'Not orthogonal' end if ! ! Integer? ! call r8mat_is_integer ( m, n, a, error_frobenius ) if ( error_frobenius <= tol ) then write ( *, '(a)' ) 'Integer matrix.' else write ( *, '(a)' ) 'Not an integer matrix.' end if ! ! Zero/one? ! call r8mat_is_zero_one ( m, n, a, ival ) if ( ival == 1 ) then write ( *, '(a)' ) 'The matrix is a zero/one matrix.' else write ( *, '(a)' ) 'Not a zero/one matrix' end if ! ! Scalar? ! call r8mat_is_scalar ( m, n, a, ival, jval, kval, lval ) if ( ival == 1 ) then write ( *, '(a)' ) 'Row scalar' else write ( *, '(a)' ) 'Not row scalar' end if if ( jval == 1 ) then write ( *, '(a)' ) 'Column scalar' else write ( *, '(a)' ) 'Not column scalar' end if call r8mat_is_toeplitz ( m, n, a, ival ) if ( ival == 1 ) then write ( *, '(a)' ) 'Diagonal scalar (= Toeplitz)' else write ( *, '(a)' ) 'Not diagonal scalar' end if call r8mat_is_hankel ( m, n, a, ival ) if ( ival == 1 ) then write ( *, '(a)' ) 'Antidiagonal scalar (= Hankel)' else write ( *, '(a)' ) 'Not antidiagonal scalar (Hankel)' end if ! ! Constant sum? ! call r8mat_is_sum ( m, n, a, ival, jval, kval ) if ( ival == 1 ) then write ( *, '(a)' ) 'Row sum is constant' else if ( ival == 2 ) then write ( *, '(a)' ) 'Row sum is constant, = 1 (Markov matrix)' else write ( *, '(a)' ) 'Row sum is not constant' end if if ( jval == 1 ) then write ( *, '(a)' ) 'Column sum is constant' else if ( jval == 2 ) then write ( *, '(a)' ) 'Column sum is constant, = 1 (transition matrix)' else write ( *, '(a)' ) 'Column sum is not constant' end if if ( kval == 1 ) then write ( *, '(a)' ) 'Row sum = column sum = constant (weak magic matrix)' else if ( kval == 2 ) then write ( *, '(a)' ) 'Row sum = column sum = 1 (doubly stochastic matrix)' else if ( kval == 3 ) then write ( *, '(a)' ) & 'Row sum = column sum = main diagonal sum = constant (magic matrix)' else if ( kval == 4 ) then write ( *, '(a)' ) & 'Row sum = column sum = main diagonal sum = 1 (magic biMarkov matrix)' else write ( *, '(a)' ) 'Not magic, stochastic or biMarkov' end if ! ! Adjacency matrix? ! call r8mat_is_adjacency ( m, n, a, ival ) if ( ival == 1 ) then write ( *, '(a)' ) 'The matrix is an adjacency matrix.' else write ( *, '(a)' ) 'Not an adjacency matrix.' end if ! ! Row echelon form? ! call r8mat_is_ref ( m, n, a, ival ) if ( ival == 1 ) then write ( *, '(a)' ) 'Row echelon form' else if ( ival == 2 ) then write ( *, '(a)' ) 'Reduced row echelon form' else write ( *, '(a)' ) 'Not (reduced) row echelon form' end if ! ! Normal. ! call r8mat_is_normal ( m, n, a, error_frobenius ) if ( error_frobenius <= tol ) then write ( *, '(a)' ) 'Normal, hence diagonalizable.' else write ( *, '(a)' ) 'Not normal.' end if ! ! M. ! call r8mat_is_m ( m, n, a, ival ) if ( ival == 0 ) then write ( *, '(a)' ) 'M matrix.' else if ( ival == 1 ) then write ( *, '(a)' ) 'Not square, so not an M matrix.' else if ( ival == 2 ) then write ( *, '(a)' ) 'Offdiagonal not nonpositive, so not an M matrix.' else if ( ival == 3 ) then write ( *, '(a)' ) 'Not invertible, so not an M matrix.' else if ( ival == 4 ) then write ( *, '(a)' ) 'Inverse not nonnegative, so not an M matrix.' else write ( *, '(a)' ) 'Not an M matrix' end if ! ! Norms. ! if ( m == n ) then write ( *, '(a,g14.6)' ) 'Spectral norm = ', r8mat_norm_spec ( n, a ) end if write ( *, '(a,g14.6)' ) 'L1 norm = ', r8mat_norm_l1 ( m, n, a ) write ( *, '(a,g14.6)' ) 'L2 norm = ', r8mat_norm_l2 ( m, n, a ) write ( *, '(a,g14.6)' ) 'Loo norm = ', r8mat_norm_li ( m, n, a ) write ( *, '(a,g14.6)' ) 'Frobenius norm = ', r8mat_norm_fro ( m, n, a ) write ( *, '(a,g14.6)' ) 'EISPACK norm = ', r8mat_norm_eis ( m, n, a ) return end subroutine r8mat_cholesky_factor ( n, a, c, ierror ) !*****************************************************************************80 ! !! r8mat_cholesky_factor() computes the Cholesky factor of a symmetric R8MAT. ! ! Discussion: ! ! An R8MAT is a matrix of real ( kind = rk ) values. ! ! The matrix must be symmetric and positive semidefinite. ! ! For a positive semidefinite symmetric matrix A, the Cholesky factorization ! is a lower triangular matrix L such that: ! ! A = L * L' ! ! Licensing: ! ! This code is distributed under the MIT license. ! ! Modified: ! ! 23 March 2001 ! ! Author: ! ! John Burkardt ! ! Input: ! ! integer N, the order of the matrix. ! ! real ( kind = rk ) A(N,N), the matrix. ! ! Output: ! ! real ( kind = rk ) C(N,N), the lower triangular Cholesky factor. ! ! integer IERROR, error flag. ! 0, no error. ! 1, warning, the matrix is positive semidefinite. The factorization ! was carried out, but the matrix is singular. ! 2, error, the matrix has at least one negative eigenvalue. The ! factorization could not be completed. ! implicit none integer, parameter :: rk = kind ( 1.0D+00 ) integer n real ( kind = rk ) a(n,n) real ( kind = rk ) c(n,n) real ( kind = rk ) ctc integer i integer ierror integer j ierror = 0 c(1:n,1:n) = a(1:n,1:n) do j = 1, n c(1:j-1,j) = 0.0D+00 do i = j, n ctc = c(j,i) - dot_product ( c(i,1:j-1), c(j,1:j-1) ) if ( i == j ) then if ( ctc < 0.0D+00 ) then ierror = 2 return else if ( ctc == 0.0D+00 ) then ierror = 1 else c(i,j) = sqrt ( ctc ) end if else if ( c(j,j) /= 0.0D+00 ) then c(i,j) = ctc / 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 ) !*****************************************************************************80 ! !! r8mat_copy() copies an R8MAT. ! ! Discussion: ! ! An R8MAT is an array of R8 values. ! ! Licensing: ! ! This code is distributed under the MIT license. ! ! Modified: ! ! 26 July 2008 ! ! Author: ! ! John Burkardt ! ! Input: ! ! integer M, N, the order of the matrix. ! ! real ( kind = rk ) A(M,N), the matrix to be copied. ! ! Output: ! ! real ( kind = rk ) B(M,N), a copy of the matrix. ! implicit none integer, parameter :: rk = kind ( 1.0D+00 ) integer m integer n real ( kind = rk ) a(m,n) real ( kind = rk ) b(m,n) b(1:m,1:n) = a(1:m,1:n) return end subroutine r8mat_determinant ( n, a, determ ) !*****************************************************************************80 ! !! r8mat_determinant() computes the determinant of a square R8MAT. ! ! Discussion: ! ! An R8MAT is a matrix of R8 values. ! ! Licensing: ! ! This code is distributed under the MIT license. ! ! Modified: ! ! 21 May 2002 ! ! Author: ! ! John Burkardt ! ! Input: ! ! integer N, the order of the matrix A. ! ! real ( kind = rk ) A(N,N), the matrix. ! ! Output: ! ! real ( kind = rk ) DETERM, the determinant. ! implicit none integer, parameter :: rk = kind ( 1.0D+00 ) integer n real ( kind = rk ) a(n,n) real ( kind = rk ) b(n,n) real ( kind = rk ) determ integer info integer pivot(n) b(1:n,1:n) = a(1:n,1:n) call r8mat_gefa ( b, n, pivot, info ) call r8mat_gedet ( b, n, pivot, determ ) return end subroutine r8mat_diag_get_vector ( n, a, v ) !*****************************************************************************80 ! !! r8mat_diag_get_vector() gets the value of the diagonal of a square R8MAT. ! ! Discussion: ! ! An R8MAT is a matrix of R8 values. ! ! Licensing: ! ! This code is distributed under the MIT license. ! ! Modified: ! ! 22 March 2001 ! ! Author: ! ! John Burkardt ! ! Input: ! ! integer N, the order of the matrix. ! ! real ( kind = rk ) A(N,N), the matrix. ! ! Output: ! ! real ( kind = rk ) V(N), the diagonal entries of the matrix. ! implicit none integer, parameter :: rk = kind ( 1.0D+00 ) integer n real ( kind = rk ) a(n,n) integer i real ( kind = rk ) v(n) do i = 1, n v(i) = a(i,i) end do return end subroutine r8mat_eigenvalues ( n, a, lambda ) !*****************************************************************************80 ! !! r8mat_eigenvalues() computes the eigenvalues of a square R8MAT. ! ! Discussion: ! ! An R8MAT is a matrix of real ( kind = rk ) values. ! ! This subroutine calls the recommended sequence of EISPACK routines. ! ! Licensing: ! ! This code is distributed under the MIT license. ! ! Modified: ! ! 27 May 2002 ! ! Author: ! ! John Burkardt ! ! Input: ! ! integer N, the order of the matrix. ! ! real ( kind = rk ) A(N,N), the matrix. ! ! Output: ! ! complex ( kind = ck ) LAMBDA(N), the eigenvalues. ! implicit none integer, parameter :: rk = kind ( 1.0D+00 ) integer, parameter :: ck = kind ( ( 1.0D+00, 1.0D+00 ) ) integer n real ( kind = rk ) a(n,n) real ( kind = rk ) a_copy(n,n) real ( kind = rk ) fv1(n) integer ierr integer is1 integer is2 integer iv1(n) complex ( kind = ck ) lambda(n) real ( kind = rk ) wi(n) real ( kind = rk ) wr(n) a_copy(1:n,1:n) = a(1:n,1:n) 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 ) lambda(1:n) = cmplx ( wr(1:n), wi(1:n), kind = ck ) return end subroutine r8mat_geco ( a, n, pivot, rcond, z ) !*****************************************************************************80 ! !! r8mat_geco() factors an R8MAT and estimates its condition number. ! ! Discussion: ! ! An R8MAT is a matrix of real ( kind = rk ) values. ! ! For the system A * X = B, relative perturbations in A and B ! of size EPSILON may cause relative perturbations in X of size ! EPSILON/RCOND. ! ! If RCOND is so small that the logical expression ! 1.0D+00 + rcond == 1.0D+00 ! is true, then A may be singular to working precision. In particular, ! RCOND is zero if exact singularity is detected or the estimate ! underflows. ! ! Licensing: ! ! This code is distributed under the MIT license. ! ! Modified: ! ! 29 May 2004 ! ! Author: ! ! Cleve Moler, ! University of New Mexico / Argonne National Lab. ! ! Reference: ! ! Jack Dongarra, Jim Bunch, Cleve Moler, Pete Stewart, ! LINPACK User's Guide, ! SIAM, 1979, ! ISBN13: 978-0-898711-72-1, ! LC: QA214.L56. ! ! Input: ! ! real ( kind = rk ) A(N,N), a matrix to be factored. ! ! integer N, the order of the matrix A. ! ! Output: ! ! real ( kind = rk ) A(N,N), the LU factorization of the matrix. ! ! integer PIVOT(N), the pivot indices. ! ! real ( kind = rk ) RCOND, an estimate of the reciprocal condition ! number of A. ! ! real ( kind = rk ) Z(N), a work vector whose contents are ! usually unimportant. If A is close to a singular matrix, then Z is ! an approximate null vector in the sense that ! norm ( A * Z ) = RCOND * norm ( A ) * norm ( Z ). ! implicit none integer, parameter :: rk = kind ( 1.0D+00 ) integer n real ( kind = rk ) a(n,n) real ( kind = rk ) anorm real ( kind = rk ) ek integer info integer j integer k integer l integer pivot(n) real ( kind = rk ) rcond real ( kind = rk ) s real ( kind = rk ) sm real ( kind = rk ) t real ( kind = rk ) wk real ( kind = rk ) wkm real ( kind = rk ) ynorm real ( kind = rk ) z(n) ! ! Compute the L1 norm of A. ! anorm = 0.0D+00 do j = 1, n anorm = max ( anorm, sum ( abs ( a(1:n,j) ) ) ) end do ! ! Compute the LU factorization. ! call r8mat_gefa ( a, n, pivot, info ) ! ! RCOND = 1 / ( norm(A) * (estimate of norm(inverse(A))) ) ! ! estimate of norm(inverse(A)) = norm(Z) / norm(Y) ! ! where ! A * Z = Y ! and ! A' * Y = E ! ! The components of E are chosen to cause maximum local growth in the ! elements of W, where U'*W = E. The vectors are frequently rescaled ! to avoid overflow. ! ! Solve U' * W = E. ! ek = 1.0D+00 z(1:n) = 0.0D+00 do k = 1, n if ( z(k) /= 0.0D+00 ) then ek = sign ( ek, -z(k) ) end if if ( abs ( a(k,k) ) < abs ( ek - z(k) ) ) then s = abs ( a(k,k) ) / abs ( ek - z(k) ) z(1:n) = s * z(1:n) ek = s * ek end if wk = ek - z(k) wkm = -ek - z(k) s = abs ( wk ) sm = abs ( wkm ) if ( a(k,k) /= 0.0D+00 ) then wk = wk / a(k,k) wkm = wkm / a(k,k) else wk = 1.0D+00 wkm = 1.0D+00 end if if ( k+1 <= n ) then do j = k+1, n sm = sm + abs ( z(j) + wkm * a(k,j) ) z(j) = z(j) + wk * a(k,j) s = s + abs ( z(j) ) end do if ( s < sm ) then t = wkm - wk wk = wkm z(k+1:n) = z(k+1:n) + t * a(k,k+1:n) end if end if z(k) = wk end do z(1:n) = z(1:n) / sum ( abs ( z(1:n) ) ) ! ! Solve L' * Y = W ! do k = n, 1, -1 z(k) = z(k) + dot_product ( a(k+1:n,k), z(k+1:n) ) if ( 1.0D+00 < abs ( z(k) ) ) then z(1:n) = z(1:n) / abs ( z(k) ) end if l = pivot(k) t = z(l) z(l) = z(k) z(k) = t end do z(1:n) = z(1:n) / sum ( abs ( z(1:n) ) ) ynorm = 1.0D+00 ! ! Solve L * V = Y. ! do k = 1, n l = pivot(k) t = z(l) z(l) = z(k) z(k) = t z(k+1:n) = z(k+1:n) + t * a(k+1:n,k) if ( 1.0D+00 < abs ( z(k) ) ) then ynorm = ynorm / abs ( z(k) ) z(1:n) = z(1:n) / abs ( z(k) ) end if end do s = sum ( abs ( z(1:n) ) ) z(1:n) = z(1:n) / s ynorm = ynorm / s ! ! Solve U * Z = V. ! do k = n, 1, -1 if ( abs ( a(k,k) ) < abs ( z(k) ) ) then s = abs ( a(k,k) ) / abs ( z(k) ) z(1:n) = s * z(1:n) ynorm = s * ynorm end if if ( a(k,k) /= 0.0D+00 ) then z(k) = z(k) / a(k,k) else z(k) = 1.0D+00 end if z(1:k-1) = z(1:k-1) - z(k) * a(1:k-1,k) end do ! ! Normalize Z in the L1 norm. ! s = 1.0D+00 / sum ( abs ( z(1:n) ) ) z(1:n) = s * z(1:n) ynorm = s * ynorm if ( anorm /= 0.0D+00 ) then rcond = ynorm / anorm else rcond = 0.0D+00 end if return end subroutine r8mat_gedet ( a, n, pivot, determ ) !*****************************************************************************80 ! !! r8mat_gedet() computes the determinant of an R8MAT factored by R8MAT_GEFA. ! ! Discussion: ! ! An R8MAT is a matrix of R8 values. ! ! This is a modified version of the LINPACK routine DGEDI. ! ! Licensing: ! ! This code is distributed under the MIT license. ! ! Modified: ! ! 25 March 2001 ! ! Author: ! ! John Burkardt ! ! Reference: ! ! Jack Dongarra, Cleve Moler, Jim Bunch, Pete Stewart, ! LINPACK User's Guide, ! SIAM, (Society for Industrial and Applied Mathematics), ! 3600 University City Science Center, ! Philadelphia, PA, 19104-2688. ! ISBN: 0-89871-172-X. ! ! Input: ! ! real ( kind = rk ) A(N,N), the LU factors computed by R8MAT_GEFA. ! ! integer N, the order of the matrix. ! N must be positive. ! ! integer PIVOT(N), as computed by R8MAT_GEFA. ! ! Output: ! ! real ( kind = rk ) DETERM, the determinant of the matrix. ! implicit none integer, parameter :: rk = kind ( 1.0D+00 ) integer n real ( kind = rk ) a(n,n) real ( kind = rk ) determ integer i integer pivot(n) determ = 1.0D+00 do i = 1, n determ = determ * a(i,i) end do do i = 1, n if ( pivot(i) /= i ) then determ = - determ end if end do return end subroutine r8mat_gefa ( a, n, pivot, info ) !*****************************************************************************80 ! !! r8mat_gefa() factors an R8MAT. ! ! Discussion: ! ! An R8MAT is a matrix of R8 values. ! ! This is a simplified version of the LINPACK routine DGEFA. ! ! Licensing: ! ! This code is distributed under the MIT license. ! ! Modified: ! ! 25 March 2001 ! ! Author: ! ! John Burkardt ! ! Reference: ! ! Jack Dongarra, Cleve Moler, Jim Bunch, Pete Stewart, ! LINPACK User's Guide, ! SIAM, (Society for Industrial and Applied Mathematics), ! 3600 University City Science Center, ! Philadelphia, PA, 19104-2688. ! ISBN 0-89871-172-X ! ! Input: ! ! real ( kind = rk ) A(N,N), the matrix to be factored. ! ! integer N, the order of the matrix. ! N must be positive. ! ! Output: ! ! real ( kind = rk ) A(N,N), an upper triangular matrix and the multipliers ! which were used to obtain it. The factorization can be written ! A = L * U, where L is a product of permutation and unit lower ! triangular matrices and U is upper triangular. ! ! integer PIVOT(N), a vector of pivot indices. ! ! integer INFO, singularity flag. ! 0, no singularity detected. ! nonzero, the factorization failed on the INFO-th step. ! implicit none integer, parameter :: rk = kind ( 1.0D+00 ) integer n real ( kind = rk ) a(n,n) logical, parameter :: debug = .false. integer i integer info integer j integer k integer l integer pivot(n) real ( kind = rk ) t info = 0 pivot(1:n) = 0 do k = 1, n - 1 ! ! Find L, the index of the pivot row. ! l = k do i = k + 1, n if ( abs ( a(l,k) ) < abs ( a(i,k) ) ) then l = i end if end do pivot(k) = l ! ! If the pivot index is zero, the algorithm has failed. ! if ( a(l,k) == 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 ! ! Interchange rows L and K if necessary. ! if ( l /= k ) then t = a(l,k) a(l,k) = a(k,k) a(k,k) = t end if ! ! Normalize the values that lie below the pivot entry A(K,K). ! a(k+1:n,k) = - a(k+1:n,k) / a(k,k) ! ! Row elimination with column indexing. ! do j = k + 1, n if ( l /= k ) then t = a(l,j) a(l,j) = a(k,j) a(k,j) = t end if a(k+1:n,j) = a(k+1:n,j) + a(k+1:n,k) * a(k,j) end do end do pivot(n) = n if ( a(n,n) == 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 ) !*****************************************************************************80 ! !! r8mat_geinverse() computes the inverse of an R8MAT factored by R8MAT_GEFA. ! ! Discussion: ! ! An R8MAT is a matrix of real ( kind = rk ) values. ! ! R8MAT_GEINVERSE is a modified version of the LINPACK routine DGEDI. ! ! Licensing: ! ! This code is distributed under the MIT license. ! ! Modified: ! ! 25 March 2001 ! ! Author: ! ! John Burkardt ! ! Reference: ! ! Jack Dongarra, Cleve Moler, Jim Bunch, Pete Stewart, ! LINPACK User's Guide, ! SIAM, (Society for Industrial and Applied Mathematics), ! 3600 University City Science Center, ! Philadelphia, PA, 19104-2688. ! ISBN 0-89871-172-X ! ! Input: ! ! real ( kind = rk ) A(N,N), the factor information computed by R8MAT_GEFA. ! ! integer N, the order of the matrix A. ! ! integer PIVOT(N), the pivot vector from R8MAT_GEFA. ! ! Output: ! ! real ( kind = rk ) A(N,N), the inverse matrix. ! implicit none integer, parameter :: rk = kind ( 1.0D+00 ) integer n real ( kind = rk ) a(n,n) integer i integer pivot(n) integer j integer k real ( kind = rk ) t real ( kind = rk ) work(n) ! ! Compute Inverse(U). ! do k = 1, n a(k,k) = 1.0D+00 / a(k,k) a(1:k-1,k) = - a(1:k-1,k) * a(k,k) do j = k + 1, n t = a(k,j) a(k,j) = 0.0D+00 a(1:k,j) = a(1:k,j) + t * a(1:k,k) end do end do ! ! Form Inverse(U) * Inverse(L). ! do k = n - 1, 1, -1 work(k+1:n) = a(k+1:n,k) a(k+1:n,k) = 0.0D+00 do j = k + 1, n a(1:n,k) = a(1:n,k) + work(j) * a(1:n,j) end do if ( pivot(k) /= k ) then do i = 1, n t = a(i,k) a(i,k) = a(i,pivot(k)) a(i,pivot(k)) = t end do end if end do return end subroutine r8mat_geplu ( m, n, a, p, l, u ) !*****************************************************************************80 ! !! r8mat_geplu() produces the PLU factors of an R8MAT. ! ! Discussion: ! ! An R8MAT is a matrix of real ( kind = rk ) values. ! ! The PLU factors of the M by N matrix A are: ! ! P, an M by M permutation matrix P, ! L, an M by M unit lower triangular matrix, ! U, an M by N upper triangular matrix. ! ! Licensing: ! ! This code is distributed under the MIT license. ! ! Modified: ! ! 30 April 2000 ! ! Author: ! ! John Burkardt ! ! Input: ! ! integer M, N, the order of the matrix. ! ! real ( kind = rk ) A(M,N), the matrix to be factored. ! ! Output: ! ! real ( kind = rk ) P(M,M), the permutation factor. ! ! real ( kind = rk ) L(M,M), the unit lower triangular factor. ! ! real ( kind = rk ) U(M,N), the upper triangular factor. ! implicit none integer, parameter :: rk = kind ( 1.0D+00 ) integer m integer n real ( kind = rk ) a(m,n) integer i integer j real ( kind = rk ) l(m,m) real ( kind = rk ) p(m,m) integer pivot_row real ( kind = rk ) pivot_value real ( kind = rk ) u(m,n) ! ! Initialize: ! ! P:=Identity ! L:=Identity ! U:=A ! call identity_matrix ( m, m, p ) call identity_matrix ( m, m, l ) u(1:m,1:n) = a(1:m,1:n) ! ! On step J, find the pivot row and the pivot value. ! do j = 1, min ( m - 1, n ) pivot_value = 0.0D+00 pivot_row = 0 do i = j, m if ( pivot_value < abs ( u(i,j) ) ) then pivot_value = abs ( u(i,j) ) pivot_row = i end if end do ! ! If the pivot row is nonzero, swap rows J and PIVOT_ROW. ! if ( pivot_row /= 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 ) ! ! Zero out the entries in column J, from row J+1 to M. ! do i = j + 1, m if ( u(i,j) /= 0.0D+00 ) then l(i,j) = u(i,j) / u(j,j) u(i,j) = 0.0D+00 u(i,j+1:n) = u(i,j+1:n) - l(i,j) * u(j,j+1:n) end if end do end if end do return end subroutine r8mat_gesl ( a, n, pivot, b, job ) !*****************************************************************************80 ! !! r8mat_gesl() solves a system factored by R8MAT_GEFA. ! ! Discussion: ! ! An R8MAT is a matrix of real ( kind = rk ) values. ! ! This is a simplified version of the LINPACK routine DGESL. ! ! Licensing: ! ! This code is distributed under the MIT license. ! ! Modified: ! ! 04 March 1999 ! ! Author: ! ! John Burkardt ! ! Reference: ! ! Jack Dongarra, Cleve Moler, Jim Bunch, Pete Stewart, ! LINPACK User's Guide, ! SIAM, (Society for Industrial and Applied Mathematics), ! 3600 University City Science Center, ! Philadelphia, PA, 19104-2688. ! ISBN 0-89871-172-X ! ! Input: ! ! real ( kind = rk ) A(N,N), the LU factors from R8MAT_GEFA. ! ! integer N, the order of the matrix. ! N must be positive. ! ! integer PIVOT(N), the pivot vector from R8MAT_GEFA. ! ! real ( kind = rk ) B(N), the right hand side vector. ! ! integer JOB, specifies the operation. ! 0, solve A * x = b. ! nonzero, solve A' * x = b. ! ! Output: ! ! real ( kind = rk ) B(N), the solution vector. ! implicit none integer, parameter :: rk = kind ( 1.0D+00 ) integer n real ( kind = rk ) a(n,n) real ( kind = rk ) b(n) integer job integer k integer l integer pivot(n) real ( kind = rk ) t ! ! Solve A * x = b. ! if ( job == 0 ) then ! ! Solve PL * Y = B. ! do k = 1, n - 1 l = pivot(k) if ( l /= k ) then t = b(l) b(l) = b(k) b(k) = t end if b(k+1:n) = b(k+1:n) + a(k+1:n,k) * b(k) end do ! ! Solve U * X = Y. ! do k = n, 1, -1 b(k) = b(k) / a(k,k) b(1:k-1) = b(1:k-1) - a(1:k-1,k) * b(k) end do ! ! Solve A' * X = B. ! else ! ! Solve U' * Y = B. ! do k = 1, n b(k) = ( b(k) - dot_product ( b(1:k-1), a(1:k-1,k) ) ) / a(k,k) end do ! ! Solve ( PL )' * X = Y. ! do k = n - 1, 1, -1 b(k) = b(k) + dot_product ( b(k+1:n), a(k+1:n,k) ) l = pivot(k) if ( l /= 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 ) !*****************************************************************************80 ! !! r8mat_house_axh() computes A*H where H is a compact Householder matrix. ! ! Discussion: ! ! An R8MAT is a matrix of real ( kind = rk ) values. ! ! The Householder matrix H(V) is defined by ! ! H(V) = I - 2 * v * v' / ( v' * v ) ! ! This routine is not particularly efficient. ! ! Licensing: ! ! This code is distributed under the MIT license. ! ! Modified: ! ! 26 March 2000 ! ! Author: ! ! John Burkardt ! ! Input: ! ! integer N, the order of the matrix. ! ! real ( kind = rk ) A(N,N), the matrix. ! ! real ( kind = rk ) V(N), a vector defining a Householder matrix. ! ! Output: ! ! real ( kind = rk ) AH(N,N), the product A*H. ! implicit none integer, parameter :: rk = kind ( 1.0D+00 ) integer n real ( kind = rk ) a(n,n) real ( kind = rk ) ah(n,n) real ( kind = rk ) ah_temp(n,n) integer i integer j integer k real ( kind = rk ) v(n) real ( kind = rk ) v_normsq v_normsq = sum ( v(1:n) ** 2 ) ! ! Compute A*H' = A*H ! do i = 1, n do j = 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) * v(j) / v_normsq end do end do end do ! ! Copy the temporary result into AH. ! Doing it this way means the user can identify the input arguments A and AH. ! ah(1:n,1:n) = ah_temp(1:n,1:n) return end subroutine r8mat_house_form ( n, v, h ) !*****************************************************************************80 ! !! r8mat_house_form() constructs a Householder matrix from its compact form. ! ! Discussion: ! ! An R8MAT is a matrix of real ( kind = rk ) values. ! ! H(v) = I - 2 * v * v' / ( v' * v ) ! ! Licensing: ! ! This code is distributed under the MIT license. ! ! Modified: ! ! 24 March 2000 ! ! Author: ! ! John Burkardt ! ! Input: ! ! integer N, the order of the matrix. ! ! real ( kind = rk ) V(N), the vector defining the Householder matrix. ! ! Output: ! ! real ( kind = rk ) H(N,N), the Householder matrix. ! implicit none integer, parameter :: rk = kind ( 1.0D+00 ) integer n real ( kind = rk ) beta real ( kind = rk ) h(n,n) integer i integer j real ( kind = rk ) v(n) ! ! Compute the L2 norm of V. ! beta = sum ( v(1:n) ** 2 ) ! ! Form the matrix H. ! 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 ) !*****************************************************************************80 ! !! r8mat_identity() sets an R8MAT to the identity. ! ! Discussion: ! ! An R8MAT is a matrix of real ( kind = rk ) values. ! ! Licensing: ! ! This code is distributed under the MIT license. ! ! Modified: ! ! 24 March 2000 ! ! Author: ! ! John Burkardt ! ! Input: ! ! integer N, the order of the matrix. ! ! Output: ! ! real ( kind = rk ) A(N,N), the matrix which has been set ! to the identity. ! implicit none integer, parameter :: rk = kind ( 1.0D+00 ) integer n real ( kind = rk ) a(n,n) integer i a(1:n,1:n) = 0.0D+00 do i = 1, n a(i,i) = 1.0D+00 end do return end subroutine r8mat_inverse ( n, a, b ) !*****************************************************************************80 ! !! r8mat_inverse() computes the inverse of an R8MAT. ! ! Discussion: ! ! An R8MAT is a matrix of real ( kind = rk ) values. ! ! Licensing: ! ! This code is distributed under the MIT license. ! ! Modified: ! ! 22 May 2002 ! ! Author: ! ! John Burkardt ! ! Input: ! ! integer N, the orderof the matrix A. ! ! real ( kind = rk ) A(N,N), the matrix. ! ! Output: ! ! real ( kind = rk ) B(N,N), the inverse matrix. ! implicit none integer, parameter :: rk = kind ( 1.0D+00 ) integer n real ( kind = rk ) a(n,n) real ( kind = rk ) b(n,n) integer info integer pivot(n) b(1:n,1:n) = a(1:n,1:n) call r8mat_gefa ( b, n, pivot, info ) call r8mat_geinverse ( b, n, pivot ) return end subroutine r8mat_is_adjacency ( m, n, a, ival ) !*****************************************************************************80 ! !! r8mat_is_adjacency() checks whether an R8MAT is an adjacency matrix. ! ! Discussion: ! ! An R8MAT is a matrix of real ( kind = rk ) values. ! ! Licensing: ! ! This code is distributed under the MIT license. ! ! Modified: ! ! 07 July 2000 ! ! Author: ! ! John Burkardt ! ! Input: ! ! integer M, N, the row and column dimensions of ! the matrix. M and N must be positive. ! ! real ( kind = rk ) A(M,N), the matrix. ! ! Output: ! ! integer IVAL: ! -1, the matrix is not an adjacency matrix. ! 1, the matrix is an adjacency matrix. ! implicit none integer, parameter :: rk = kind ( 1.0D+00 ) integer m integer n real ( kind = rk ) a(m,n) real ( kind = rk ) error_frobenius integer ival integer jval logical r8mat_is_square real ( kind = rk ), parameter :: tol = 0.00001D+00 if ( .not. r8mat_is_square ( m, n, a ) ) then ival = -1 return end if call r8mat_is_symmetric ( m, n, a, error_frobenius ) if ( tol < error_frobenius ) then ival = -1 return end if call r8mat_is_zero_one ( m, n, a, jval ) if ( jval /= 1 ) then ival = -1 return end if return end subroutine r8mat_is_anticirculant ( m, n, a, ival ) !*****************************************************************************80 ! !! r8mat_is_anticirculant() checks whether an R8MAT is an anticirculant matrix. ! ! Discussion: ! ! An R8MAT is a matrix of real ( kind = rk ) values. ! ! Licensing: ! ! This code is distributed under the MIT license. ! ! Modified: ! ! 01 July 2000 ! ! Author: ! ! John Burkardt ! ! Input: ! ! integer M, N, the row and column dimensions of ! the matrix. M and N must be positive. ! ! real ( kind = rk ) A(M,N), the matrix. ! ! Output: ! ! integer IVAL: ! -1, the matrix is not anticirculant. ! 1, the matrix is anticirculant. ! implicit none integer, parameter :: rk = kind ( 1.0D+00 ) integer m integer n real ( kind = rk ) 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) /= a(1,k) ) then ival = -1 return end if end do end do return end subroutine r8mat_is_antipersymmetric ( m, n, a, error_frobenius ) !*****************************************************************************80 ! !! r8mat_is_antipersymmetric() checks an R8MAT for antipersymmetry. ! ! Discussion: ! ! An R8MAT is a matrix of real ( kind = rk ) values. ! ! A is antipersymmetric if A(I,J) = -A(N+1-J,N+1-I). ! ! Licensing: ! ! This code is distributed under the MIT license. ! ! Modified: ! ! 20 February 2018 ! ! Author: ! ! John Burkardt ! ! Input: ! ! integer M, N, the row and column dimensions of ! the matrix. M and N must be positive. ! ! real ( kind = rk ) A(M,N), the matrix. ! ! Output: ! ! real ( kind = rk ) ERROR_FROBENIUS, is 0.0 if the matrix ! is exactly antipersymmetric. ! implicit none integer, parameter :: rk = kind ( 1.0D+00 ) integer m integer n real ( kind = rk ) a(m,n) real ( kind = rk ) error_frobenius integer i integer j real ( kind = rk ) r8_huge logical r8mat_is_square if ( .not. r8mat_is_square ( m, n, a ) ) then error_frobenius = r8_huge ( ) return end if error_frobenius = 0.0D+00 do i = 1, m do j = 1, n error_frobenius = error_frobenius & + ( a(i,j) + a(n+1-j,n+1-i) ) ** 2 end do end do error_frobenius = sqrt ( error_frobenius ) return end subroutine r8mat_is_antisymmetric ( m, n, a, error_frobenius ) !*****************************************************************************80 ! !! r8mat_is_antisymmetric() checks an R8MAT for antisymmetry. ! ! Discussion: ! ! An R8MAT is a matrix of real ( kind = rk ) values. ! ! Licensing: ! ! This code is distributed under the MIT license. ! ! Modified: ! ! 04 November 2007 ! ! Author: ! ! John Burkardt ! ! Input: ! ! integer M, N, the row and column dimensions of ! the matrix. M and N must be positive. ! ! real ( kind = rk ) A(M,N), the matrix. ! ! Output: ! ! real ( kind = rk ) ERROR_FROBENIUS, the Frobenius error in ! antisymmetry, which would be 0 if the matrix is exactly antisymmetric. ! implicit none integer, parameter :: rk = kind ( 1.0D+00 ) integer m integer n real ( kind = rk ) a(m,n) real ( kind = rk ) error_frobenius integer i integer j real ( kind = rk ) r8_huge logical r8mat_is_square if ( .not. r8mat_is_square ( m, n, a ) ) then error_frobenius = r8_huge ( ) return end if error_frobenius = 0.0D+00 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_banded ( m, n, a, ival, jval ) !*****************************************************************************80 ! !! r8mat_is_banded() determines whether an R8MAT is banded. ! ! Discussion: ! ! An R8MAT is a matrix of real ( kind = rk ) values. ! ! Licensing: ! ! This code is distributed under the MIT license. ! ! Modified: ! ! 13 November 1998 ! ! Author: ! ! John Burkardt ! ! Input: ! ! integer M, N, the row and column dimensions of ! the matrix. M and N must be positive. ! ! real ( kind = rk ) A(M,N), the matrix. ! ! Output: ! ! integer IVAL, the lower bandwidth, measured as the ! number of nonzero diagonals, starting with the main diagonal ! and proceeding down, with values between 0 and M. ! ! integer JVAL, the upper bandwidth, measured as the ! number of nonzero diagonals, starting with the main diagonal ! and proceeding right, with values between 0 and N. ! implicit none integer, parameter :: rk = kind ( 1.0D+00 ) integer m integer n real ( kind = rk ) 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) /= 0.0D+00 ) then if ( i <= j ) then jval = max ( jval, j + 1 - i ) end if if ( j <= i ) then ival = max ( ival, i + 1 - j ) end if end if end do end do return end subroutine r8mat_is_centrosymmetric ( m, n, a, ival ) !*****************************************************************************80 ! !! r8mat_is_centrosymmetric() checks an R8MAT for centrosymmetry. ! ! Discussion: ! ! An R8MAT is a matrix of real ( kind = rk ) values. ! ! A is centrosymmetric: A(I,J) = A(N+1-I,N+1-J). ! ! Licensing: ! ! This code is distributed under the MIT license. ! ! Modified: ! ! 23 May 2002 ! ! Author: ! ! John Burkardt ! ! Input: ! ! integer M, N, the row and column dimensions of ! the matrix. M and N must be positive. ! ! real ( kind = rk ) A(M,N), the matrix. ! ! Output: ! ! integer IVAL: ! -1, the matrix is not centrosymmetric. ! 1, the matrix is centrosymmetric. ! implicit none integer, parameter :: rk = kind ( 1.0D+00 ) integer m integer n real ( kind = rk ) 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-i,n+1-j) ) then ival = -1 return end if end do end do return end subroutine r8mat_is_circulant ( m, n, a, ival ) !*****************************************************************************80 ! !! R8MAT_IS_CIRCULANT checks whether an R8MAT is a circulant matrix. ! ! Discussion: ! ! An R8MAT is a matrix of real ( kind = rk ) values. ! ! Licensing: ! ! This code is distributed under the MIT license. ! ! Modified: ! ! 01 July 2000 ! ! Author: ! ! John Burkardt ! ! Input: ! ! integer M, N, the row and column dimensions of ! the matrix. M and N must be positive. ! ! real ( kind = rk ) A(M,N), the matrix. ! ! Output: ! ! integer IVAL: ! -1, the matrix is not circulant. ! 1, the matrix is circulant. ! implicit none integer, parameter :: rk = kind ( 1.0D+00 ) integer m integer n real ( kind = rk ) 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) /= a(1,k) ) then ival = -1 return end if end do end do return end subroutine r8mat_is_cyclic_tridiagonal ( m, n, a, ival ) !*****************************************************************************80 ! !! r8mat_is_cyclic_tridiagonal() determines if an R8MAT is cyclic tridiagonal. ! ! Discussion: ! ! An R8MAT is a matrix of real ( kind = rk ) values. ! ! Licensing: ! ! This code is distributed under the MIT license. ! ! Modified: ! ! 23 May 2002 ! ! Author: ! ! John Burkardt ! ! Input: ! ! integer M, N, the order of the matrix. ! M and N must be positive. ! ! real ( kind = rk ) A(M,N), the matrix. ! ! Output: ! ! integer IVAL, the report: ! -1, the matrix is not square. ! -2, the matrix has illegal nonzero values. ! 1, the matrix is cyclic tridiagonal. ! implicit none integer, parameter :: rk = kind ( 1.0D+00 ) integer m integer n real ( kind = rk ) a(m,n) integer i integer ival integer j integer k logical r8mat_is_square if ( .not. r8mat_is_square ( m, n, a ) ) then ival = -1 return end if do i = 1, n j = i + 1 do k = 1, n - 3 j = j + 1 if ( n < j ) then j = j - n end if if ( a(i,j) /= 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 ) !*****************************************************************************80 ! !! r8mat_is_diag2() counts the number of nonzero diagonals in an R8MAT. ! ! Discussion: ! ! An R8MAT is a matrix of real ( kind = rk ) values. ! ! Licensing: ! ! This code is distributed under the MIT license. ! ! Modified: ! ! 07 November 1998 ! ! Author: ! ! John Burkardt ! ! Input: ! ! integer M, N, the row and column dimensions of ! the matrix. M and N must be positive. ! ! real ( kind = rk ) A(M,N), the matrix. ! ! Output: ! ! integer IVAL, the number of nonzero diagonals. ! implicit none integer, parameter :: rk = kind ( 1.0D+00 ) integer m integer n real ( kind = rk ) 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) /= 0 ) then nonzero = 1 end if end do ival = ival + nonzero end do return end subroutine r8mat_is_diagonally_dominant ( n, a, ival ) !*****************************************************************************80 ! !! r8mat_is_diagonally_dominant() checks whether an R8MAT is diagonally dominant. ! ! Discussion: ! ! The matrix is required to be square. ! ! An R8MAT is a matrix of real ( kind = rk ) values. ! ! Licensing: ! ! This code is distributed under the MIT license. ! ! Modified: ! ! 08 April 2015 ! ! Author: ! ! John Burkardt ! ! Input: ! ! integer N, the row and column dimensions of ! the matrix. N must be positive. ! ! real ( kind = rk ) A(N,N), the matrix. ! ! Output: ! ! integer IVAL: ! -1, the matrix is not diagonally dominant. ! 1, the matrix is diagonally dominant. ! 2, the matrix is strictly diagonally dominant. ! implicit none integer, parameter :: rk = kind ( 1.0D+00 ) integer n real ( kind = rk ) a(n,n) integer i integer ival integer j integer k real ( kind = rk ) s real ( kind = rk ) sumi real ( kind = rk ) sumj ival = 2 do k = 1, n s = abs ( a(k,k) ) sumj = 0.0D+00 do j = 1, n if ( j /= k ) then sumj = sumj + abs ( a(k,j) ) end if end do sumi = 0.0D+00 do i = 1, n if ( i /= k ) then sumi = sumi + abs ( a(i,k) ) end if end do if ( s < sumi .or. s < sumj ) then ival = -1 return else if ( s == sumi .or. s == sumj ) then ival = 1 end if end do return end subroutine r8mat_is_diagonally_dominant_column ( m, n, a, ival ) !*****************************************************************************80 ! !! r8mat_is_diagonally_dominant_column(): is an R8MAT column diagonally dominant. ! ! Discussion: ! ! An R8MAT is a matrix of real ( kind = rk ) values. ! ! Licensing: ! ! This code is distributed under the MIT license. ! ! Modified: ! ! 08 April 2015 ! ! Author: ! ! John Burkardt ! ! Input: ! ! integer M, N, the row and column dimensions of ! the matrix. M and N must be positive. ! ! real ( kind = rk ) A(M,N), the matrix. ! ! Output: ! ! integer IVAL: ! -1, the matrix is not column diagonally dominant. ! 1, the matrix is column diagonally dominant. ! 2, the matrix is strictly column diagonally dominant. ! implicit none integer, parameter :: rk = kind ( 1.0D+00 ) integer m integer n real ( kind = rk ) a(m,n) integer i integer ival integer j real ( kind = rk ) s real ( kind = rk ) sumi ival = 2 do j = 1, min ( m, n ) s = abs ( a(j,j) ) sumi = 0.0D+00 do i = 1, m if ( j /= i ) then sumi = sumi + abs ( a(i,j) ) end if end do if ( s < sumi ) then ival = -1 return else if ( s == sumi ) then ival = min ( ival, 1 ) end if end do return end subroutine r8mat_is_diagonally_dominant_row ( m, n, a, ival ) !*****************************************************************************80 ! !! r8mat_is_diagonally_dominant_row(): is an R8MAT row diagonally dominant. ! ! Discussion: ! ! An R8MAT is a matrix of real ( kind = rk ) values. ! ! Licensing: ! ! This code is distributed under the MIT license. ! ! Modified: ! ! 08 April 2015 ! ! Author: ! ! John Burkardt ! ! Input: ! ! integer M, N, the row and column dimensions of ! the matrix. M and N must be positive. ! ! real ( kind = rk ) A(M,N), the matrix. ! ! Output: ! ! integer IVAL: ! -1, the matrix is not row diagonally dominant. ! 1, the matrix is row diagonally dominant. ! 2, the matrix is strictly row diagonally dominant. ! implicit none integer, parameter :: rk = kind ( 1.0D+00 ) integer m integer n real ( kind = rk ) a(m,n) integer i integer ival integer j real ( kind = rk ) s real ( kind = rk ) sumj ival = 2 do i = 1, min ( m, n ) s = abs ( a(i,i) ) sumj = 0.0D+00 do j = 1, n if ( j /= i ) then sumj = sumj + abs ( a(i,j) ) end if end do if ( s < sumj ) then ival = -1 return else if ( s == sumj ) then ival = min ( ival, +1 ) end if end do return end subroutine r8mat_is_eigen_left ( n, k, a, x, lambda, error_frobenius ) !*****************************************************************************80 ! !! r8mat_is_eigen_left() determines the error in a left eigensystem. ! ! Discussion: ! ! An R8MAT is a matrix of real ( kind = rk ) values. ! ! This routine computes the Frobenius norm of ! ! X * A - LAMBDA * X ! ! where ! ! A is an N by N matrix, ! X is a K by N matrix (each of K rows is a left eigenvector) ! LAMBDA is a K by K diagonal matrix of eigenvalues. ! ! Licensing: ! ! This code is distributed under the MIT license. ! ! Modified: ! ! 13 March 2015 ! ! Author: ! ! John Burkardt ! ! Input: ! ! integer N, the order of the matrix. ! ! integer K, the number of eigenvectors. ! K is usually 1 or N. ! ! real ( kind = rk ) A(N,N), the matrix. ! ! real ( kind = rk ) X(K,N), the K eigenvectors. ! ! real ( kind = rk ) LAMBDA(K), the K eigenvalues. ! ! Output: ! ! real ( kind = rk ) ERROR_FROBENIUS, the Frobenius norm ! of the X * A - LAMBDA * X. ! implicit none integer, parameter :: rk = kind ( 1.0D+00 ) integer k integer n real ( kind = rk ) a(n,n) real ( kind = rk ) c(k,n) real ( kind = rk ) error_frobenius integer i real ( kind = rk ) lambda(k) real ( kind = rk ) r8mat_norm_fro real ( kind = rk ) x(k,n) c(1:k,1:n) = matmul ( x(1:k,1:n), a(1:n,1:n) ) do i = 1, k c(i,1:n) = c(i,1:n) - lambda(i) * x(i,1:n) end do error_frobenius = r8mat_norm_fro ( k, n, c ) return end subroutine r8mat_is_eigen_right ( n, k, a, x, lambda, error_frobenius ) !*****************************************************************************80 ! !! r8mat_is_eigen_right() determines the error in a right eigensystem. ! ! Discussion: ! ! An R8MAT is a matrix of real ( kind = rk ) values. ! ! This routine computes the Frobenius norm of ! ! A * X - X * LAMBDA ! ! where ! ! A is an N by N matrix, ! X is an N by K matrix (each of K columns is an eigenvector) ! LAMBDA is a K by K diagonal matrix of eigenvalues. ! ! This routine assumes that A, X and LAMBDA are all real! ! ! Licensing: ! ! This code is distributed under the MIT license. ! ! Modified: ! ! 24 November 2007 ! ! Author: ! ! John Burkardt ! ! Input: ! ! integer N, the order of the matrix. ! ! integer K, the number of eigenvectors. ! K is usually 1 or N. ! ! real ( kind = rk ) A(N,N), the matrix. ! ! real ( kind = rk ) X(N,K), the K eigenvectors. ! ! real ( kind = rk ) LAMBDA(K), the K eigenvalues. ! ! Output: ! ! real ( kind = rk ) ERROR_FROBENIUS, the Frobenius norm ! of the difference matrix A * X - X * LAMBDA, which would be exactly zero ! if X and LAMBDA were exact eigenvectors and eigenvalues of A. ! implicit none integer, parameter :: rk = kind ( 1.0D+00 ) integer k integer n real ( kind = rk ) a(n,n) real ( kind = rk ) c(n,k) real ( kind = rk ) error_frobenius integer j real ( kind = rk ) lambda(k) real ( kind = rk ) r8mat_norm_fro real ( kind = rk ) x(n,k) c(1:n,1:k) = matmul ( a(1:n,1:n), x(1:n,1:k) ) do j = 1, k c(1:n,j) = c(1:n,j) - lambda(j) * x(1:n,j) end do error_frobenius = r8mat_norm_fro ( n, k, c ) return end subroutine r8mat_is_hankel ( m, n, a, ival ) !*****************************************************************************80 ! !! r8mat_is_hankel() checks whether an R8MAT is Hankel. ! ! Discussion: ! ! An R8MAT is a matrix of real ( kind = rk ) values. ! ! A Hankel matrix is one which is constant along each anti-diagonal. ! ! Licensing: ! ! This code is distributed under the MIT license. ! ! Modified: ! ! 01 July 2000 ! ! Author: ! ! John Burkardt ! ! Input: ! ! integer M, N, the row and column dimensions of ! the matrix. M and N must be positive. ! ! real ( kind = rk ) A(M,N), the matrix. ! ! Output: ! ! integer IVAL: ! -1, the matrix is not Hankel. ! 1, the matrix is Hankel. ! implicit none integer, parameter :: rk = kind ( 1.0D+00 ) integer m integer n real ( kind = rk ) a(m,n) integer i integer ihi integer ilo integer ipj integer ival real ( kind = rk ) 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) /= s ) then ival = -1 return end if end do end do return end subroutine r8mat_is_identity ( n, a, error_frobenius ) !*****************************************************************************80 ! !! r8mat_is_identity() determines if an R8MAT is the identity. ! ! Discussion: ! ! An R8MAT is a matrix of real ( kind = rk ) values. ! ! The routine returns the Frobenius norm of A - I. ! ! Licensing: ! ! This code is distributed under the MIT license. ! ! Modified: ! ! 02 November 2007 ! ! Author: ! ! John Burkardt ! ! Input: ! ! integer N, the order of the matrix. ! ! real ( kind = rk ) A(N,N), the matrix. ! ! Output: ! ! real ( kind = rk ) ERROR_FROBENIUS, the Frobenius norm ! of the difference matrix A - I, which would be exactly zero ! if A were the identity matrix. ! implicit none integer, parameter :: rk = kind ( 1.0D+00 ) integer n real ( kind = rk ) a(n,n) real ( kind = rk ) error_frobenius integer i integer j error_frobenius = 0.0D+00 do i = 1, n do j = 1, n if ( i == 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_integer ( m, n, a, error_frobenius ) !*****************************************************************************80 ! !! r8mat_is_integer() checks whether an R8MAT has only integer entries. ! ! Discussion: ! ! An R8MAT is a matrix of real ( kind = rk ) values. ! ! Licensing: ! ! This code is distributed under the MIT license. ! ! Modified: ! ! 03 November 2007 ! ! Author: ! ! John Burkardt ! ! Input: ! ! integer M, N, the row and column dimensions of ! the matrix. M and N must be positive. ! ! real ( kind = rk ) A(M,N), the matrix. ! ! Output: ! ! real ( kind = rk ) ERROR_FROBENIUS, the Frobenius norm of ! the difference between A and the nearest integer matrix. ! implicit none integer, parameter :: rk = kind ( 1.0D+00 ) integer m integer n real ( kind = rk ) a(m,n) real ( kind = rk ) error_frobenius integer i integer j error_frobenius = 0.0D+00 do i = 1, m do j = 1, n error_frobenius = error_frobenius + ( a(i,j) - anint ( a(i,j) ) ) ** 2 end do end do return end subroutine r8mat_is_inverse ( n, a, b, error_frobenius ) !*****************************************************************************80 ! !! r8mat_is_inverse() determines if one R8MAT is the inverse of another. ! ! Discussion: ! ! An R8MAT is a matrix of real ( kind = rk ) values. ! ! This routine returns the sum of the Frobenius norms of ! A * B - I and B * A - I. ! ! Licensing: ! ! This code is distributed under the MIT license. ! ! Modified: ! ! 09 July 2008 ! ! Author: ! ! John Burkardt ! ! Input: ! ! integer N, the order of the matrix. ! ! real ( kind = rk ) A(N,N), B(N,N), the matrices. ! ! Output: ! ! real ( kind = rk ) ERROR_FROBENIUS, the sum of the Frobenius norms ! of the difference matrices A * B - I and B * A - I which would both ! be exactly zero if B was the exact inverse of A and computer arithmetic ! were exact. ! implicit none integer, parameter :: rk = kind ( 1.0D+00 ) integer n real ( kind = rk ) a(n,n) real ( kind = rk ) b(n,n) real ( kind = rk ) error_frobenius real ( kind = rk ) error_left real ( kind = rk ) 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 ) !*****************************************************************************80 ! !! r8mat_is_inverse_left() determines if one R8MAT is the left inverse of another. ! ! Discussion: ! ! An R8MAT is a matrix of real ( kind = rk ) values. ! ! This routine returns the Frobenius norm of the NxN matrix: ! ! B * A - I. ! ! Licensing: ! ! This code is distributed under the MIT license. ! ! Modified: ! ! 09 January 2008 ! ! Author: ! ! John Burkardt ! ! Input: ! ! integer M, N, the order of the matrix A. ! ! real ( kind = rk ) A(M,N), the matrix to be checked. ! ! real ( kind = rk ) B(N,M), the matrix which is to be tested ! as a left inverse of A. ! ! Output: ! ! real ( kind = rk ) ERROR_FROBENIUS, the Frobenius norm ! of the difference matrix B * A - I, which would be exactly zero ! if B was the exact left inverse of A and computer arithmetic were exact. ! implicit none integer, parameter :: rk = kind ( 1.0D+00 ) integer m integer n real ( kind = rk ) a(m,n) real ( kind = rk ) b(n,m) real ( kind = rk ) c(n,n) real ( kind = rk ) error_frobenius integer i real ( kind = rk ) r8mat_norm_fro c(1:n,1:n) = matmul ( b(1:n,1:m), a(1:m,1:n) ) do i = 1, n c(i,i) = c(i,i) - 1.0D+00 end do error_frobenius = r8mat_norm_fro ( n, n, c ) return end subroutine r8mat_is_inverse_right ( m, n, a, b, error_frobenius ) !*****************************************************************************80 ! !! r8mat_is_inverse_right(): is one R8MAT the right inverse of another. ! ! Discussion: ! ! An R8MAT is a matrix of real ( kind = rk ) values. ! ! This routine returns the Frobenius norm of the MxM matrix: ! ! A * B - I. ! ! Licensing: ! ! This code is distributed under the MIT license. ! ! Modified: ! ! 09 January 2008 ! ! Author: ! ! John Burkardt ! ! Input: ! ! integer M, N, the order of the matrix A. ! ! real ( kind = rk ) A(M,N), the matrix to be checked. ! ! real ( kind = rk ) B(N,M), the matrix which is to be tested ! as a left inverse of A. ! ! Output: ! ! real ( kind = rk ) ERROR_FROBENIUS, the Frobenius norm ! of the difference matrix A * B - I, which would be exactly zero ! if B was the exact right inverse of A and computer arithmetic were exact. ! implicit none integer, parameter :: rk = kind ( 1.0D+00 ) integer m integer n real ( kind = rk ) a(m,n) real ( kind = rk ) b(n,m) real ( kind = rk ) c(m,m) real ( kind = rk ) error_frobenius integer i real ( kind = rk ) r8mat_norm_fro c(1:m,1:m) = matmul ( a(1:m,1:n), b(1:n,1:m) ) do i = 1, m c(i,i) = c(i,i) - 1.0D+00 end do error_frobenius = r8mat_norm_fro ( m, m, c ) return end subroutine r8mat_is_irreducible ( m, n, a, ival ) !*****************************************************************************80 ! !! r8mat_is_irreducible() determines if an R8MAT is irreducible. ! ! Discussion: ! ! An R8MAT is a matrix of real ( kind = rk ) values. ! ! The procedure is based on the idea that a matrix can be viewed as ! the (weighted) adjacency matrix of a directed graph. Ignoring the ! sign and magnitude of the entries, we say there is a directed edge from ! node I to node J if and only if A(I,J) is nonzero. Then A is ! irreducible if and only if this directed graph is strongly connected; ! that is, if and only if it is possible to start at any node and ! reach any other (distinct) node by a sequence of connecting edges. ! ! Licensing: ! ! This code is distributed under the MIT license. ! ! Modified: ! ! 25 July 2000 ! ! Author: ! ! John Burkardt ! ! Input: ! ! integer M, N, the order of the matrix. ! ! real ( kind = rk ) A(M,N), the matrix. ! ! Output: ! ! integer IVAL, ! -1, the matrix is not irreducible; ! 1, the matrix is irreducible. ! implicit none integer, parameter :: rk = kind ( 1.0D+00 ) integer m integer n real ( kind = rk ) a(m,n) integer base integer i integer ival integer j integer level integer list(n) integer nfound integer ntotal logical r8mat_is_square if ( .not. r8mat_is_square ( m, n, a ) ) then ival = -1 return end if do base = 1, n list(1:n) = 0 list(base) = 1 nfound = 1 ntotal = 1 level = 0 do level = level + 1 nfound = 0 do i = 1, n if ( list(i) == level ) then do j = 1, n if ( a(i,j) /= 0.0D+00 ) then if ( list(j) == 0 ) then list(j) = level + 1 nfound = nfound + 1 end if end if end do end if end do ntotal = ntotal + nfound if ( n <= ntotal ) then exit end if if ( nfound == 0 ) then ival = -1 return end if end do end do ival = 1 return end subroutine r8mat_is_l ( m, n, a, ival ) !*****************************************************************************80 ! !! r8mat_is_l() checks whether an R8MAT is an L matrix. ! ! Discussion: ! ! An R8MAT is a matrix of real ( kind = rk ) values. ! ! A matrix is an L matrix if it has positive diagonal and nonpositive ! offdiagonal entries. ! ! Licensing: ! ! This code is distributed under the MIT license. ! ! Modified: ! ! 24 May 2002 ! ! Author: ! ! John Burkardt ! ! Input: ! ! integer M, N, the row and column dimensions of ! the matrix. M and N must be positive. ! ! real ( kind = rk ) A(M,N), the matrix. ! ! Output: ! ! integer IVAL: the matrix is: ! -1, not an L matrix because a diagonal entry is nonpositive. ! -2, not an L matrix because an offdiagonal entry is positive. ! 1, an L matrix. ! implicit none integer, parameter :: rk = kind ( 1.0D+00 ) integer m integer n real ( kind = rk ) a(m,n) integer i integer ival integer j do i = 1, n if ( a(i,i) <= 0.0D+00 ) then ival = -1 return end if end do do i = 1, n do j = 1, n if ( i /= j ) then if ( 0.0D+00 < a(i,i) ) then ival = -2 return end if end if end do end do ival = 1 return end subroutine r8mat_is_llt ( m, n, a, l, error_frobenius ) !*****************************************************************************80 ! !! r8mat_is_llt() measures the error in a lower triangular Cholesky factorization. ! ! Discussion: ! ! An R8MAT is a matrix of real ( kind = rk ) values. ! ! This routine simply returns the Frobenius norm of the M x M matrix: ! A - L*L'. ! ! Licensing: ! ! This code is distributed under the MIT license. ! ! Modified: ! ! 14 March 2015 ! ! Author: ! ! John Burkardt ! ! Input: ! ! integer M, N, the order of the matrix. ! ! real ( kind = rk ) A(M,M), the matrix. ! ! real ( kind = rk ) L(M,N), the Cholesky factor. ! ! Output: ! ! real ( kind = rk ) ERROR_FROBENIUS, the Frobenius norm ! of A - L * L'. ! implicit none integer, parameter :: rk = kind ( 1.0D+00 ) integer m integer n real ( kind = rk ) a(m,m) real ( kind = rk ) d(m,m) real ( kind = rk ) error_frobenius real ( kind = rk ) l(m,n) real ( kind = rk ) r8mat_norm_fro d(1:m,1:m) = a(1:m,1:m) - matmul ( l(1:m,1:n), transpose ( l(1:m,1:n) ) ) error_frobenius = r8mat_norm_fro ( m, m, d ) return end subroutine r8mat_is_lu ( m, n, a, l, u, error_frobenius ) !*****************************************************************************80 ! !! r8mat_is_lu() measures the error in an LU factorization. ! ! Discussion: ! ! An R8MAT is a matrix of real ( kind = rk ) values. ! ! This routine simply returns the Frobenius norm of the M x N matrix: ! A - L * U. ! ! Licensing: ! ! This code is distributed under the MIT license. ! ! Modified: ! ! 27 October 2021 ! ! Author: ! ! John Burkardt ! ! Input: ! ! integer M, N, the order of the matrix. ! ! real ( kind = rk ) A(M,N), the matrix. ! ! real ( kind = rk ) L(M,M), U(M,N), the LU factors. ! ! Output: ! ! real ( kind = rk ) ERROR_FROBENIUS, the Frobenius norm of A - L * U. ! implicit none integer, parameter :: rk = kind ( 1.0D+00 ) integer m integer n real ( kind = rk ) a(m,n) real ( kind = rk ) d(m,n) real ( kind = rk ) error_frobenius real ( kind = rk ) l(m,m) real ( kind = rk ) r8mat_norm_fro real ( kind = rk ) u(m,n) d(1:m,1:n) = a(1:m,1:n) - matmul ( l(1:m,1:m), u(1:m,1:n) ) error_frobenius = r8mat_norm_fro ( m, n, d ) return end subroutine r8mat_is_m ( m, n, a, ival ) !*****************************************************************************80 ! !! r8mat_is_m() checks whether an R8MAT is an M matrix. ! ! Discussion: ! ! An R8MAT is a matrix of real ( kind = rk ) values. ! ! Licensing: ! ! This code is distributed under the MIT license. ! ! Modified: ! ! 04 March 2001 ! ! Author: ! ! John Burkardt ! ! Input: ! ! integer M, N, the row and column dimensions of ! the matrix. M and N must be positive. ! ! real ( kind = rk ) A(M,N), the matrix. ! ! Output: ! ! integer IVAL: the matrix is: ! -1, not an M matrix because it is not square. ! -2, not an M matrix because its offdiagonal is not nonpositive. ! -3, not an M matrix because it is not invertible; ! -4, not an M matrix because its inverse is not nonnegative. ! 1, an M matrix. ! implicit none integer, parameter :: rk = kind ( 1.0D+00 ) integer m integer n real ( kind = rk ) a(m,n) real ( kind = rk ) a2(n,n) integer i integer info integer pivot(n) integer ival integer j logical r8mat_is_square ival = 1 if ( .not. r8mat_is_square ( m, n, a ) ) then ival = -1 return end if do i = 1, n do j = 1, n if ( i == j ) then else if ( 0.0D+00 < a(i,j) ) then ival = -2 return end if end do end do a2(1:n,1:n) = a(1:n,1:n) call r8mat_gefa ( a2, n, pivot, info ) if ( info /= 0 ) then ival = -3 return end if call r8mat_geinverse ( a2, n, pivot ) do i = 1, n do j = 1, n if ( a2(i,j) < 0.0D+00 ) then ival = -4 return end if end do end do return end subroutine r8mat_is_normal ( m, n, a, error_frobenius ) !*****************************************************************************80 ! !! r8mat_is_normal() determines whether an R8MAT is normal. ! ! Discussion: ! ! An R8MAT is a matrix of real ( kind = rk ) values. ! ! A real square matrix A is normal if ! ! A * A' = A' * A. ! ! A (real) matrix is normal if and only if it is diagonalizable, ! that is, orthogonally similar to a diagonal matrix: ! ! A = U' * D * U. ! ! A matrix is automatically normal if it is symmetric, anti-symmetric, ! orthogonal, or diagonal. ! ! Licensing: ! ! This code is distributed under the MIT license. ! ! Modified: ! ! 04 November 2007 ! ! Author: ! ! John Burkardt ! ! Input: ! ! integer M, N, the row and column dimensions of ! the matrix. M and N must be positive. ! ! real ( kind = rk ) A(M,N), the matrix. ! ! Output: ! ! real ( kind = rk ) ERROR_FROBENIUS, the Frobenius normality ! error, which is 0 if the matrix is exactly normal. ! implicit none integer, parameter :: rk = kind ( 1.0D+00 ) integer m integer n real ( kind = rk ) a(m,n) real ( kind = rk ) bij real ( kind = rk ) cij real ( kind = rk ) error_frobenius integer i integer j integer k real ( kind = rk ) r8_huge logical r8mat_is_square ! ! If not square, no hope. ! if ( .not. r8mat_is_square ( m, n, a ) ) then error_frobenius = r8_huge ( ) return end if ! ! Compare A * A' to A' * A. ! error_frobenius = 0.0D+00 do i = 1, m do j = 1, n bij = 0.0D+00 cij = 0.0D+00 do k = 1, n bij = bij + a(i,k) * a(j,k) cij = cij + a(k,i) * a(k,j) end do error_frobenius = error_frobenius + ( bij - cij ) ** 2 end do end do error_frobenius = sqrt ( error_frobenius ) return end subroutine r8mat_is_null_left ( m, n, a, x, error_l2 ) !*****************************************************************************80 ! !! r8mat_is_null_left() determines if x is a left null vector of an R8MAT. ! ! Discussion: ! ! An R8MAT is a matrix of real ( kind = rk ) values. ! ! The nonzero M vector x is a left null vector of the MxN matrix A if ! ! x' * A = 0, ! or, equivalently, ! A' * x = 0 ! ! If A is a square matrix, then this implies that A is singular. ! ! If A is a square matrix, this implies that 0 is an eigenvalue of A, ! and that x is an associated eigenvector. ! ! This routine returns 0 if x is exactly a left null vector of A. ! ! It returns a "huge" value if x is the zero vector. ! ! Otherwise, it returns the L2 norm of x' * A divided by the L2 norm of x: ! ! ERROR_L2 = NORM_L2 ( x' * A ) / NORM_L2 ( x ) ! ! Licensing: ! ! This code is distributed under the MIT license. ! ! Modified: ! ! 06 March 2015 ! ! Author: ! ! John Burkardt ! ! Input: ! ! integer M, N, the row and column dimensions of ! the matrix. M and N must be positive. ! ! real ( kind = rk ) A(M,N), the matrix. ! ! real ( kind = rk ) X(M), the vector. ! ! Output: ! ! real ( kind = rk ) ERROR_L2, the result. ! 0.0 indicates that X is exactly a left null vector. ! A "huge" value indicates that ||x|| = 0; ! Otherwise, the value returned is a relative error ||x'*A||/||x||. ! implicit none integer, parameter :: rk = kind ( 1.0D+00 ) integer m integer n real ( kind = rk ) a(m,n) real ( kind = rk ) atx_norm real ( kind = rk ) error_l2 real ( kind = rk ) r8_huge real ( kind = rk ) x(m) real ( kind = rk ) x_norm x_norm = sqrt ( sum ( x(1:m) ** 2 ) ) if ( x_norm == 0.0D+00 ) then error_l2 = r8_huge ( ) return end if atx_norm = sqrt & ( & sum & ( & ( & matmul ( transpose ( a(1:m,1:n) ), x(1:m) ) & ) ** 2 & ) & ) error_l2 = atx_norm / x_norm return end subroutine r8mat_is_null_right ( m, n, a, x, error_l2 ) !*****************************************************************************80 ! !! r8mat_is_null_right() determines if vector x is a null vector of an R8MAT. ! ! Discussion: ! ! An R8MAT is a matrix of real ( kind = rk ) values. ! ! The nonzero N vector x is a null vector of the MxN matrix A if ! ! A * x = 0 ! ! If A is a square matrix, then this implies that A is singular. ! ! If A is a square matrix, this implies that 0 is an eigenvalue of A, ! and that x is an associated eigenvector. ! ! This routine returns 0 if x is exactly a null vector of A. ! ! It returns a "huge" value if x is the zero vector. ! ! Otherwise, it returns the L2 norm of A * x divided by the L2 norm of x: ! ! ERROR_L2 = NORM_L2 ( A * x ) / NORM_L2 ( x ) ! ! Licensing: ! ! This code is distributed under the MIT license. ! ! Modified: ! ! 03 November 2007 ! ! Author: ! ! John Burkardt ! ! Input: ! ! integer M, N, the row and column dimensions of ! the matrix. M and N must be positive. ! ! real ( kind = rk ) A(M,N), the matrix. ! ! real ( kind = rk ) X(N), the vector. ! ! Output: ! ! real ( kind = rk ) ERROR_L2, the result. ! 0.0 indicates that X is exactly a null vector. ! A "huge" value indicates that ||x|| = 0; ! Otherwise, the value returned is a relative error ||A*x||/||x||. ! implicit none integer, parameter :: rk = kind ( 1.0D+00 ) integer m integer n real ( kind = rk ) a(m,n) real ( kind = rk ) ax_norm real ( kind = rk ) error_l2 real ( kind = rk ) r8_huge real ( kind = rk ) x(n) real ( kind = rk ) x_norm x_norm = sqrt ( sum ( x(1:n) ** 2 ) ) if ( x_norm == 0.0D+00 ) then error_l2 = r8_huge ( ) return end if ax_norm = sqrt ( sum ( ( matmul ( a(1:m,1:n), x(1:n) ) ) ** 2 ) ) error_l2 = ax_norm / x_norm return end subroutine r8mat_is_orthogonal ( m, n, a, error_frobenius ) !*****************************************************************************80 ! !! r8mat_is_orthogonal() checks whether an R8MAT is orthogonal. ! ! Discussion: ! ! An R8MAT is a matrix of real ( kind = rk ) values. ! ! Licensing: ! ! This code is distributed under the MIT license. ! ! Modified: ! ! 20 February 2018 ! ! Author: ! ! John Burkardt ! ! Input: ! ! integer M, N, the row and column dimensions of ! the matrix. M and N must be positive. ! ! real ( kind = rk ) A(M,N), the matrix. ! ! Output: ! ! real ( kind = rk ) ERROR_FROBENIUS, the Frobenius orthogonality ! error, which is zero if the matrix is exactly orthogonal. ! implicit none integer, parameter :: rk = kind ( 1.0D+00 ) integer m integer n real ( kind = rk ) a(n,n) real ( kind = rk ), allocatable, dimension ( :, : ) :: b real ( kind = rk ) error_frobenius real ( kind = rk ) r8_huge logical r8mat_is_square if ( .not. r8mat_is_square ( m, n, a ) ) then error_frobenius = r8_huge ( ) return end if allocate ( b(1:n,1:n) ) b(1:n,1:n) = matmul ( transpose ( a(1:n,1:n) ), a(1:n,1:n) ) call r8mat_is_identity ( n, b, error_frobenius ) deallocate ( b ) return end subroutine r8mat_is_orthogonal_column ( m, n, a, error_frobenius ) !*****************************************************************************80 ! !! r8mat_is_orthogonal_column() checks whether an R8MAT is column orthogonal. ! ! Discussion: ! ! An R8MAT is a matrix of real ( kind = rk ) values. ! ! Licensing: ! ! This code is distributed under the MIT license. ! ! Modified: ! ! 12 April 2017 ! ! Author: ! ! John Burkardt ! ! Input: ! ! integer M, N, the order of the matrix. ! M and N must be positive. ! ! real ( kind = rk ) A(M,N), the matrix. ! ! Output: ! ! real ( kind = rk ) ERROR_FROBENIUS, the sum of the errors. ! implicit none integer, parameter :: rk = kind ( 1.0D+00 ) integer m integer n real ( kind = rk ) a(m,n) real ( kind = rk ), allocatable, dimension ( :, : ) :: b real ( kind = rk ) error_frobenius allocate ( b(1:n,1:n) ) b(1:n,1:n) = matmul ( transpose ( a(1:m,1:n) ), a(1:m,1:n) ) call r8mat_is_identity ( n, b, error_frobenius ) deallocate ( b ) return end subroutine r8mat_is_orthogonal_row ( m, n, a, error_frobenius ) !*****************************************************************************80 ! !! r8mat_is_orthogonal_row() checks whether an R8MAT is row orthogonal. ! ! Discussion: ! ! An R8MAT is a matrix of real ( kind = rk ) values. ! ! Licensing: ! ! This code is distributed under the MIT license. ! ! Modified: ! ! 12 April 2017 ! ! Author: ! ! John Burkardt ! ! Input: ! ! integer M, N, the row and column dimensions of ! the matrix. M and N must be positive. ! ! real ( kind = rk ) A(M,N), the matrix. ! ! Output: ! ! real ( kind = rk ) ERROR_FROBENIUS, the sum of the errors. ! implicit none integer, parameter :: rk = kind ( 1.0D+00 ) integer m integer n real ( kind = rk ) a(m,n) real ( kind = rk ), allocatable, dimension ( :, : ) :: b real ( kind = rk ) error_frobenius allocate ( b(1:m,1:m) ) b(1:m,1:m) = matmul ( a(1:m,1:n), transpose ( a(1:m,1:n) ) ) call r8mat_is_identity ( m, b, error_frobenius ) deallocate ( b ) return end subroutine r8mat_is_permutation ( m, n, a, ival ) !*****************************************************************************80 ! !! r8mat_is_permutation() checks whether an R8MAT is a permutation matrix. ! ! Discussion: ! ! An R8MAT is a matrix of real ( kind = rk ) values. ! ! Licensing: ! ! This code is distributed under the MIT license. ! ! Modified: ! ! 14 April 2017 ! ! Author: ! ! John Burkardt ! ! Input: ! ! integer M, N, the order of the matrix. ! ! real ( kind = rk ) A(M,N), the matrix. ! ! Output: ! ! integer IVAL: ! -1, the matrix is not square. ! -2, the matrix is not a zero-one matrix. ! -3, there is a row that does not sum to 1. ! -4, there is a column that does not sum to 1. ! 1, the matrix is a permutation matrix, ! implicit none integer, parameter :: rk = kind ( 1.0D+00 ) integer m integer n real ( kind = rk ) a(n,n) integer i integer ival integer j integer jval logical r8mat_is_square if ( .not. r8mat_is_square ( n, n, a ) ) then ival = -1 return end if call r8mat_is_zero_one ( m, n, a, jval ) if ( jval /= 1 ) then ival = -2 return end if do i = 1, m if ( sum ( a(i,1:n) ) /= 1.0D+00 ) then ival = -3 return end if end do do j = 1, n if ( sum ( a(1:m,j) ) /= 1.0D+00 ) then ival = -4 return end if end do ival = 1 return end subroutine r8mat_is_persymmetric ( m, n, a, error_frobenius ) !*****************************************************************************80 ! !! r8mat_is_persymmetric() checks an R8MAT for persymmetry. ! ! Discussion: ! ! An R8MAT is a matrix of real ( kind = rk ) values. ! ! A is persymmetric if A(I,J) = A(N+1-J,N+1-I). ! ! Licensing: ! ! This code is distributed under the MIT license. ! ! Modified: ! ! 20 February 2018 ! ! Author: ! ! John Burkardt ! ! Input: ! ! integer M, N, the row and column dimensions of ! the matrix. M and N must be positive. ! ! real ( kind = rk ) A(M,N), the matrix. ! ! Output: ! ! real ( kind = rk ) ERROR_FROBENIUS, the Frobenius error ! in persymmetry, which will be 0 if the matrix is exactly ! persymmetric. ! implicit none integer, parameter :: rk = kind ( 1.0D+00 ) integer m integer n real ( kind = rk ) a(m,n) real ( kind = rk ) error_frobenius integer i integer j real ( kind = rk ) r8_huge logical r8mat_is_square if ( .not. r8mat_is_square ( m, n, a ) ) then error_frobenius = r8_huge ( ) return end if error_frobenius = 0.0D+00 do i = 1, min ( m, n ) do j = n, max ( 1, n - m + 1 ), -1 error_frobenius = error_frobenius + ( a(i,j) - a(n+1-j,n+1-i) ) ** 2 end do end do error_frobenius = sqrt ( error_frobenius ) return end subroutine r8mat_is_plu ( m, n, a, p, l, u, error_frobenius ) !*****************************************************************************80 ! !! r8mat_is_plu() measures the error in a PLU factorization. ! ! Discussion: ! ! An R8MAT is a matrix of real ( kind = rk ) values. ! ! This routine simply returns the Frobenius norm of the M x N matrix: ! A - P * L * U. ! ! Licensing: ! ! This code is distributed under the MIT license. ! ! Modified: ! ! 16 August 2008 ! ! Author: ! ! John Burkardt ! ! Input: ! ! integer M, N, the order of the matrix. ! ! real ( kind = rk ) A(M,N), the matrix. ! ! real ( kind = rk ) P(M,M), L(M,M), U(M,N), the PLU factors. ! ! Output: ! ! real ( kind = rk ) ERROR_FROBENIUS, the Frobenius norm ! of the difference matrix A - P * L * U. ! implicit none integer, parameter :: rk = kind ( 1.0D+00 ) integer m integer n real ( kind = rk ) a(m,n) real ( kind = rk ) d(m,n) real ( kind = rk ) error_frobenius real ( kind = rk ) l(m,m) real ( kind = rk ) p(m,m) real ( kind = rk ) r8mat_norm_fro real ( kind = rk ) u(m,n) d(1:m,1:n) = a(1:m,1:n) - matmul ( p(1:m,1:m), & matmul ( l(1:m,1:m), u(1:m,1:n) ) ) error_frobenius = r8mat_norm_fro ( m, n, d ) return end subroutine r8mat_is_positive ( m, n, a, ival, jval ) !*****************************************************************************80 ! !! r8mat_is_positive() checks whether an R8MAT is a positive matrix. ! ! Discussion: ! ! An R8MAT is a matrix of real ( kind = rk ) values. ! ! Licensing: ! ! This code is distributed under the MIT license. ! ! Modified: ! ! 07 November 1998 ! ! Author: ! ! John Burkardt ! ! Input: ! ! integer M, N, the row and column dimensions of ! the matrix. M and N must be positive. ! ! real ( kind = rk ) A(M,N), the matrix. ! ! Output: ! ! integer IVAL: ! -1, the matrix is not positive. ! 0, the matrix is nonnegative. ! 1, the matrix is positive. ! ! integer JVAL: ! -1, the matrix is not negative. ! 0, the matrix is nonpositive. ! 1, the matrix is negative. ! implicit none integer, parameter :: rk = kind ( 1.0D+00 ) integer m integer n real ( kind = rk ) a(m,n) integer i integer ival integer j integer jval ival = 1 jval = 1 do i = 1, m do j = 1, n if ( 0.0D+00 < a(i,j) ) then jval = -1 else if ( a(i,j) == 0.0D+00 ) then if ( ival == 1 ) then ival = 0 end if if ( jval == 1 ) then jval = 0 end if else if ( a(i,j) < 0.0D+00 ) then ival = -1 end if end do end do return end subroutine r8mat_is_propa ( n, a, ival ) !*****************************************************************************80 ! !! r8mat_is_propa() checks whether an R8MAT has property A. ! ! Discussion: ! ! An R8MAT is a matrix of real ( kind = rk ) values. ! ! A matrix has property A if the indices 1 through N can be divided ! into two sets, S1 and S2, in such a way that the only nonzero ! offdiagonal elements occur as "connections" between sets S1 and S2. ! ! In other words, if I /= J, then A(I,J) /= 0 implies that I is in ! S1 and J is in S2, or vice versa. ! ! In this case, A can be reordered to have the form: ! ! D1 B ! C D2 ! ! where D1 and D2 are diagonal matrices. ! ! A matrix has property A is roughly the same as saying that the ! corresponding graph ( I is connected to J if and only if A(I,J) ! or A(J,I) is nonzero) is bipartite. ! ! Licensing: ! ! This code is distributed under the MIT license. ! ! Modified: ! ! 23 May 2002 ! ! Author: ! ! John Burkardt ! ! Input: ! ! integer N, the order of the matrix. ! ! real ( kind = rk ) A(N,N), the matrix. ! ! Output: ! ! integer IVAL: ! -1, the matrix does not have property A. ! 1, the matrix has property A. ! implicit none integer, parameter :: rk = kind ( 1.0D+00 ) integer n real ( kind = rk ) a(n,n) integer i integer ival integer j integer nset integer nset_old integer nstack1 integer nstack2 integer set(n) integer stack1(n) integer stack2(n) set(1:n) = 0 nset = 0 nstack1 = 0 nstack2 = 0 nstack1 = nstack1 + 1 stack1(nstack1) = 1 set(1) = 1 nset = nset + 1 do ! ! Check all connections from the new candidates for set 1... ! ...to old nodes, for consistency, and ! ...to new nodes, to find candidates for the next sweep. ! nset_old = nset do while ( 0 < nstack1 ) i = stack1(nstack1) do j = 1, n if ( j == i ) then cycle end if if ( a(i,j) == 0.0D+00 .and. a(j,i) == 0.0D+00 ) then cycle end if if ( set(j) == 2 ) then cycle else if ( set(j) == 1 ) then ival = -1 return end if nstack2 = nstack2 + 1 stack2(nstack2) = j set(j) = 2 nset = nset + 1 end do nstack1 = nstack1 - 1 end do ! ! If we didn't add any new neighbors... ! if ( nset == nset_old ) then ! ! ...and the current candidates make up the rest of the set, ! then we've looked at everything and we're done. ! if ( nset == n ) then ival = 1 exit end if ! ! ...otherwise, grab an unused index as a new candidate, and continue. ! do i = 1, n if ( set(i) == 0 ) then nstack2 = nstack2 + 1 stack2(nstack2) = i set(i) = 2 nset = nset + 1 exit end if end do end if ! ! Check all connections from the new candidates for set 2... ! ...to old nodes, for consistency, and ! ...to new nodes, to find candidates for the next sweep. ! nset_old = nset do while ( 0 < nstack2 ) i = stack2(nstack2) do j = 1, n if ( j == i ) then cycle end if if ( a(i,j) == 0.0D+00 .and. a(j,i) == 0.0D+00 ) then cycle end if if ( set(j) == 1 ) then cycle else if ( set(j) == 2 ) then ival = -1 return end if nstack1 = nstack1 + 1 stack1(nstack1) = j set(j) = 1 nset = nset + 1 end do nstack2 = nstack2 - 1 end do ! ! If we didn't add any new neighbors... ! if ( nset == nset_old ) then ! ! ...and the current candidates make up the rest of the set, ! then we've looked at everything and we're done. ! if ( nset == n ) then ival = 1 exit end if ! ! ...otherwise, grab an unused index as a new candidate, and continue. ! do i = 1, n if ( set(i) == 0 ) then nstack1 = nstack1 + 1 stack1(nstack1) = i set(i) = 1 nset = nset + 1 exit end if end do end if end do return end subroutine r8mat_is_ref ( m, n, a, ival ) !*****************************************************************************80 ! !! r8mat_is_ref() determines whether an R8MAT is in row echelon form. ! ! Discussion: ! ! An R8MAT is a matrix of real ( kind = rk ) values. ! ! Licensing: ! ! This code is distributed under the MIT license. ! ! Modified: ! ! 09 November 1998 ! ! Author: ! ! John Burkardt ! ! Input: ! ! integer M, N, the ow and column dimensions of ! the matrix. M and N must be positive. ! ! real ( kind = rk ) A(M,N), the matrix. ! ! Output: ! ! integer IVAL: ! -1, the matrix is not in row echelon form. ! 1, the matrix is in row echelon form. ! 2, the matrix is in reduced row echelon form. ! implicit none integer, parameter :: rk = kind ( 1.0D+00 ) integer m integer n real ( kind = rk ) a(m,n) integer i integer i2 integer ival integer j integer last_one integer this_one ival = 2 last_one = 0 do i = 1, m this_one = n + 1 do j = n, 1, -1 if ( a(i,j) /= 0.0D+00 ) then this_one = j end if end do if ( this_one <= n ) then if ( a(i,this_one) /= 1.0D+00 ) then ival = -1 return end if if ( this_one <= last_one ) then ival = -1 return end if do i2 = 1, m if ( i2 /= i ) then if ( a(i2,this_one) /= 0.0D+00 ) then ival = 1 end if end if end do end if last_one = this_one end do return end subroutine r8mat_is_scalar ( m, n, a, ival, jval, kval, lval ) !*****************************************************************************80 ! !! r8mat_is_scalar() checks whether an R8MAT is a scalar along rows, columns, etc. ! ! Discussion: ! ! An R8MAT is a matrix of real ( kind = rk ) values. ! ! Licensing: ! ! This code is distributed under the MIT license. ! ! Modified: ! ! 09 November 1998 ! ! Author: ! ! John Burkardt ! ! Input: ! ! integer M, N, the row and column dimensions of ! the matrix. M and N must be positive. ! ! real ( kind = rk ) A(M,N), the matrix. ! ! Output: ! ! integer IVAL: ! -1, the matrix is not row scalar. ! 1, the matrix is row scalar. ! ! integer JVAL: ! -1, the matrix is not column scalar. ! 1, the matrix is column scalar. ! ! integer KVAL: ! -1, the matrix is not diagonal scalar. ! 1, the matrix is diagonal scalar. ! ! integer LVAL: ! -1, the matrix is not antidiagonal scalar. ! 1, the matrix is antidiagonal scalar. ! implicit none integer, parameter :: rk = kind ( 1.0D+00 ) integer m integer n real ( kind = rk ) a(m,n) integer i integer ihi integer ilo integer ipj integer ival integer j integer jmi integer jval integer kval integer lval real ( kind = rk ) s ival = 1 do i = 1, m s = a(i,1) do j = 2, n if ( a(i,j) /= s ) then ival = -1 end if end do end do jval = 1 do j = 1, n s = a(1,j) do i = 2, m if ( a(i,j) /= s ) then jval = -1 end if end do end do kval = 1 do jmi = 1 - m, n - 1 ilo = max ( 1, 1 - jmi ) ihi = min ( m, n - jmi ) s = a(ilo,ilo+jmi) do i = ilo, ihi if ( a(i,i+jmi) /= s ) then kval = -1 end if end do end do lval = 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) /= s ) then lval = -1 end if end do end do return end subroutine r8mat_is_solution ( m, n, k, a, x, b, error_frobenius ) !*****************************************************************************80 ! !! r8mat_is_solution() measures the error in a linear system solution. ! ! Discussion: ! ! An R8MAT is a matrix of real ( kind = rk ) values. ! ! The system matrix A is an M x N matrix. ! It is not required that A be invertible. ! ! The solution vector X is actually allowed to be an N x K matrix. ! ! The right hand side "vector" B is actually allowed to be an M x K matrix. ! ! This routine simply returns the Frobenius norm of the M x K matrix: ! A * X - B. ! ! Licensing: ! ! This code is distributed under the MIT license. ! ! Modified: ! ! 28 November 2007 ! ! Author: ! ! John Burkardt ! ! Input: ! ! integer M, N, K, the order of the matrices. ! ! real ( kind = rk ) A(M,N), X(N,K), B(M,K), the matrices. ! ! Output: ! ! real ( kind = rk ) ERROR_FROBENIUS, the Frobenius norm ! of the difference matrix A * X - B, which would be exactly zero ! if X was the "solution" of the linear system. ! implicit none integer, parameter :: rk = kind ( 1.0D+00 ) integer k integer m integer n real ( kind = rk ) a(m,n) real ( kind = rk ) b(m,k) real ( kind = rk ) c(m,k) real ( kind = rk ) error_frobenius real ( kind = rk ) r8mat_norm_fro real ( kind = rk ) x(n,k) c(1:m,1:k) = matmul ( a(1:m,1:n), x(1:n,1:k) ) - b(1:m,1:k) error_frobenius = r8mat_norm_fro ( m, k, c ) return end subroutine r8mat_is_sparse ( m, n, a, fnorm ) !*****************************************************************************80 ! !! r8mat_is_sparse() counts the number of zero entries in an R8MAT. ! ! Discussion: ! ! An R8MAT is a matrix of real ( kind = rk ) values. ! ! Licensing: ! ! This code is distributed under the MIT license. ! ! Modified: ! ! 14 April 2017 ! ! Author: ! ! John Burkardt ! ! Input: ! ! integer M, N, the row and column dimensions of ! the matrix. M and N must be positive. ! ! real ( kind = rk ) A(M,N), the matrix. ! ! Output: ! ! real ( kind = rk ) FNORM, the number of nonzero entries ! divided by M * N. ! implicit none integer, parameter :: rk = kind ( 1.0D+00 ) integer m integer n real ( kind = rk ) a(m,n) real ( kind = rk ) fnorm integer i integer ival integer j ival = 0 do i = 1, m do j = 1, n if ( a(i,j) == 0.0D+00 ) then ival = ival + 1 end if end do end do fnorm = real ( ival, kind = rk ) / real ( m * n, kind = rk ) return end subroutine r8mat_is_spd ( m, n, a, ival ) !*****************************************************************************80 ! !! r8mat_is_spd() checks for if an R8MAT is symmetric positive definite. ! ! Discussion: ! ! An R8MAT is a matrix of real ( kind = rk ) values. ! ! Licensing: ! ! This code is distributed under the MIT license. ! ! Modified: ! ! 26 March 2000 ! ! Author: ! ! John Burkardt ! ! Input: ! ! integer M, N, the row and column dimensions of ! the matrix. M and N must be positive. ! ! real ( kind = rk ) A(M,N), the matrix. ! ! Output: ! ! integer IVAL: ! -1, the matrix is not square. ! -2, the matrix is not symmetric. ! -3, the matrix is symmetric, but not positive definite. ! 0, the matrix is symmetric positive semi-definite. ! 1, the matrix is symmetric positive definite. ! implicit none integer, parameter :: rk = kind ( 1.0D+00 ) integer m integer n real ( kind = rk ) a(m,n) real ( kind = rk ) c(m,n) integer i integer ierror integer ival integer j logical r8mat_is_square if ( .not. r8mat_is_square ( m, n, a ) ) then ival = -1 return end if do i = 1, n do j = 1, i - 1 if ( a(i,j) /= a(j,i) ) then ival = -2 return end if end do end do call r8mat_cholesky_factor ( n, a, c, ierror ) if ( ierror == 2 ) then ival = -3 else if ( ierror == 1 ) then ival = 0 else ival = 1 end if return end function r8mat_is_square ( m, n, a ) !*****************************************************************************80 ! !! r8mat_is_square() checks whether an R8MAT is square. ! ! Discussion: ! ! An R8MAT is a matrix of real ( kind = rk ) values. ! ! Licensing: ! ! This code is distributed under the MIT license. ! ! Modified: ! ! 13 April 2017 ! ! Author: ! ! John Burkardt ! ! Input: ! ! integer M, N, the order of the matrix. ! M and N must be positive. ! ! real ( kind = rk ) A(M,N), the matrix. ! ! Output: ! ! logical R8MAT_IS_SQUARE, is TRUE if the matrix ! is square. ! implicit none integer, parameter :: rk = kind ( 1.0D+00 ) integer m integer n real ( kind = rk ) a(m,n) logical r8mat_is_square logical value call r8_fake_use ( a(1,1) ) value = ( m == n ) r8mat_is_square = value return end subroutine r8mat_is_sum ( m, n, a, ival, jval, kval ) !*****************************************************************************80 ! !! r8mat_is_sum() checks whether an R8MAT has constant sums on rows or columns. ! ! Discussion: ! ! An R8MAT is a matrix of real ( kind = rk ) values. ! ! Licensing: ! ! This code is distributed under the MIT license. ! ! Modified: ! ! 24 May 2002 ! ! Author: ! ! John Burkardt ! ! Input: ! ! integer M, N, the row and column dimensions of ! the matrix. M and N must be positive. ! ! real ( kind = rk ) A(M,N), the matrix. ! ! Output: ! ! integer IVAL: ! -1, the matrix is not row sum constant. ! 1, the matrix is row sum constant. ! 2, the matrix is row sum constant with constant = 1 (Markov/stochastic). ! ! integer JVAL: ! -1, the matrix is not column sum constant. ! 1, the matrix is column sum constant. ! 2, the matrix is column sum constant with constant = 1 (transition). ! ! integer KVAL: ! -1, row sum constant not equal to column sum constant. ! 1, row sum constant = column sum constant (weak magic). ! 2, row sum constant = column sum constant = 1 (biMarkov/double stochastic). ! 3, row sum constant = column sum constant ! = main diagonals sum constant (magic) ! 4, row sum constant = column sum constant ! = main diagonals sum constant = 1 (magic biMarkov) ! implicit none integer, parameter :: rk = kind ( 1.0D+00 ) integer m integer n real ( kind = rk ) a(m,n) real ( kind = rk ) a_norm real ( kind = rk ) cave real ( kind = rk ) col_sum(n) real ( kind = rk ) cmax real ( kind = rk ) cmin real ( kind = rk ) ctol real ( kind = rk ) dave real ( kind = rk ) dsum1 real ( kind = rk ) dsum2 real ( kind = rk ) dtol integer i integer ival integer jval integer kval real ( kind = rk ) rave real ( kind = rk ) rmax real ( kind = rk ) rmin real ( kind = rk ) row_sum(m) real ( kind = rk ) rtol real ( kind = rk ), parameter :: tol = 0.0001D+00 a_norm = sum ( abs ( a(1:m,1:n) ) ) ! ! Look at row sums. ! ival = -1 row_sum(1:m) = sum ( a(1:m,1:n), dim = 2 ) rmax = maxval ( row_sum(1:m) ) rmin = minval ( row_sum(1:m) ) rave = 0.5D+00 * ( rmax + rmin ) rtol = tol * ( 1.0D+00 + a_norm / real ( n, kind = rk ) ) if ( abs ( rmax - rmin ) <= rtol ) then ival = 1 if ( abs ( rave - 1.0D+00 ) <= rtol ) then ival = 2 end if end if ! ! Look at column sums. ! jval = -1 col_sum(1:n) = sum ( a(1:m,1:n), dim = 1 ) cmax = maxval ( col_sum(1:n) ) cmin = minval ( col_sum(1:n) ) cave = 0.5D+00 * ( cmax + cmin ) ctol = tol * ( 1.0D+00 + a_norm / real ( m, kind = rk ) ) if ( abs ( cmax - cmin ) <= ctol ) then jval = 1 if ( abs ( cave - 1.0D+00 ) <= ctol ) then jval = 2 end if end if ! ! Compute diagonal sums, compare row and column situations, ! and see if we can throw in the diagonal as well. ! kval = -1 dsum1 = 0.0D+00 do i = 1, min ( m, n ) dsum1 = dsum1 + a(i,i) end do dsum2 = 0.0D+00 do i = 1, min ( m, n ) dsum2 = dsum2 + a(i,n+1-i) end do dave = 0.5D+00 * ( dsum1 + dsum2 ) dtol = tol * ( 1.0D+00 + a_norm / real ( min ( m, n ), kind = rk ) ) if ( 1 <= ival .and. 1 <= jval ) then if ( abs ( rave - cave ) <= dtol ) then kval = 1 if ( ival == 2 .and. jval == 2 ) then kval = 2 end if if ( abs ( dsum1 - dsum2 ) <= dtol ) then if ( abs ( dave - rave ) <= dtol ) then kval = kval + 2 end if end if end if end if return end subroutine r8mat_is_symmetric ( m, n, a, error_frobenius ) !*****************************************************************************80 ! !! r8mat_is_symmetric() checks an R8MAT for symmetry. ! ! Discussion: ! ! An R8MAT is a matrix of real ( kind = rk ) values. ! ! Licensing: ! ! This code is distributed under the MIT license. ! ! Modified: ! ! 16 October 2007 ! ! Author: ! ! John Burkardt ! ! Input: ! ! integer M, N, the order of the matrix. ! ! real ( kind = rk ) A(M,N), the matrix. ! ! Output: ! ! real ( kind = rk ) ERROR_FROBENIUS, measures the ! Frobenius norm of ( A - A' ), which would be zero if the matrix ! were exactly symmetric. ! implicit none integer, parameter :: rk = kind ( 1.0D+00 ) integer m integer n real ( kind = rk ) a(m,n) real ( kind = rk ) error_frobenius real ( kind = rk ) r8_huge logical r8mat_is_square if ( .not. r8mat_is_square ( m, n, a ) ) then error_frobenius = r8_huge ( ) return end if error_frobenius = sqrt ( & sum ( & ( & abs ( a(1:m,1:n) - transpose ( a(1:m,1:n) ) ) & ) ** 2 & ) & ) return end subroutine r8mat_is_toeplitz ( m, n, a, ival ) !*****************************************************************************80 ! !! r8mat_is_toeplitz() checks if an R8MAT is a Toeplitz matrix. ! ! Discussion: ! ! An R8MAT is a matrix of real ( kind = rk ) values. ! ! A Toeplitz matrix is constant along each diagonal. ! ! Licensing: ! ! This code is distributed under the MIT license. ! ! Modified: ! ! 01 July 2000 ! ! Author: ! ! John Burkardt ! ! Input: ! ! integer M, N, the row and column dimensions of ! the matrix. M and N must be positive. ! ! real ( kind = rk ) A(M,N), the matrix. ! ! Output: ! ! integer IVAL: ! -1, the matrix is not Toeplitz. ! 1, the matrix is Toeplitz. ! implicit none integer, parameter :: rk = kind ( 1.0D+00 ) integer m integer n real ( kind = rk ) a(m,n) integer i integer ival integer j integer k integer khi real ( kind = rk ) test ival = 1 do i = 1, m test = a(i,1) khi = min ( m - i, n - 1 ) do k = 1, khi if ( a(i+k,1+k) /= test ) then ival = -1 return end if end do end do do j = 2, n test = a(1,j) khi = min ( m - 1, n - j ) do k = 1, khi if ( a(1+k,j+k) /= test ) then ival = -1 return end if end do end do return end subroutine r8mat_is_tournament ( n, a, error_frobenius ) !*****************************************************************************80 ! !! r8mat_is_tournament() checks if an R8MAT is a tournament matrix. ! ! Discussion: ! ! An R8MAT is a matrix of real ( kind = rk ) values. ! ! A matrix is a tournament matrix if: ! * it is square, and ! * it is antisymmetric: A' = -A, and ! * the offdiagonal elements are either 1 or -1. ! ! Licensing: ! ! This code is distributed under the MIT license. ! ! Modified: ! ! 04 November 2007 ! ! Author: ! ! John Burkardt ! ! Input: ! ! integer N, order of the matrix. ! ! real ( kind = rk ) A(N,N), the matrix. ! ! Output: ! ! real ( kind = rk ) ERROR_FROBENIUS, the Frobenius tournament error. ! implicit none integer, parameter :: rk = kind ( 1.0D+00 ) integer n real ( kind = rk ) a(n,n) real ( kind = rk ) error_frobenius integer i integer j call r8mat_is_antisymmetric ( n, n, a, error_frobenius ) error_frobenius = error_frobenius ** 2 do i = 1, n - 1 do j = i + 1, n error_frobenius = error_frobenius + ( abs ( a(i,j) ) - 1.0D+00 ) ** 2 end do end do error_frobenius = sqrt ( error_frobenius ) return end subroutine r8mat_is_transition ( m, n, a, error_frobenius ) !*****************************************************************************80 ! !! r8mat_is_transition() checks whether an R8MAT is a transition matrix. ! ! Discussion: ! ! A transition matrix: ! * is a square matrix; ! * with real, nonnegative entries; ! * whose columns each sum to 1. ! ! An R8MAT is a matrix of real ( kind = rk ) values. ! ! Licensing: ! ! This code is distributed under the MIT license. ! ! Modified: ! ! 14 July 2013 ! ! Author: ! ! John Burkardt ! ! Input: ! ! integer M, N, the order of A. ! ! real ( kind = rk ) A(M,N), the matrix. ! ! Output: ! ! real ( kind = rk ) ERROR_FROBENIUS. ! This value is R8_HUGE(), if M /= N. ! This value is R8_HUGE(), if any entry is negative. ! Otherwise, it is the square root of the sum of the squares of the ! deviations of the column sums from 1. ! implicit none integer, parameter :: rk = kind ( 1.0D+00 ) integer m integer n real ( kind = rk ) a(m,n) real ( kind = rk ) error_frobenius integer i integer j real ( kind = rk ) r8_huge logical r8mat_is_square real ( kind = rk ) t if ( .not. r8mat_is_square ( m, n, a ) ) then error_frobenius = r8_huge ( ) return end if do j = 1, n do i = 1, m if ( a(i,j) < 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 = sum ( a(1:m,j) ) - 1.0D+00 error_frobenius = error_frobenius + t * t end do error_frobenius = sqrt ( error_frobenius ) return end subroutine r8mat_is_triangular ( m, n, a, ival, jval ) !*****************************************************************************80 ! !! r8mat_is_triangular() determines whether an R8MAT is triangular. ! ! Discussion: ! ! An R8MAT is a matrix of real ( kind = rk ) values. ! ! Licensing: ! ! This code is distributed under the MIT license. ! ! Modified: ! ! 07 November 1998 ! ! Author: ! ! John Burkardt ! ! Input: ! ! integer M, N, the row and column dimensions of ! the matrix. M and N must be positive. ! ! real ( kind = rk ) A(M,N), the matrix. ! ! Output: ! ! integer IVAL: ! -1, the matrix is not upper triangular ! 1, the matrix is upper triangular. ! 2, the matrix is unit upper triangular. ! ! integer JVAL: ! -1, the matrix is not lower triangular. ! 1, the matrix is lower triangular. ! 2, the matrix is unit lower triangular. ! implicit none integer, parameter :: rk = kind ( 1.0D+00 ) integer m integer n real ( kind = rk ) a(m,n) integer i integer ival integer j integer jval ival = 2 jval = 2 do i = 1, m do j = 1, n if ( i == j ) then if ( a(i,j) /= 1.0D+00 ) then if ( ival == 2 ) then ival = 1 end if if ( jval == 2 ) then jval = 1 end if end if else if ( i < j ) then if ( a(i,j) /= 0.0D+00 ) then jval = -1 end if else if ( j < i ) then if ( a(i,j) /= 0.0D+00 ) then ival = -1 end if end if if ( ival == -1 .and. jval == -1 ) then return end if end do end do return end subroutine r8mat_is_unit_column ( m, n, a, error_sum ) !*****************************************************************************80 ! !! r8mat_is_unit_column() checks if an R8MAT has columns of unit Euclidean norm. ! ! Discussion: ! ! An R8MAT is a matrix of real ( kind = rk ) values. ! ! Licensing: ! ! This code is distributed under the MIT license. ! ! Modified: ! ! 04 November 2007 ! ! Author: ! ! John Burkardt ! ! Input: ! ! integer M, N, the row and column dimensions of ! the matrix. M and N must be positive. ! ! real ( kind = rk ) A(M,N), the matrix. ! ! Output: ! ! real ( kind = rk ) ERROR_SUM, the error sum. ! implicit none integer, parameter :: rk = kind ( 1.0D+00 ) integer m integer n real ( kind = rk ) a(m,n) real ( kind = rk ) error_sum integer j real ( kind = rk ) r8vec_norm_l2 error_sum = 0.0D+00 do j = 1, n error_sum = error_sum + ( 1.0D+00 - r8vec_norm_l2 ( m, a(1:m,j) ) ) ** 2 end do error_sum = sqrt ( error_sum ) return end subroutine r8mat_is_unit_row ( m, n, a, error_sum ) !*****************************************************************************80 ! !! r8mat_is_unit_row() checks whether an R8MAT has rows of unit Euclidean norm. ! ! Discussion: ! ! An R8MAT is a matrix of real ( kind = rk ) values. ! ! Licensing: ! ! This code is distributed under the MIT license. ! ! Modified: ! ! 04 November 2007 ! ! Author: ! ! John Burkardt ! ! Input: ! ! integer M, N, the row and column dimensions of ! the matrix. M and N must be positive. ! ! real ( kind = rk ) A(M,N), the matrix. ! ! Output: ! ! integer ERROR_SUM, the sum of the errors. ! implicit none integer, parameter :: rk = kind ( 1.0D+00 ) integer m integer n real ( kind = rk ) a(m,n) real ( kind = rk ) error_sum integer i real ( kind = rk ) r8vec_norm_l2 error_sum = 0.0D+00 do i = 1, m error_sum = error_sum + ( 1.0D+00 - r8vec_norm_l2 ( n, a(i,1:n) ) ) ** 2 end do error_sum = sqrt ( error_sum ) return end subroutine r8mat_is_zero_one ( m, n, a, ival ) !*****************************************************************************80 ! !! r8mat_is_zero_one() checks whether an R8MAT is a zero/one matrix. ! ! Discussion: ! ! An R8MAT is a matrix of real ( kind = rk ) values. ! ! Licensing: ! ! This code is distributed under the MIT license. ! ! Modified: ! ! 07 July 2000 ! ! Author: ! ! John Burkardt ! ! Input: ! ! integer M, N, the row and column dimensions of ! the matrix. M and N must be positive. ! ! real ( kind = rk ) A(M,N), the matrix. ! ! Output: ! ! integer IVAL: ! -1, the matrix is not a zero/one matrix. ! 1, the matrix is a zero/one matrix. ! implicit none integer, parameter :: rk = kind ( 1.0D+00 ) integer m integer n real ( kind = rk ) a(m,n) integer i integer ival integer j do i = 1, m do j = 1, n if ( a(i,j) /= 0.0D+00 .and. a(i,j) /= 1.0D+00 ) then ival = -1 return end if end do end do ival = 1 return end function r8mat_norm_eis ( m, n, a ) !*****************************************************************************80 ! !! r8mat_norm_eis() returns the EISPACK norm of an M by N R8MAT. ! ! Discussion: ! ! An R8MAT is a matrix of real ( kind = rk ) values. ! ! The EISPACK norm is defined as: ! ! R8MAT_NORM_EIS = sum ( 1 <= I <= M ) sum ( 1 <= J <= N ) ! ( abs ( A(I,J) ) ) ) ! ! Licensing: ! ! This code is distributed under the MIT license. ! ! Modified: ! ! 04 March 2001 ! ! Author: ! ! John Burkardt ! ! Input: ! ! integer M, N, the order of the matrix. ! ! real ( kind = rk ) A(M,N), the matrix. ! ! Output: ! ! real ( kind = rk ) R8MAT_NORM_EIS, the EISPACK norm of A. ! implicit none integer, parameter :: rk = kind ( 1.0D+00 ) integer m integer n real ( kind = rk ) a(m,n) real ( kind = rk ) r8mat_norm_eis r8mat_norm_eis = sum ( abs ( a(1:m,1:n) ) ) return end function r8mat_norm_fro ( m, n, a ) !*****************************************************************************80 ! !! r8mat_norm_fro() returns the Frobenius norm of an M by N R8MAT. ! ! Discussion: ! ! An R8MAT is a matrix of real ( kind = rk ) values. ! ! The Frobenius norm is defined as ! ! R8MAT_NORM_FRO = sqrt ( ! sum ( 1 <= I <= M ) Sum ( 1 <= J <= N ) A(I,J)^2 ) ! ! The matrix Frobenius-norm is not derived from a vector norm, but ! is compatible with the vector L2 norm, so that: ! ! r8vec_norm_l2 ( A*x ) <= r8mat_norm_fro ( A ) * r8vec_norm_l2 ( x ). ! ! Licensing: ! ! This code is distributed under the MIT license. ! ! Modified: ! ! 04 March 2001 ! ! Author: ! ! John Burkardt ! ! Input: ! ! integer M, N, the order of the matrix. ! ! real ( kind = rk ) A(M,N), the matrix. ! ! Output: ! ! real ( kind = rk ) R8MAT_NORM_FRO, the Frobenius norm of A. ! implicit none integer, parameter :: rk = kind ( 1.0D+00 ) integer m integer n real ( kind = rk ) a(m,n) real ( kind = rk ) r8mat_norm_fro r8mat_norm_fro = sqrt ( sum ( a(1:m,1:n) ** 2 ) ) return end function r8mat_norm_l1 ( m, n, a ) !*****************************************************************************80 ! !! r8mat_norm_l1() returns the matrix L1 norm of an M by N R8MAT. ! ! Discussion: ! ! An R8MAT is a matrix of real ( kind = rk ) values. ! ! The matrix L1 norm is defined as: ! ! R8MAT_NORM_L1 = max ( 1 <= J <= N ) ! sum ( 1 <= I <= M ) abs ( A(I,J) ). ! ! The matrix L1 norm is derived from the vector L1 norm, and ! satisifies: ! ! r8vec_norm_l1 ( A*x ) <= r8mat_norm_l1 ( A ) * r8vec_norm_l1 ( x ). ! ! Licensing: ! ! This code is distributed under the MIT license. ! ! Modified: ! ! 04 March 2001 ! ! Author: ! ! John Burkardt ! ! Input: ! ! integer M, N, the order of the matrix. ! ! real ( kind = rk ) A(M,N), the matrix. ! ! Output: ! ! real ( kind = rk ) R8MAT_NORM_L1, the L1 norm of A. ! implicit none integer, parameter :: rk = kind ( 1.0D+00 ) integer m integer n real ( kind = rk ) a(m,n) integer j real ( kind = rk ) r8mat_norm_l1 r8mat_norm_l1 = 0.0D+00 do j = 1, n r8mat_norm_l1 = max ( r8mat_norm_l1, sum ( abs ( a(1:m,j) ) ) ) end do return end function r8mat_norm_l2 ( m, n, a ) !*****************************************************************************80 ! !! r8mat_norm_l2() returns the matrix L2 norm of an M by N R8MAT. ! ! Discussion: ! ! An R8MAT is a matrix of real ( kind = rk ) values. ! ! The matrix L2 norm is defined as: ! ! || A || = sqrt ( max ( 1 <= I <= M ) LAMBDA(I) ) ! ! where LAMBDA contains the eigenvalues of A * A'. ! ! The matrix L2 norm is derived from the vector L2 norm, and satisifies: ! ! r8vec_norm_l2 ( A*x ) <= r8mat_norm_l2 ( A ) * r8vec_norm_l2 ( x ). ! ! Licensing: ! ! This code is distributed under the MIT license. ! ! Modified: ! ! 19 May 2002 ! ! Author: ! ! John Burkardt ! ! Input: ! ! integer M, N, the order of the matrix. ! ! real ( kind = rk ) A(M,N), the matrix. ! ! Output: ! ! real ( kind = rk ) R8MAT_NORM_L2, the L2 norm of A. ! implicit none integer, parameter :: rk = kind ( 1.0D+00 ) integer m integer n real ( kind = rk ) a(m,n) real ( kind = rk ) b(m,m) real ( kind = rk ) lambda(m) real ( kind = rk ) r8mat_norm_l2 real ( kind = rk ) x(m,m) ! ! Compute the M by M matrix B = A * A'. ! b(1:m,1:m) = matmul ( a(1:m,1:n), transpose ( a(1:m,1:n) ) ) ! ! Diagonalize B. ! call jacobi_iterate ( m, b, lambda, x ) ! ! Find the maximum eigenvalue, and take its square root. ! r8mat_norm_l2 = sqrt ( maxval ( lambda(1:m) ) ) return end function r8mat_norm_li ( m, n, a ) !*****************************************************************************80 ! !! r8mat_norm_li() returns the matrix L-infinity norm of an M by N R8MAT. ! ! Discussion: ! ! An R8MAT is a matrix of real ( kind = rk ) values. ! ! The matrix L-infinity norm is defined as: ! ! R8MAT_NORM_LI = Max ( 1 <= I <= M ) ! sum ( 1 <= J <= N ) abs ( A(I,J) ). ! ! The matrix L-infinity norm is derived from the vector L-infinity norm, ! and satisifies: ! ! r8vec_norm_li ( A*x ) <= r8mat_norm_li ( A ) * r8vec_norm_li ( x ). ! ! Licensing: ! ! This code is distributed under the MIT license. ! ! Modified: ! ! 04 March 2001 ! ! Author: ! ! John Burkardt ! ! Input: ! ! integer M, N, the order of the matrix. ! ! real ( kind = rk ) A(M,N), the matrix. ! ! Output: ! ! real ( kind = rk ) R8MAT_NORMI_LI, the L-infinity norm of A. ! implicit none integer, parameter :: rk = kind ( 1.0D+00 ) integer m integer n real ( kind = rk ) a(m,n) integer i real ( kind = rk ) r8mat_norm_li r8mat_norm_li = 0.0D+00 do i = 1, m r8mat_norm_li = max ( r8mat_norm_li, sum ( abs ( a(i,1:n) ) ) ) end do return end function r8mat_norm_spec ( n, a ) !*****************************************************************************80 ! !! r8mat_norm_spec() returns the spectral radius norm of an N by N R8MAT. ! ! Discussion: ! ! An R8MAT is a matrix of real ( kind = rk ) values. ! ! The spectral radius norm is defined as: ! ! R8MAT_NORM_SPEC = max ( 1 <= I <= N ) abs ( LAMBDA ( I ) ) ! ! where LAMBDA is the vector of eigenvalues of A. ! ! A simple-minded power method approach is used. ! ! Licensing: ! ! This code is distributed under the MIT license. ! ! Modified: ! ! 13 July 2000 ! ! Author: ! ! John Burkardt ! ! Input: ! ! integer N, the order of the matrix. ! ! real ( kind = rk ) A(N,N), the matrix. ! ! Output: ! ! real ( kind = rk ) R8MAT_NORM_SPEC, the estimated spectral ! radius norm of A. ! implicit none integer, parameter :: rk = kind ( 1.0D+00 ) integer n real ( kind = rk ) a(n,n) real ( kind = rk ) eps integer it real ( kind = rk ), parameter :: it_eps = 0.0001D+00 integer, parameter :: it_max = 100 integer, parameter :: it_min = 10 integer j real ( kind = rk ) r8mat_norm_spec real ( kind = rk ) r8vec_norm_l2 real ( kind = rk ) s real ( kind = rk ) s2 real ( kind = rk ) s_old real ( kind = rk ) x(n) real ( kind = rk ) y(n) eps = sqrt ( epsilon ( 1.0D+00 ) ) x(1:n) = 1.0D+00 s = r8vec_norm_l2 ( n, x ) x(1:n) = x(1:n) / s do it = 1, it_max y(1:n) = matmul ( a(1:n,1:n), x(1:n) ) s_old = s s = r8vec_norm_l2 ( n, y ) if ( it_min < it ) then if ( abs ( s - s_old ) <= it_eps * ( 1.0D+00 + abs ( s ) ) ) then exit end if end if x(1:n) = y(1:n) if ( s /= 0.0D+00 ) then x(1:n) = x(1:n) / s end if ! ! Perturb X a bit, to avoid cases where the initial guess is exactly ! the eigenvector of a smaller eigenvalue. ! if ( it < it_max / 2 ) then j = 1 + mod ( it - 1, n ) x(j) = x(j) + eps * ( 1.0D+00 + abs ( x(j) ) ) s2 = r8vec_norm_l2 ( n, x ) x(1:n) = x(1:n) / s2 end if end do r8mat_norm_spec = s return end subroutine r8mat_plot ( m, n, a, title ) !*****************************************************************************80 ! !! r8mat_plot() "plots" an R8MAT with an optional title. ! ! Discussion: ! ! An R8MAT is a matrix of real ( kind = rk ) values. ! ! Licensing: ! ! This code is distributed under the MIT license. ! ! Modified: ! ! 09 June 2003 ! ! Author: ! ! John Burkardt ! ! Input: ! ! integer M, N, the order of the matrix. ! ! real ( kind = rk ) A(M,N), the matrix. ! ! character ( len = * ) TITLE, a title. ! implicit none integer, parameter :: rk = kind ( 1.0D+00 ) integer m integer n real ( kind = rk ) a(m,n) integer i integer j integer jhi integer jlo character r8mat_plot_symbol character ( len = 70 ) string character ( len = * ) title write ( *, '(a)' ) ' ' write ( *, '(a)' ) trim ( title ) do jlo = 1, n, 70 jhi = min ( jlo + 70 - 1, n ) write ( *, '(a)' ) ' ' write ( *, '(8x,4x,70i1)' ) ( mod ( j, 10 ), j = jlo, jhi ) write ( *, '(a)' ) ' ' do i = 1, m do j = jlo, jhi string(j+1-jlo:j+1-jlo) = r8mat_plot_symbol ( a(i,j) ) end do write ( *, '(i8,4x,a)' ) i, string(1:jhi+1-jlo) end do end do return end function r8mat_plot_symbol ( r ) !*****************************************************************************80 ! !! r8mat_plot_symbol() returns a symbol for a real number for matrix plotting. ! ! Discussion: ! ! An R8MAT is a matrix of real ( kind = rk ) values. ! ! Licensing: ! ! This code is distributed under the MIT license. ! ! Modified: ! ! 09 June 2003 ! ! Author: ! ! John Burkardt ! ! Input: ! ! real ( kind = rk ) R, a real value whose symbol is desired. ! ! Output: ! ! character R8MAT_PLOT_symbol, is ! '-' if R is negative, ! ' ' if R is zero, ! '+' if R is positive. ! implicit none integer, parameter :: rk = kind ( 1.0D+00 ) character r8mat_plot_symbol real ( kind = rk ) r if ( r < 0.0D+00 ) then r8mat_plot_symbol = 'X' else if ( r == 0.0D+00 ) then r8mat_plot_symbol = '.' else if ( 0.0D+00 < r ) then r8mat_plot_symbol = 'X' end if return end subroutine r8mat_poly_char ( n, a, p ) !*****************************************************************************80 ! !! r8mat_poly_char() computes the characteristic polynomial of an R8MAT. ! ! Discussion: ! ! An R8MAT is a matrix of real ( kind = rk ) values. ! ! Licensing: ! ! This code is distributed under the MIT license. ! ! Modified: ! ! 15 March 2001 ! ! Author: ! ! John Burkardt ! ! Input: ! ! integer N, the order of the matrix A. ! ! real ( kind = rk ) A(N,N), the matrix. ! ! Output: ! ! real ( kind = rk ) P(0:N), the coefficients of the characteristic ! polynomial of A. P(N) contains the coefficient of X^N ! (which will be 1), P(I) contains the coefficient of X^I, ! and P(0) contains the constant term. ! implicit none integer, parameter :: rk = kind ( 1.0D+00 ) integer n real ( kind = rk ) a(n,n) integer i integer iorder real ( kind = rk ) p(0:n) real ( kind = rk ) r8mat_trace real ( kind = rk ) trace real ( kind = rk ) work1(n,n) real ( kind = rk ) work2(n,n) ! ! Initialize WORK1 to the identity matrix. ! call r8mat_identity ( n, work1 ) p(n) = 1.0D+00 do iorder = n - 1, 0, -1 ! ! Work2 = A * WORK1. ! work2(1:n,1:n) = matmul ( a(1:n,1:n), work1(1:n,1:n) ) ! ! Take the trace. ! trace = r8mat_trace ( n, work2 ) ! ! P(IORDER) = - Trace ( WORK2 ) / ( N - IORDER ) ! p(iorder) = - trace / real ( n - iorder, kind = rk ) ! ! WORK1 := WORK2 + P(IORDER) * Identity. ! work1(1:n,1:n) = work2(1:n,1:n) do i = 1, n work1(i,i) = work1(i,i) + p(iorder) end do end do return end subroutine r8mat_print ( m, n, a, title ) !*****************************************************************************80 ! !! r8mat_print() prints an R8MAT. ! ! Discussion: ! ! An R8MAT is an array of R8 values. ! ! Licensing: ! ! This code is distributed under the MIT license. ! ! Modified: ! ! 12 September 2004 ! ! Author: ! ! John Burkardt ! ! Input: ! ! integer M, the number of rows in A. ! ! integer N, the number of columns in A. ! ! real ( kind = rk ) A(M,N), the matrix. ! ! character ( len = * ) TITLE, a title. ! implicit none integer, parameter :: rk = kind ( 1.0D+00 ) integer m integer n real ( kind = rk ) 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 ) !*****************************************************************************80 ! !! r8mat_print_some() prints some of an R8MAT. ! ! Discussion: ! ! An R8MAT is an array of R8 values. ! ! Licensing: ! ! This code is distributed under the MIT license. ! ! Modified: ! ! 26 March 2005 ! ! Author: ! ! John Burkardt ! ! Input: ! ! integer M, N, the number of rows and columns. ! ! real ( kind = rk ) A(M,N), an M by N matrix to be printed. ! ! integer ILO, JLO, the first row and column to print. ! ! integer IHI, JHI, the last row and column to print. ! ! character ( len = * ) TITLE, a title. ! implicit none integer, parameter :: rk = kind ( 1.0D+00 ) integer, parameter :: incx = 5 integer m integer n real ( kind = rk ) a(m,n) character ( len = 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 ( len = * ) title write ( *, '(a)' ) ' ' write ( *, '(a)' ) trim ( title ) 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), '(i8,6x)' ) j end do write ( *, '('' Col '',5a14)' ) ctemp(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 if ( a(i,j) == real ( int ( a(i,j) ), kind = rk ) ) then write ( ctemp(j2), '(f8.0,6x)' ) a(i,j) else write ( ctemp(j2), '(g14.6)' ) a(i,j) end if end do write ( *, '(i5,1x,5a14)' ) i, ( ctemp(j), j = 1, inc ) end do end do write ( *, '(a)' ) ' ' return end subroutine r8mat_print2 ( m, n, a ) !*****************************************************************************80 ! !! r8mat_print2() prints an M by N R8MAT. ! ! Discussion: ! ! An R8MAT is a matrix of real ( kind = rk ) values. ! ! Licensing: ! ! This code is distributed under the MIT license. ! ! Modified: ! ! 20 October 1998 ! ! Author: ! ! John Burkardt ! ! Input: ! ! integer M, N, the order of the matrix. ! ! real ( kind = rk ) A(M,N), the matrix. ! implicit none integer, parameter :: rk = kind ( 1.0D+00 ) integer m integer n real ( kind = rk ) a(m,n) real ( kind = rk ) amax real ( kind = rk ) amin real ( kind = rk ) bigint integer i integer i4_log_10 character ( len = 10 ) iform integer ihi integer ilo logical integ integer j integer jhi integer jlo integer lmax integer npline ! ! Check if all entries are integral. ! integ = .true. bigint = real ( huge ( 1 ), kind = rk ) do i = 1, m do j = 1, n if ( integ ) then if ( bigint < abs ( a(i,j) ) ) then integ = .false. else if ( a(i,j) /= real ( int ( a(i,j) ), kind = rk ) ) then integ = .false. end if end if end do end do ! ! Find the maximum and minimum entries. ! amax = maxval ( abs ( a(1:m,1:n) ) ) amin = minval ( abs ( a(1:m,1:n) ) ) ! ! Use the information about the maximum size of an entry to ! compute an intelligent format for use with integer entries. ! ! Later, we might also do this for real matrices. ! lmax = i4_log_10 ( int ( amax ) ) if ( integ ) then npline = 79 / ( lmax + 3 ) write ( iform, '(''('',i2,''I'',i2,'')'')') npline, lmax+3 else npline = 5 iform = ' ' end if ! ! Print a scalar quantity. ! if ( m == 1 .and. n == 1 ) then if ( integ ) then write ( *, iform ) int ( a(1,1) ) else write ( *, '(g14.6)' ) a(1,1) end if ! ! Column vector of length M, ! else if ( n == 1 ) then do ilo = 1, m, npline ihi = min ( ilo + npline - 1, m ) if ( integ ) then write ( *, iform ) int ( a(ilo:ihi,1) ) else write ( *, '(5g14.6)' ) a(ilo:ihi,1) end if end do ! ! Row vector of length N, ! else if ( m == 1 ) then do jlo = 1, n, npline jhi = min ( jlo + npline - 1, n ) if ( integ ) then write ( *, iform ) int ( a(1,jlo:jhi) ) else write ( *, '(5g14.6)' ) a(1,jlo:jhi) end if end do ! ! M by N Array ! else do jlo = 1, n, npline jhi = min ( jlo + npline - 1, n ) if ( npline < n ) then write ( *, '(a)' ) ' ' write ( *, '(a,i8,a,i8)' ) ' Matrix columns ', jlo, ' to ', jhi write ( *, '(a)' ) ' ' end if do i = 1, m if ( integ ) then write ( *, iform ) int ( a(i,jlo:jhi) ) else write ( *, '(5g14.6)' ) a(i,jlo:jhi) end if end do end do end if return end subroutine r8mat_symm_jacobi ( n, a, lambda ) !*****************************************************************************80 ! !! r8mat_symm_jacobi() applies Jacobi eigenvalue iteration to a symmetric R8MAT. ! ! Discussion: ! ! An R8MAT is a matrix of real ( kind = rk ) values. ! ! Licensing: ! ! This code is distributed under the MIT license. ! ! Modified: ! ! 22 May 2002 ! ! Author: ! ! John Burkardt ! ! Input: ! ! integer N, the order of the matrix. ! ! real ( kind = rk ) A(N,N), a symmetric matrix. ! ! Output: ! ! real ( kind = rk ) LAMBDA(N), the approximate eigenvalues. ! implicit none integer, parameter :: rk = kind ( 1.0D+00 ) integer n real ( kind = rk ) a(n,n) real ( kind = rk ) b(n,n) real ( kind = rk ) c real ( kind = rk ), parameter :: eps = 0.00001D+00 integer i integer it integer, parameter :: it_max = 100 integer j integer k real ( kind = rk ) lambda(n) real ( kind = rk ) norm_fro real ( kind = rk ) r8mat_norm_fro real ( kind = rk ) s real ( kind = rk ) sum2 real ( kind = rk ) t real ( kind = rk ) t1 real ( kind = rk ) t2 real ( kind = rk ) u b(1:n,1:n) = a(1:n,1:n) norm_fro = r8mat_norm_fro ( n, n, b ) it = 0 do it = it + 1 do i = 1, n do j = 1, i - 1 if ( eps * norm_fro < abs ( b(i,j) ) + abs ( b(j,i) ) ) then u = ( b(j,j) - b(i,i) ) / ( b(i,j) + b(j,i) ) t = sign ( 1.0D+00, u ) / ( abs ( u ) + sqrt ( u * u + 1.0D+00 ) ) c = 1.0D+00 / sqrt ( t * t + 1.0D+00 ) s = t * c ! ! A -> A * Q. ! 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 ! ! A -> QT * A ! 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 end if end do end do ! ! Test the size of the off-diagonal elements. ! 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 <= eps * ( norm_fro + 1.0D+00 ) ) then exit end if if ( it_max <= it ) then exit end if end do do i = 1, n lambda(i) = b(i,i) end do return end subroutine r8mat_to_c8mat ( m, n, r8mat, c8mat ) !*****************************************************************************80 ! !! r8mat_to_c8mat() copies an R8MAT to a C8MAT. ! ! Discussion: ! ! An R8MAT is a matrix of real numbers. ! ! A C8MAT is a matrix of complex numbers. ! ! Licensing: ! ! This code is distributed under the MIT license. ! ! Modified: ! ! 15 May 2021 ! ! Author: ! ! John Burkardt ! ! Input: ! ! integer M, N, the number of rows and columns. ! ! real ( kind = rk ) R8MAT[M*N], the matrix to be copied. ! ! Output: ! ! complex ( kind = ck ) C8MAT[M*N], the complex copy of R8MAT. ! implicit none integer, parameter :: rk = kind ( 1.0D+00 ) integer, parameter :: ck = kind ( ( 1.0D+00, 1.0D+00 ) ) integer m integer n complex ( kind = ck ) c8mat(m,n) real ( kind = rk ) r8mat(m,n) c8mat(1:m,1:n) = cmplx ( r8mat(1:m,1:n), kind = ck ) return end function r8mat_trace ( n, a ) !*****************************************************************************80 ! !! r8mat_trace() computes the trace of an R8MAT. ! ! Discussion: ! ! An R8MAT is a matrix of real ( kind = rk ) values. ! ! The trace of a square matrix is the sum of the diagonal elements. ! ! Licensing: ! ! This code is distributed under the MIT license. ! ! Modified: ! ! 20 July 1999 ! ! Author: ! ! John Burkardt ! ! Input: ! ! integer N, the order of the matrix A. ! ! real ( kind = rk ) A(N,N), the matrix whose trace is desired. ! ! Output: ! ! real ( kind = rk ) R8MAT_TRACE, the trace of the matrix. ! implicit none integer, parameter :: rk = kind ( 1.0D+00 ) integer n real ( kind = rk ) a(n,n) real ( kind = rk ) diag(n) real ( kind = rk ) r8mat_trace call r8mat_diag_get_vector ( n, a, diag ) r8mat_trace = sum ( diag(1:n) ) return end subroutine r8mat_transpose ( m, n, a, at ) !*****************************************************************************80 ! !! r8mat_transpose() makes a transposed copy of an R8MAT. ! ! Discussion: ! ! An R8MAT is an MxN array of R8's, stored by (I,J) -> [I+J*M]. ! ! FORTRAN90 provides the transpose ( ) function which should be preferred ! over this routine. ! ! Licensing: ! ! This code is distributed under the MIT license. ! ! Modified: ! ! 13 June 2011 ! ! Author: ! ! John Burkardt ! ! Input: ! ! integer M, N, the number of rows and columns ! of the matrix A. ! ! real ( kind = rk ) A(N,N), the matrix to be transposed. ! ! Output: ! ! real ( kind = rk ) AT(N,M), the matrix to be transposed. ! implicit none integer, parameter :: rk = kind ( 1.0D+00 ) integer m integer n real ( kind = rk ) a(m,n) real ( kind = rk ) at(n,m) at = transpose ( a ) return end subroutine r8mat_transpose_in_place ( n, a ) !*****************************************************************************80 ! !! r8mat_transpose_in_place() transposes an R8MAT in place. ! ! Discussion: ! ! An R8MAT is an MxN array of R8's, stored by (I,J) -> [I+J*M]. ! ! Licensing: ! ! This code is distributed under the MIT license. ! ! Modified: ! ! 27 June 2008 ! ! Author: ! ! John Burkardt ! ! Input: ! ! integer N, the number of rows and columns ! of the matrix A. ! ! real ( kind = rk ) A(N,N), the matrix to be transposed. ! ! Output: ! ! real ( kind = rk ) A(N,N), the transposed matrix. ! implicit none integer, parameter :: rk = kind ( 1.0D+00 ) integer n real ( kind = rk ) a(n,n) integer i integer j real ( kind = rk ) 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 ) !*****************************************************************************80 ! !! r8mat_uniform_01() fills an R8MAT with unit pseudorandom numbers. ! ! Discussion: ! ! An R8MAT is a matrix of real ( kind = rk ) values. ! ! Licensing: ! ! This code is distributed under the MIT license. ! ! Modified: ! ! 11 August 2004 ! ! Author: ! ! John Burkardt ! ! Reference: ! ! Paul Bratley, Bennett Fox, Linus Schrage, ! A Guide to Simulation, ! Springer Verlag, pages 201-202, 1983. ! ! Bennett Fox, ! Algorithm 647: ! Implementation and Relative Efficiency of Quasirandom ! Sequence Generators, ! ACM Transactions on Mathematical Software, ! Volume 12, Number 4, pages 362-376, 1986. ! ! Peter Lewis, Allen Goodman, James Miller, ! A Pseudo-Random Number Generator for the System/360, ! IBM Systems Journal, ! Volume 8, pages 136-143, 1969. ! ! Input: ! ! integer M, N, the order of the matrix. ! ! integer SEED, a seed for the random number generator. ! ! Output: ! ! real ( kind = rk ) R(M,N), the array of pseudorandom values. ! ! integer SEED, an updated seed. ! implicit none integer, parameter :: rk = kind ( 1.0D+00 ) integer m integer n integer i integer j integer k integer seed real ( kind = rk ) r(m,n) do j = 1, n do i = 1, m k = seed / 127773 seed = 16807 * ( seed - k * 127773 ) - k * 2836 if ( seed < 0 ) then seed = seed + 2147483647 end if r(i,j) = real ( seed, kind = rk ) * 4.656612875D-10 end do end do return end subroutine r8mat_uniform_ab ( m, n, a, b, seed, r ) !*****************************************************************************80 ! !! r8mat_uniform_ab() returns a scaled pseudorandom R8MAT. ! ! Discussion: ! ! An R8MAT is an MxN array of R8's, stored by (I,J) -> [I+J*M]. ! ! A <= R(I,J) <= B. ! ! Licensing: ! ! This code is distributed under the MIT license. ! ! Modified: ! ! 31 May 2007 ! ! Author: ! ! John Burkardt ! ! Reference: ! ! Paul Bratley, Bennett Fox, Linus Schrage, ! A Guide to Simulation, ! Second Edition, ! Springer, 1987, ! ISBN: 0387964673, ! LC: QA76.9.C65.B73. ! ! Bennett Fox, ! Algorithm 647: ! Implementation and Relative Efficiency of Quasirandom ! Sequence Generators, ! ACM Transactions on Mathematical Software, ! Volume 12, Number 4, December 1986, pages 362-376. ! ! Pierre L'Ecuyer, ! Random Number Generation, ! in Handbook of Simulation, ! edited by Jerry Banks, ! Wiley, 1998, ! ISBN: 0471134031, ! LC: T57.62.H37. ! ! Peter Lewis, Allen Goodman, James Miller, ! A Pseudo-Random Number Generator for the System/360, ! IBM Systems Journal, ! Volume 8, Number 2, 1969, pages 136-143. ! ! Input: ! ! integer M, N, the number of rows and columns ! in the array. ! ! real ( kind = rk ) A, B, the lower and upper limits. ! ! integer SEED, a seed for the random number generator. ! ! Output: ! ! real ( kind = rk ) R(M,N), the array of pseudorandom values. ! ! integer SEED, an updated seed. ! implicit none integer, parameter :: rk = kind ( 1.0D+00 ) integer m integer n real ( kind = rk ) a real ( kind = rk ) b integer i integer, parameter :: i4_huge = 2147483647 integer j integer k integer seed real ( kind = rk ) r(m,n) if ( seed == 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 < 0 ) then seed = seed + i4_huge end if r(i,j) = a + ( b - a ) * real ( seed, kind = rk ) * 4.656612875D-10 end do end do return end subroutine r8poly_degree ( na, a, degree ) !*****************************************************************************80 ! !! r8poly_degree() returns the degree of a polynomial. ! ! Discussion: ! ! The degree of a polynomial is the index of the highest power ! of X with a nonzero coefficient. ! ! The degree of a constant polynomial is 0. The degree of the ! zero polynomial is debatable, but this routine returns the ! degree as 0. ! ! Licensing: ! ! This code is distributed under the MIT license. ! ! Modified: ! ! 20 March 2001 ! ! Author: ! ! John Burkardt ! ! Input: ! ! integer NA, the dimension of A. ! ! real ( kind = rk ) A(0:NA), the coefficients of the polynomials. ! ! Output: ! ! integer DEGREE, the degree of A. ! implicit none integer, parameter :: rk = kind ( 1.0D+00 ) integer na real ( kind = rk ) a(0:na) integer degree degree = na do while ( 0 < degree ) if ( a(degree) /= 0.0D+00 ) then return end if degree = degree - 1 end do return end subroutine r8poly_print ( n, a, title ) !*****************************************************************************80 ! !! r8poly_print() prints out a polynomial. ! ! Discussion: ! ! The power sum form is: ! ! p(x) = a(0) + a(1)*x + ... + a(n-1)*x^(n-1) + a(n)*x^n ! ! Licensing: ! ! This code is distributed under the MIT license. ! ! Modified: ! ! 06 August 2000 ! ! Author: ! ! John Burkardt ! ! Input: ! ! integer N, the dimension of A. ! ! real ( kind = rk ) A(0:N), the polynomial coefficients. ! A(0) is the constant term and ! A(N) is the coefficient of X^N. ! ! character ( len = * ) TITLE, a title. ! implicit none integer, parameter :: rk = kind ( 1.0D+00 ) integer n real ( kind = rk ) a(0:n) integer i real ( kind = rk ) mag integer n2 character plus_minus character ( len = * ) title write ( *, '(a)' ) ' ' write ( *, '(a)' ) trim ( title ) write ( *, '(a)' ) ' ' call r8poly_degree ( n, a, n2 ) if ( a(n2) < 0.0D+00 ) then plus_minus = '-' else plus_minus = ' ' end if mag = abs ( a(n2) ) if ( 2 <= n2 ) then write ( *, '( '' p(x) = '', a1, g14.6, '' * x ^ '', i3 )' ) & plus_minus, mag, n2 else if ( n2 == 1 ) then write ( *, '( '' p(x) = '', a1, g14.6, '' * x'' )' ) plus_minus, mag else if ( n2 == 0 ) then write ( *, '( '' p(x) = '', a1, g14.6 )' ) plus_minus, mag end if do i = n2 - 1, 0, -1 if ( a(i) < 0.0D+00 ) then plus_minus = '-' else plus_minus = '+' end if mag = abs ( a(i) ) if ( mag /= 0.0D+00 ) then if ( 2 <= i ) then write ( *, ' ( '' '', a1, g14.6, '' * x ^ '', i3 )' ) & plus_minus, mag, i else if ( i == 1 ) then write ( *, ' ( '' '', a1, g14.6, '' * x'' )' ) plus_minus, mag else if ( i == 0 ) then write ( *, ' ( '' '', a1, g14.6 )' ) plus_minus, mag end if end if end do return end subroutine r8row_swap ( m, n, a, irow1, irow2 ) !*****************************************************************************80 ! !! r8row_swap() swaps two rows of a table. ! ! Licensing: ! ! This code is distributed under the MIT license. ! ! Modified: ! ! 14 February 1999 ! ! Author: ! ! John Burkardt ! ! Input: ! ! integer M, N, the order of the matrix. ! ! real ( kind = rk ) A(M,N), the matrix. ! ! integer IROW1, IROW2, the two rows to swap. ! ! Output: ! ! real ( kind = rk ) A(M,N), the matrix after swapping. ! implicit none integer, parameter :: rk = kind ( 1.0D+00 ) integer m integer n real ( kind = rk ) a(m,n) integer irow1 integer irow2 integer j real ( kind = rk ) t if ( irow1 < 1 .or. m < irow1 ) then write ( *, '(a)' ) ' ' write ( *, '(a)' ) 'R8ROW_SWAP - Fatal error!' write ( *, '(a)' ) ' IROW1 is out of range.' stop 1 end if if ( irow2 < 1 .or. m < irow2 ) then write ( *, '(a)' ) ' ' write ( *, '(a)' ) 'R8ROW_SWAP - Fatal error!' write ( *, '(a)' ) ' IROW2 is out of range.' stop 1 end if if ( irow1 == irow2 ) then return end if do j = 1, n t = a(irow1,j) a(irow1,j) = a(irow2,j) a(irow2,j) = t end do return end subroutine r8row_to_r8vec ( m, n, a, x ) !*****************************************************************************80 ! !! r8row_to_r8vec() converts a matrix of rows into a vector. ! ! Example: ! ! M = 3, N = 4 ! ! A = ! 11 12 13 14 ! 21 22 23 24 ! 31 32 33 34 ! ! X = ( 11, 12, 13, 14, 21, 22, 23, 24, 31, 32, 33, 34 ) ! ! Licensing: ! ! This code is distributed under the MIT license. ! ! Modified: ! ! 13 July 2000 ! ! Author: ! ! John Burkardt ! ! Input: ! ! integer M, N, the order of the matrix. ! ! real ( kind = rk ) A(M,N), the matrix. ! ! Output: ! ! real ( kind = rk ) X(M*N), a vector containing the M rows of A. ! implicit none integer, parameter :: rk = kind ( 1.0D+00 ) integer m integer n real ( kind = rk ) a(m,n) integer i integer j real ( kind = rk ) 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 subroutine r8vec_copy ( n, a1, a2 ) !*****************************************************************************80 ! !! r8vec_copy() copies an R8VEC. ! ! Discussion: ! ! An R8VEC is a vector of R8 values. ! ! Licensing: ! ! This code is distributed under the MIT license. ! ! Modified: ! ! 17 September 2005 ! ! Author: ! ! John Burkardt ! ! Input: ! ! integer N, the length of the vectors. ! ! real ( kind = rk ) A1(N), the vector to be copied. ! ! Output: ! ! real ( kind = rk ) A2(N), a copy of A1. ! implicit none integer, parameter :: rk = kind ( 1.0D+00 ) integer n real ( kind = rk ) a1(n) real ( kind = rk ) a2(n) a2(1:n) = a1(1:n) return end subroutine r8vec_house_column ( n, a, k, v ) !*****************************************************************************80 ! !! r8vec_house_column() defines a Householder premultiplier that "packs" a column. ! ! Discussion: ! ! An R8VEC is a vector of real ( kind = rk ) values. ! ! The routine returns a vector V that defines a Householder ! premultiplier matrix H(V) that zeros out the subdiagonal entries of ! column K of the matrix A. ! ! H(V) = I - 2 * v * v' ! ! Licensing: ! ! This code is distributed under the MIT license. ! ! Modified: ! ! 01 June 2002 ! ! Author: ! ! John Burkardt ! ! Input: ! ! integer N, the order of the matrix A. ! ! real ( kind = rk ) A(N), column K of the matrix A. ! ! integer K, the column of the matrix to be modified. ! ! Output: ! ! real ( kind = rk ) V(N), a vector of unit L2 norm which defines an ! orthogonal Householder premultiplier matrix H with the property ! that the K-th column of H*A is zero below the diagonal. ! implicit none integer, parameter :: rk = kind ( 1.0D+00 ) integer n real ( kind = rk ) a(n) integer k real ( kind = rk ) s real ( kind = rk ) v(n) v(1:n) = 0.0D+00 if ( k < 1 .or. n <= k ) then return end if s = sqrt ( dot_product ( a(k:n), a(k:n) ) ) if ( s == 0.0D+00 ) then return end if v(k) = a(k) + sign ( s, a(k) ) v(k+1:n) = a(k+1:n) v(k:n) = v(k:n) / sqrt ( dot_product ( v(k:n), v(k:n) ) ) return end subroutine r8vec_indicator ( n, a ) !*****************************************************************************80 ! !! r8vec_indicator() sets a real vector to the indicator vector. ! ! Discussion: ! ! An R8VEC is a vector of real ( kind = rk ) values. ! ! Licensing: ! ! This code is distributed under the MIT license. ! ! Modified: ! ! 09 February 2001 ! ! Author: ! ! John Burkardt ! ! Input: ! ! integer N, the number of elements of A. ! ! Output: ! ! real ( kind = rk ) A(N), the array to be initialized. ! implicit none integer, parameter :: rk = kind ( 1.0D+00 ) integer n real ( kind = rk ) a(n) integer i do i = 1, n a(i) = real ( i, kind = rk ) end do return end subroutine r8vec_linspace ( n, a, b, x ) !*****************************************************************************80 ! !! r8vec_linspace() creates a vector of linearly spaced values. ! ! Discussion: ! ! An R8VEC is a vector of R8's. ! ! 4 points evenly spaced between 0 and 12 will yield 0, 4, 8, 12. ! ! In other words, the interval is divided into N-1 even subintervals, ! and the endpoints of intervals are used as the points. ! ! Licensing: ! ! This code is distributed under the MIT license. ! ! Modified: ! ! 14 March 2011 ! ! Author: ! ! John Burkardt ! ! Input: ! ! integer N, the number of entries in the vector. ! ! real ( kind = rk ) A, B, the first and last entries. ! ! Output: ! ! real ( kind = rk ) X(N), a vector of linearly spaced data. ! implicit none integer, parameter :: rk = kind ( 1.0D+00 ) integer n real ( kind = rk ) a real ( kind = rk ) b integer i real ( kind = rk ) x(n) if ( n == 1 ) then x(1) = ( a + b ) / 2.0D+00 else do i = 1, n x(i) = ( real ( n - i, kind = rk ) * a & + real ( i - 1, kind = rk ) * b ) & / real ( n - 1, kind = rk ) end do end if return end function r8vec_norm_l2 ( n, a ) !*****************************************************************************80 ! !! r8vec_norm_l2() returns the L2 norm of a vector. ! ! Discussion: ! ! An R8VEC is a vector of real ( kind = rk ) values. ! ! The vector L2 norm is defined as: ! ! value = sqrt ( sum ( 1 <= I <= N ) A(I)^2 ). ! ! Licensing: ! ! This code is distributed under the MIT license. ! ! Modified: ! ! 29 November 1998 ! ! Author: ! ! John Burkardt ! ! Input: ! ! integer N, the number of entries in A. ! ! real ( kind = rk ) A(N), the vector. ! ! Output: ! ! real ( kind = rk ) R8VEC_NORM_L2, the 2-norm of A. ! implicit none integer, parameter :: rk = kind ( 1.0D+00 ) integer n real ( kind = rk ) a(n) real ( kind = rk ) r8vec_norm_l2 r8vec_norm_l2 = sqrt ( sum ( a(1:n) ** 2 ) ) return end subroutine r8vec_print ( n, a, title ) !*****************************************************************************80 ! !! r8vec_print() prints a real vector, with an optional title. ! ! Discussion: ! ! An R8VEC is a vector of real ( kind = rk ) values. ! ! Licensing: ! ! This code is distributed under the MIT license. ! ! Modified: ! ! 16 December 1999 ! ! Author: ! ! John Burkardt ! ! Input: ! ! integer N, the number of components of the vector. ! ! real ( kind = rk ) A(N), the vector. ! ! character ( len = * ) TITLE, a title. ! implicit none integer, parameter :: rk = kind ( 1.0D+00 ) integer n real ( kind = rk ) a(n) integer i character ( len = * ) title write ( *, '(a)' ) ' ' write ( *, '(a)' ) trim ( title ) write ( *, '(a)' ) ' ' do i = 1, n write ( *, '(i8,g14.6)' ) i, a(i) end do return end subroutine r8vec_sort_bubble_a ( n, a ) !*****************************************************************************80 ! !! r8vec_sort_bubble_a() ascending sorts an R8VEC using bubble sort. ! ! Discussion: ! ! This is a quick and dirty version because I can't get to my ! reference copy. ! ! Licensing: ! ! This code is distributed under the MIT license. ! ! Modified: ! ! 27 November 2007 ! ! Author: ! ! John Burkardt ! ! Input: ! ! integer N, the number of entries in the vector. ! ! real ( kind = rk ) A(N), the vector to sort. ! ! Output: ! ! real ( kind = rk ) A(N), the sorted vector. ! implicit none integer, parameter :: rk = kind ( 1.0D+00 ) integer n real ( kind = rk ) a(n) integer i integer j real ( kind = rk ) 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 subroutine r8vec_uniform_01 ( n, seed, r ) !*****************************************************************************80 ! !! r8vec_uniform_01() returns a unit pseudorandom R8VEC. ! ! Discussion: ! ! An R8VEC is a vector of real ( kind = rk ) values. ! ! For now, the input quantity SEED is an integer variable. ! ! Licensing: ! ! This code is distributed under the MIT license. ! ! Modified: ! ! 05 July 2006 ! ! Author: ! ! John Burkardt ! ! Reference: ! ! Paul Bratley, Bennett Fox, Linus Schrage, ! A Guide to Simulation, ! Springer Verlag, pages 201-202, 1983. ! ! Bennett Fox, ! Algorithm 647: ! Implementation and Relative Efficiency of Quasirandom ! Sequence Generators, ! ACM Transactions on Mathematical Software, ! Volume 12, Number 4, pages 362-376, 1986. ! ! Peter Lewis, Allen Goodman, James Miller ! A Pseudo-Random Number Generator for the System/360, ! IBM Systems Journal, ! Volume 8, pages 136-143, 1969. ! ! Input: ! ! integer N, the number of entries in the vector. ! ! integer SEED, a seed for the random number generator. ! ! Output: ! ! real ( kind = rk ) R(N), the vector of pseudorandom values. ! ! integer SEED, an updated seed. ! implicit none integer, parameter :: rk = kind ( 1.0D+00 ) integer n integer i integer k integer seed real ( kind = rk ) r(n) if ( seed == 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 < 0 ) then seed = seed + 2147483647 end if r(i) = real ( seed, kind = rk ) * 4.656612875D-10 end do return end subroutine r8vec_uniform_ab ( n, a, b, seed, r ) !*****************************************************************************80 ! !! r8vec_uniform_ab() returns a scaled pseudorandom R8VEC. ! ! Discussion: ! ! An R8VEC is a vector of R8's. ! ! Each dimension ranges from A to B. ! ! Licensing: ! ! This code is distributed under the MIT license. ! ! Modified: ! ! 31 May 2007 ! ! Author: ! ! John Burkardt ! ! Reference: ! ! Paul Bratley, Bennett Fox, Linus Schrage, ! A Guide to Simulation, ! Second Edition, ! Springer, 1987, ! ISBN: 0387964673, ! LC: QA76.9.C65.B73. ! ! Bennett Fox, ! Algorithm 647: ! Implementation and Relative Efficiency of Quasirandom ! Sequence Generators, ! ACM Transactions on Mathematical Software, ! Volume 12, Number 4, December 1986, pages 362-376. ! ! Pierre L'Ecuyer, ! Random Number Generation, ! in Handbook of Simulation, ! edited by Jerry Banks, ! Wiley, 1998, ! ISBN: 0471134031, ! LC: T57.62.H37. ! ! Peter Lewis, Allen Goodman, James Miller, ! A Pseudo-Random Number Generator for the System/360, ! IBM Systems Journal, ! Volume 8, Number 2, 1969, pages 136-143. ! ! Input: ! ! integer N, the number of entries in the vector. ! ! real ( kind = rk ) A, B, the lower and upper limits. ! ! integer SEED, a seed for the random number generator. ! ! Output: ! ! real ( kind = rk ) R(N), the vector of pseudorandom values. ! ! integer SEED, an updated seed. ! implicit none integer, parameter :: rk = kind ( 1.0D+00 ) integer n real ( kind = rk ) a real ( kind = rk ) b integer i integer, parameter :: i4_huge = 2147483647 integer k integer seed real ( kind = rk ) r(n) if ( seed == 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 < 0 ) then seed = seed + i4_huge end if r(i) = a + ( b - a ) * real ( seed, kind = rk ) * 4.656612875D-10 end do return end subroutine r8vec2_print ( n, a1, a2, title ) !*****************************************************************************80 ! !! r8vec2_print() prints a pair of real vectors. ! ! Licensing: ! ! This code is distributed under the MIT license. ! ! Modified: ! ! 14 June 2000 ! ! Author: ! ! John Burkardt ! ! Input: ! ! integer N, the number of components of the vector. ! ! real ( kind = rk ) A1(N), A2(N), the vectors to be printed. ! ! character ( len = * ) TITLE, a title. ! implicit none integer, parameter :: rk = kind ( 1.0D+00 ) integer n real ( kind = rk ) a1(n) real ( kind = rk ) a2(n) integer i character ( len = * ) 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 subroutine random_seed_initialize ( key ) !*****************************************************************************80 ! !! random_seed_initialize() initializes the FORTRAN90 random number generator. ! ! Discussion: ! ! This is the stupidest, most awkward procedure I have seen! ! ! Modified: ! ! 27 October 2021 ! ! Author: ! ! John Burkardt ! ! Input: ! ! integer KEY: an initial seed for the random number generator. ! implicit none integer key integer, allocatable :: seed(:) integer seed_size call random_seed ( size = seed_size ) allocate ( seed(seed_size) ) seed(1:seed_size) = key call random_seed ( put = seed ) deallocate ( seed ) return end function rayleigh ( n, a, x ) !*****************************************************************************80 ! !! rayleigh() returns the Rayleigh quotient of the matrix A and the vector X. ! ! Formula: ! ! RAYLEIGH = X' * A * X / ( X' * X ) ! ! Properties: ! ! If X is an eigenvector of A, then RAYLEIGH will equal the ! corresponding eigenvalue. ! ! The set of all Rayleigh quotients for a matrix is known ! as its "field of values". ! ! Licensing: ! ! This code is distributed under the MIT license. ! ! Modified: ! ! 26 May 2002 ! ! Author: ! ! John Burkardt ! ! Input: ! ! integer N, the order of the matrix. ! ! real ( kind = rk ) A(N,N), the matrix. ! ! real ( kind = rk ) X(N), the vector used in the Rayleigh quotient. ! ! Output: ! ! real ( kind = rk ) RAYLEIGH, the Rayleigh quotient of A and X. ! implicit none integer, parameter :: rk = kind ( 1.0D+00 ) integer n real ( kind = rk ) a(n,n) real ( kind = rk ) rayleigh real ( kind = rk ) x(n) rayleigh = dot_product ( x(1:n), matmul ( a(1:n,1:n), x(1:n) ) ) & / dot_product ( x(1:n), x(1:n) ) return end function rayleigh2 ( n, a, x, y ) !*****************************************************************************80 ! !! rayleigh2() returns the generalized Rayleigh quotient. ! ! Formula: ! ! RAYLEIGH2 = X' * A * Y / ( X' * Y ) ! ! Licensing: ! ! This code is distributed under the MIT license. ! ! Modified: ! ! 26 May 2002 ! ! Author: ! ! John Burkardt ! ! Input: ! ! integer N, the order of the matrix. ! ! real ( kind = rk ) A(N,N), the matrix. ! ! real ( kind = rk ) X(N), Y(N), the vectors used in the ! Rayleigh quotient. ! ! Output: ! ! real ( kind = rk ) RAYLEIGH2, the Rayleigh quotient of A and X. ! implicit none integer, parameter :: rk = kind ( 1.0D+00 ) integer n real ( kind = rk ) a(n,n) real ( kind = rk ) rayleigh2 real ( kind = rk ) x(n) real ( kind = rk ) y(n) rayleigh2 = dot_product ( x(1:n), matmul ( a(1:n,1:n), y(1:n) ) ) & / dot_product ( x(1:n), y(1:n) ) return end subroutine rectangle_adj_matrix ( row_num, col_num, n, a ) !*****************************************************************************80 ! !! rectangle_adj_matrix() returns the RECTANGLE_ADJ matrix. ! ! Discussion: ! ! This is the adjacency matrix for a set of points arranged in ! a ROW_NUM by COL_NUM grid. ! ! Diagram: ! ! 1---5---9 ! | | | ! 2---6--10 ! | | | ! 3---7--11 ! | | | ! 4---8--12 ! ! Example: ! ! ROW_NUM = 4 ! COL_NUM = 3 ! ! 0 1 0 0 1 0 0 0 0 0 0 0 ! 1 0 1 0 0 1 0 0 0 0 0 0 ! 0 1 0 1 0 0 1 0 0 0 0 0 ! 0 0 1 0 1 0 0 1 0 0 0 0 ! ! 1 0 0 0 0 1 0 0 1 0 0 0 ! 0 1 0 0 1 0 1 0 0 1 0 0 ! 0 0 1 0 0 1 0 1 0 0 1 0 ! 0 0 0 1 0 0 1 0 0 0 0 1 ! ! 0 0 0 0 1 0 0 0 0 1 0 0 ! 0 0 0 0 0 1 0 0 1 0 1 0 ! 0 0 0 0 0 0 1 0 0 1 0 1 ! 0 0 0 0 0 0 0 1 0 0 1 0 ! ! Properties: ! ! A is integral, therefore det ( A ) is integral, and ! det ( A ) * inverse ( A ) is integral. ! ! A is a zero/one matrix. ! ! A is block tridiagonal. ! ! A is an adjacency matrix. ! ! A is related to the "LIGHTS_OUT" matrix. ! ! A is symmetric: A' = A. ! ! Because A is symmetric, it is normal. ! ! Because A is normal, it is diagonalizable. ! ! If 1 < ROW_NUM and 1 < COL_NUM, the matrix is singular. ! Take any four nodes which form a square, set X(NW) = X(SW) = 1 ! and X(NE) = X(SE) = -1 and all other X's to 0, and you have ! a null vector. ! ! Licensing: ! ! This code is distributed under the MIT license. ! ! Modified: ! ! 20 June 2011 ! ! Author: ! ! John Burkardt ! ! Input: ! ! integer ROW_NUM, COL_NUM, the number of rows and ! columns in the rectangle. ! ! integer N, the order of the matrix. ! N = ROW_NUM * COL_NUM. ! ! Output: ! ! real ( kind = rk ) A(N,N), the matrix. ! implicit none integer, parameter :: rk = kind ( 1.0D+00 ) integer n real ( kind = rk ) a(n,n) integer col_num integer i integer i_block integer j integer j_block integer row_num do j_block = 1, col_num j = ( j_block - 1 ) * row_num + 1 do i_block = 1, col_num i = ( i_block - 1 ) * row_num + 1 if ( j_block == i_block ) then call line_adj_matrix ( row_num, a(i:i+row_num-1,j:j+row_num-1) ) else if ( abs ( j_block - i_block ) == 1 ) then call identity_matrix ( row_num, row_num, a(i:i+row_num-1,j:j+row_num-1) ) else call zero_matrix ( row_num, row_num, a(i:i+row_num-1,j:j+row_num-1) ) end if end do end do return end subroutine rectangle_adj_determinant ( row_num, col_num, determ ) !*****************************************************************************80 ! !! rectangle_adj_determinant(): the determinant of the RECTANGLE_ADJ matrix. ! ! Licensing: ! ! This code is distributed under the MIT license. ! ! Modified: ! ! 21 November 2007 ! ! Author: ! ! John Burkardt ! ! Input: ! ! integer ROW_NUM, COL_NUM, the number of rows and ! columns in the rectangle. ! ! Output: ! ! real ( kind = rk ) DETERM, the determinant. ! implicit none integer, parameter :: rk = kind ( 1.0D+00 ) integer col_num integer row_num real ( kind = rk ) determ ! ! If ROW_NUM == 1 or COL_NUM == 1 we have a case of the line_adj matrix. ! if ( row_num == 1 ) then if ( mod ( row_num, 4 ) == 1 ) then determ = 0.0D+00 else if ( mod ( row_num, 4 ) == 2 ) then determ = - 1.0D+00 else if ( mod ( row_num, 4 ) == 3 ) then determ = 0.0D+00 else if ( mod ( row_num, 4 ) == 0 ) then determ = + 1.0D+00 end if else if ( col_num == 1 ) then if ( mod ( col_num, 4 ) == 1 ) then determ = 0.0D+00 else if ( mod ( col_num, 4 ) == 2 ) then determ = - 1.0D+00 else if ( mod ( col_num, 4 ) == 3 ) then determ = 0.0D+00 else if ( mod ( col_num, 4 ) == 0 ) then determ = + 1.0D+00 end if ! ! Otherwise, we can form at least one square, hence a null vector, ! hence the matrix is singular. ! else determ = 0.0D+00 end if return end subroutine redheffer_matrix ( n, a ) !*****************************************************************************80 ! !! redheffer_matrix() returns the REDHEFFER matrix. ! ! Formula: ! ! if ( J = 1 or mod ( J, I ) == 0 ) ! A(I,J) = 1 ! else ! A(I,J) = 0 ! ! Example: ! ! N = 5 ! ! 1 1 1 1 1 ! 1 1 0 1 0 ! 1 0 1 0 0 ! 1 0 0 1 0 ! 1 0 0 0 1 ! ! Properties: ! ! A is generally not symmetric: A' /= A. ! ! A is integral, therefore det ( A ) is integral, and ! det ( A ) * inverse ( A ) is integral. ! ! The diagonal entries of A are all 1. ! ! A is a zero/one matrix. ! ! N - int ( log2 ( N ) ) - 1 eigenvalues are equal to 1. ! ! There is a real eigenvalue of magnitude approximately sqrt ( N ), ! which is the spectral radius of the matrix. ! ! There is a negative eigenvalue of value approximately -sqrt ( N ). ! ! The remaining eigenvalues are "small", and there is a conjecture ! that they lie inside the unit circle in the complex plane. ! ! The determinant is equal to the Mertens function M(N). ! ! The family of matrices is nested as a function of N. ! ! Licensing: ! ! This code is distributed under the MIT license. ! ! Modified: ! ! 15 April 1999 ! ! Author: ! ! John Burkardt ! ! Reference: ! ! Wayne Barrett, Tyler Jarvis, ! Spectral Properties of a Matrix of Redheffer, ! Linear Algebra and Applications, ! Volume 162, 1992, pages 673-683. ! ! Input: ! ! integer N, the order of the matrix. ! ! Output: ! ! real ( kind = rk ) A(N,N), the matrix. ! implicit none integer, parameter :: rk = kind ( 1.0D+00 ) integer n real ( kind = rk ) a(n,n) integer i integer j do i = 1, n do j = 1, n if ( j == 1 .or. mod ( j, i ) == 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 ) !*****************************************************************************80 ! !! redheffer_determinant() returns the determinant of the REDHEFFER matrix. ! ! Licensing: ! ! This code is distributed under the MIT license. ! ! Modified: ! ! 17 October 2007 ! ! Author: ! ! John Burkardt ! ! Input: ! ! integer N, the order of the matrix. ! ! Output: ! ! real ( kind = rk ) DETERM, the determinant. ! implicit none integer, parameter :: rk = kind ( 1.0D+00 ) integer n real ( kind = rk ) determ integer mertens determ = real ( mertens ( n ), kind = rk ) return end subroutine ref_random_matrix ( m, n, prob, a ) !*****************************************************************************80 ! !! ref_random_matrix() returns a REF_RANDOM matrix. ! ! Discussion: ! ! The matrix returned is a random matrix in row echelon form. ! ! The definition of row echelon form requires: ! ! 1) the first nonzero entry in any row is 1. ! ! 2) the first nonzero entry in row I occurs in a later column ! than the first nonzero entry of every previous row. ! ! 3) rows that are entirely zero occur after all rows with ! nonzero entries. ! ! Example: ! ! M = 6, N = 5, PROB = 0.8 ! ! 1.0 0.3 0.2 0.0 0.5 ! 0.0 0.0 1.0 0.7 0.9 ! 0.0 0.0 0.0 1.0 0.3 ! 0.0 0.0 0.0 0.0 1.0 ! 0.0 0.0 0.0 0.0 0.0 ! 0.0 0.0 0.0 0.0 0.0 ! ! Properties: ! ! A is generally not symmetric: A' /= A. ! ! Licensing: ! ! This code is distributed under the MIT license. ! ! Modified: ! ! 09 November 1998 ! ! Author: ! ! John Burkardt ! ! Input: ! ! integer M, N, the order of the matrix. ! ! real ( kind = rk ) PROB, the probability that the 1 in the next ! row will be placed as early as possible. ! Setting PROB = 1 forces the 1 to occur immediately, setting ! PROB = 0 forces the entire matrix to be zero. A more reasonable ! value might be PROB = 0.8 or 0.9. ! ! Output: ! ! real ( kind = rk ) A(M,N), the matrix. ! implicit none integer, parameter :: rk = kind ( 1.0D+00 ) integer m integer n real ( kind = rk ) a(m,n) integer i integer j integer jnew integer jprev real ( kind = rk ) prob real ( kind = rk ) temp jprev = 0 do i = 1, m jnew = 0 do j = 1, n if ( j <= jprev ) then a(i,j) = 0.0D+00 else if ( jnew == 0 ) then call random_number ( harvest = temp ) if ( temp <= prob ) then jnew = j a(i,j) = 1.0D+00 else a(i,j) = 0.0D+00 end if else call random_number ( harvest = a(i,j) ) end if end do if ( jnew == 0 ) then jnew = n + 1 end if jprev = jnew end do return end subroutine ref_random_determinant ( n, prob, determ ) !*****************************************************************************80 ! !! ref_random_determinant(): determinant of a REF_RANDOM matrix. ! ! Licensing: ! ! This code is distributed under the MIT license. ! ! Modified: ! ! 06 July 2011 ! ! Author: ! ! John Burkardt ! ! Input: ! ! integer N, the order of the matrix. ! ! real ( kind = rk ) PROB, the probability that the 1 in the next ! row will be placed as early as possibly. ! Setting PROB = 1 forces the 1 to occur immediately, setting ! PROB = 0 forces the entire matrix to be zero. A more reasonable ! value might be PROB = 0.8 or 0.9. ! ! Output: ! ! real ( kind = rk ) DETERM, the determinant. ! implicit none integer, parameter :: rk = kind ( 1.0D+00 ) real ( kind = rk ) determ integer i integer j integer jnew integer jprev integer n real ( kind = rk ) prob real ( kind = rk ) temp determ = 1.0D+00 jprev = 0 do i = 1, n jnew = 0 do j = 1, n if ( j <= jprev ) then else if ( jnew == 0 ) then call random_number ( harvest = temp ) if ( temp <= prob ) then jnew = j else end if else call random_number ( harvest = temp ) end if end do if ( jnew /= i ) then determ = 0.0D+00 end if if ( jnew == 0 ) then jnew = n + 1 end if jprev = jnew end do return end subroutine riemann_matrix ( m, n, a ) !*****************************************************************************80 ! !! riemann_matrix() returns the RIEMANN matrix. ! ! Formula: ! ! if ( I + 1 divides J + 1 evenly ) ! A(I,J) = I ! else ! A(I,J) = -1 ! ! Example: ! ! M = 5, N = 5 ! ! 1 -1 1 -1 1 ! -1 2 -1 -1 2 ! -1 -1 3 -1 -1 ! -1 -1 -1 4 -1 ! -1 -1 -1 -1 5 ! ! Discussion: ! ! The Riemann hypothesis is true if and only if the determinant of A ! is of order (N! * N^(-.5 + epsilon)) for every positive epsilon. ! ! Properties: ! ! A is generally not symmetric: A' /= A. ! ! A is integral, therefore det ( A ) is integral, and ! det ( A ) * inverse ( A ) is integral. ! ! The strict lower triangular entries are all -1. ! ! If A is square, then each eigenvalue LAMBDA(I) satisfies ! abs ( LAMBDA(I) ) <= (N+1) - 1 / (N+1), ! and eigenvalue LAMBDA(I) satisfies ! 1 <= LAMBDA(I) <= I + 1 ! except for at most (N+1) - sqrt ( N + 1 ) values, and ! all integers in the interval ( (N+1)/3, (N+1)/2 ] are eigenvalues. ! ! The family of matrices is nested as a function of N. ! ! Licensing: ! ! This code is distributed under the MIT license. ! ! Modified: ! ! 15 April 1999 ! ! Author: ! ! John Burkardt ! ! Reference: ! ! Friedrich Roesler, ! Riemann's hypothesis as an eigenvalue problem, ! Linear Algebra and Applications, ! Volume 81, 1986, pages 153-198. ! ! Input: ! ! integer M, N, the order of the matrix. ! ! Output: ! ! real ( kind = rk ) A(M,N), the matrix. ! implicit none integer, parameter :: rk = kind ( 1.0D+00 ) integer m integer n real ( kind = rk ) a(m,n) integer i integer j do i = 1, m do j = 1, n if ( mod ( j + 1, i + 1 ) == 0 ) then a(i,j) = real ( i, kind = rk ) else a(i,j) = - 1.0D+00 end if end do end do return end subroutine ring_adj_matrix ( n, a ) !*****************************************************************************80 ! !! ring_adj_matrix() returns the RING_ADJ matrix. ! ! Discussion: ! ! This is the adjacency matrix for a ring, or set of points on a circle. ! ! Example: ! ! N = 5 ! ! 0 1 0 0 1 ! 1 0 1 0 0 ! 0 1 0 1 0 ! 0 0 1 0 1 ! 1 0 0 1 0 ! ! Properties: ! ! A is symmetric: A' = A. ! ! Because A is symmetric, it is normal. ! ! Because A is normal, it is diagonalizable. ! ! The determinant for N = 1 is 1, for N = 2 is -1, and for 2 < N, ! mod ( N, 4 ) = 1 ==> det ( A ) = 2 ! mod ( N, 4 ) = 2 ==> det ( A ) = -4 ! mod ( N, 4 ) = 3 ==> det ( A ) = 2 ! mod ( N, 4 ) = 0 ==> det ( A ) = 0 ! ! A is a zero/one matrix. ! ! A is an adjacency matrix. ! ! A has a zero diagonal. ! ! A is cyclic tridiagonal. ! ! A is a circulant matrix: each row is shifted once to get the next row. ! ! A has a constant row sum of 2. ! ! Because it has a constant row sum of 2, ! A has an eigenvalue of 2, and ! a right eigenvector of ( 1, 1, 1, ..., 1 ). ! ! A has a constant column sum of 2. ! ! Because it has a constant column sum of 2, ! A has an eigenvalue of 2, and ! a left eigenvector of ( 1, 1, 1, ..., 1 ). ! ! A is persymmetric: A(I,J) = A(N+1-J,N+1-I). ! ! A is centrosymmetric: A(I,J) = A(N+1-I,N+1-J). ! ! When N is a multiple of 4, A has the null vector ! (1,1,-1,-1, 1,1,-1,-1, ..., 1,1,-1,-1) ! ! Licensing: ! ! This code is distributed under the MIT license. ! ! Modified: ! ! 01 April 2000 ! ! Author: ! ! John Burkardt ! ! Input: ! ! integer N, the order of the matrix. ! ! Output: ! ! real ( kind = rk ) A(N,N), the matrix. ! implicit none integer, parameter :: rk = kind ( 1.0D+00 ) integer n real ( kind = rk ) a(n,n) integer i integer j do i = 1, n do j = 1, n if ( j == i + 1 .or. j == i - 1 .or. j == i + 1 - n .or. & j == 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 ) !*****************************************************************************80 ! !! ring_adj_determinant() returns the determinant of the RING_ADJ matrix. ! ! Licensing: ! ! This code is distributed under the MIT license. ! ! Modified: ! ! 13 October 2007 ! ! Author: ! ! John Burkardt ! ! Input: ! ! integer N, the order of the matrix. ! ! Output: ! ! real ( kind = rk ) DETERM, the determinant. ! implicit none integer, parameter :: rk = kind ( 1.0D+00 ) real ( kind = rk ) determ integer n if ( n == 1 ) then determ = 1.0D+00 else if ( n == 2 ) then determ = -1.0D+00 else if ( mod ( n, 4 ) == 0 ) then determ = 0.0D+00 else if ( mod ( n, 4 ) == 1 ) then determ = 2.0D+00 else if ( mod ( n, 4 ) == 2 ) then determ = -4.0D+00 else if ( mod ( n, 4 ) == 3 ) then determ = 2.0D+00 end if return end subroutine ring_adj_null_left ( m, n, x ) !*****************************************************************************80 ! !! ring_adj_null_left() returns a left null vector of the RING_ADJ matrix. ! ! Licensing: ! ! This code is distributed under the MIT license. ! ! Modified: ! ! 12 March 2015 ! ! Author: ! ! John Burkardt ! ! Input: ! ! integer M, N, the order of the matrix. ! ! Output: ! ! real ( kind = rk ) X(M), the null vector. ! implicit none integer, parameter :: rk = kind ( 1.0D+00 ) integer m integer n real ( kind = rk ) x(m) call i4_fake_use ( n ) if ( mod ( m, 4 ) /= 0 ) then write ( *, '(a)' ) ' ' write ( *, '(a)' ) 'RING_ADJ_NULL_LEFT - Fatal error!' write ( *, '(a)' ) ' N must be a multiple of 4.' stop 1 end if x(1:m:4) = + 1.0D+00 x(2:m:4) = + 1.0D+00 x(3:m:4) = - 1.0D+00 x(4:m:4) = - 1.0D+00 return end subroutine ring_adj_null_right ( m, n, x ) !*****************************************************************************80 ! !! ring_adj_null_right() returns a right null vector of the RING_ADJ matrix. ! ! Licensing: ! ! This code is distributed under the MIT license. ! ! Modified: ! ! 03 November 2007 ! ! Author: ! ! John Burkardt ! ! Input: ! ! integer M, N, the order of the matrix. ! ! Output: ! ! real ( kind = rk ) X(N), the null vector. ! implicit none integer, parameter :: rk = kind ( 1.0D+00 ) integer m integer n real ( kind = rk ) x(n) call i4_fake_use ( m ) if ( mod ( n, 4 ) /= 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 x(1:n:4) = + 1.0D+00 x(2:n:4) = + 1.0D+00 x(3:n:4) = - 1.0D+00 x(4:n:4) = - 1.0D+00 return end subroutine ris_matrix ( n, a ) !*****************************************************************************80 ! !! ris_matrix() returns the RIS matrix. ! ! Discussion: ! ! This matrix is also called the dingdong matrix. It was invented ! by FN Ris. ! ! Formula: ! ! A(I,J) = 1 / ( 3 + 2 * N - 2 * I - 2 * J ) ! ! Example: ! ! N = 5 ! ! 1/9 1/7 1/5 1/3 1 ! 1/7 1/5 1/3 1 -1 ! 1/5 1/3 1 -1 -1/3 ! 1/3 1 -1 -1/3 -1/5 ! 1 -1 -1/3 -1/5 -1/7 ! ! Properties: ! ! A is a Cauchy matrix. ! ! A is a Hankel matrix: constant along anti-diagonals. ! ! A is symmetric: A' = A. ! ! Because A is symmetric, it is normal. ! ! Because A is normal, it is diagonalizable. ! ! The eigenvalues of A cluster around PI/2 and -PI/2. ! ! Licensing: ! ! This code is distributed under the MIT license. ! ! Modified: ! ! 24 May 2002 ! ! Author: ! ! John Burkardt ! ! Reference: ! ! John Nash, ! Compact Numerical Methods for Computers: Linear Algebra and ! Function Minimisation, ! Second Edition, ! Taylor & Francis, 1990, ! ISBN: 085274319X, ! LC: QA184.N37. ! ! Input: ! ! integer N, the order of the matrix. ! ! Output: ! ! real ( kind = rk ) A(N,N), the matrix. ! implicit none integer, parameter :: rk = kind ( 1.0D+00 ) integer n real ( kind = rk ) a(n,n) integer i integer j do i = 1, n do j = 1, n a(i,j) = 1.0D+00 / real ( 3 + 2 * n - 2 * i - 2 * j, kind = rk ) end do end do return end subroutine ris_determinant ( n, determ ) !*****************************************************************************80 ! !! ris_determinant() returns the determinant of the RIS matrix. ! ! Licensing: ! ! This code is distributed under the MIT license. ! ! Modified: ! ! 24 May 2002 ! ! Author: ! ! John Burkardt ! ! Input: ! ! integer N, the order of the matrix. ! ! Output: ! ! real ( kind = rk ) DETERM, the determinant. ! implicit none integer, parameter :: rk = kind ( 1.0D+00 ) integer n real ( kind = rk ) bottom real ( kind = rk ) determ integer i integer j real ( kind = rk ) top top = 1.0D+00 do i = 1, n do j = i + 1, n top = top * real ( 4 * ( i - j ) * ( i - j ), kind = rk ) end do end do bottom = 1.0D+00 do i = 1, n do j = 1, n bottom = bottom * real ( 3 + 2 * n - 2 * i - 2 * j, kind = rk ) end do end do determ = top / bottom return end subroutine ris_inverse ( n, a ) !*****************************************************************************80 ! !! ris_inverse() returns the inverse of the RIS matrix. ! ! Example: ! ! N = 5 ! ! 0.6729 0.3845 0.3461 0.3845 0.6729 ! 0.3845 0.2393 0.2563 0.5127 -0.2991 ! 0.3461 0.2563 0.4944 -0.3296 -0.0641 ! 0.3845 0.5127 -0.3296 -0.0732 -0.0256 ! 0.6729 -0.2991 -0.0641 -0.0256 -0.0107 ! ! Licensing: ! ! This code is distributed under the MIT license. ! ! Modified: ! ! 24 May 2002 ! ! Author: ! ! John Burkardt ! ! Input: ! ! integer N, the order of the matrix. ! ! Output: ! ! real ( kind = rk ) A(N,N), the matrix. ! implicit none integer, parameter :: rk = kind ( 1.0D+00 ) integer n real ( kind = rk ) a(n,n) real ( kind = rk ) bot1 real ( kind = rk ) bot2 integer i integer j integer k real ( kind = rk ) 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 /= j ) then bot1 = bot1 * real ( 2 * ( k - j ), kind = rk ) end if if ( k /= i ) then bot2 = bot2 * real ( 2 * ( k - i ), kind = rk ) end if end do a(i,j) = top & / ( real ( 3 + 2 * n - 2 * j - 2 * i, kind = rk ) * bot1 * bot2 ) end do end do return end subroutine rodman_matrix ( m, n, alpha, a ) !*****************************************************************************80 ! !! rodman_matrix() returns the RODMAN matrix. ! ! Formula: ! ! If ( I = J ) then ! A(I,J) = 1 ! else ! A(I,J) = ALPHA ! ! Example: ! ! M = 5, N = 5, ALPHA = 2 ! ! 1 2 2 2 2 ! 2 1 2 2 2 ! 2 2 1 2 2 ! 2 2 2 1 2 ! 2 2 2 2 1 ! ! Properties: ! ! A is a special case of the combinatorial matrix. ! ! A is Toeplitz: constant along diagonals. ! ! A is a circulant matrix: each row is shifted once to get the next row. ! ! A has constant row sum. ! ! Because it has a constant row sum of 1+(N-1)*ALPHA, ! A has an eigenvalue of 1+(N-1)*ALPHA, and ! a right eigenvector of ( 1, 1, 1, ..., 1 ). ! ! A has constant column sum. ! ! Because it has a constant column sum of 1+(N-1)*ALPHA, ! A has an eigenvalue of 1+(N-1)*ALPHA, and ! a left eigenvector of ( 1, 1, 1, ..., 1 ). ! ! A is symmetric: A' = A. ! ! Because A is symmetric, it is normal. ! ! Because A is normal, it is diagonalizable. ! ! A is persymmetric: A(I,J) = A(N+1-J,N+1-I). ! ! A is centrosymmetric: A(I,J) = A(N+1-I,N+1-J). ! ! A is positive definite for ALPHA < 1. ! ! The eigenvalues and eigenvectors of A are: ! ! For I = 1 to N-1: ! ! LAMBDA(I) = 1 - ALPHA ! V(I) = ( - sum ( 2 <= J <= N ) X(J), X(2), X(3), ..., X(N) ) ! ! For I = N: ! ! LAMBDA(I) = 1 + ALPHA * ( N - 1 ) ! V(I) = ( 1, 1, 1, ..., 1 ) ! ! det ( A ) = ( 1 - ALPHA )^(N-1) * ( 1 + ALPHA * ( N - 1 ) ). ! ! A is nonsingular if ALPHA is not 1, and ALPHA is not -1/(N-1). ! ! The family of matrices is nested as a function of N. ! ! Licensing: ! ! This code is distributed under the MIT license. ! ! Modified: ! ! 18 July 1998 ! ! Author: ! ! John Burkardt ! ! Reference: ! ! Joan Westlake, ! A Handbook of Numerical Matrix Inversion and Solution of ! Linear Equations, ! John Wiley, 1968, ! ISBN13: 978-0471936756, ! LC: QA263.W47. ! ! Input: ! ! integer M, N, the order of the matrix. ! ! real ( kind = rk ) ALPHA, the parameter. ! ! Output: ! ! real ( kind = rk ) A(M,N), the matrix. ! implicit none integer, parameter :: rk = kind ( 1.0D+00 ) integer m integer n real ( kind = rk ) a(m,n) real ( kind = rk ) alpha integer i a(1:m,1:n) = alpha do i = 1, min ( m, n ) a(i,i) = 1.0D+00 end do return end subroutine rodman_condition ( n, alpha, value ) !*****************************************************************************80 ! !! rodman_condition() returns the L1 condition of the RODMAN matrix. ! ! Licensing: ! ! This code is distributed under the MIT license. ! ! Modified: ! ! 04 April 2015 ! ! Author: ! ! John Burkardt ! ! Input: ! ! integer N, the order of A. ! ! real ( kind = rk ) ALPHA, the parameter. ! ! Output: ! ! real ( kind = rk ) VALUE, the L1 condition. ! implicit none integer, parameter :: rk = kind ( 1.0D+00 ) real ( kind = rk ) a_norm real ( kind = rk ) alpha real ( kind = rk ) b_norm real ( kind = rk ) bot integer n real ( kind = rk ) top real ( kind = rk ) value a_norm = 1.0D+00 + real ( n - 1, kind = rk ) * abs ( alpha ) top = abs ( 1.0D+00 + alpha * real ( n - 2, kind = rk ) ) & + real ( n - 1, kind = rk ) * abs ( alpha ) bot = abs ( 1.0D+00 + alpha * real ( n - 2, kind = rk ) & - alpha * alpha * real ( n - 1, kind = rk ) ) b_norm = top / bot value = a_norm * b_norm return end subroutine rodman_determinant ( n, alpha, value ) !*****************************************************************************80 ! !! rodman_determinant() returns the determinant of the RODMAN matrix. ! ! Licensing: ! ! This code is distributed under the MIT license. ! ! Modified: ! ! 21 May 2002 ! ! Author: ! ! John Burkardt ! ! Input: ! ! integer N, the order of the matrix. ! ! real ( kind = rk ) ALPHA, the parameter. ! ! Output: ! ! real ( kind = rk ) VALUE, the determinant. ! implicit none integer, parameter :: rk = kind ( 1.0D+00 ) real ( kind = rk ) alpha integer n real ( kind = rk ) value value = ( 1.0D+00 - alpha ) ** ( n - 1 ) * ( 1.0D+00 + alpha & * real ( n - 1, kind = rk ) ) return end subroutine rodman_eigen_right ( n, alpha, x ) !*****************************************************************************80 ! !! rodman_eigen_right() returns the right eigenvectors of the RODMAN matrix. ! ! Licensing: ! ! This code is distributed under the MIT license. ! ! Modified: ! ! 25 November 2007 ! ! Author: ! ! John Burkardt ! ! Input: ! ! integer N, the order of the matrix. ! ! real ( kind = rk ) ALPHA, the parameter. ! ! Output: ! ! real ( kind = rk ) X(N,N), the right eigenvectors. ! implicit none integer, parameter :: rk = kind ( 1.0D+00 ) integer n real ( kind = rk ) alpha integer j real ( kind = rk ) x(n,n) call r8_fake_use ( alpha ) x(1:n,1:n) = 0.0D+00 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 rodman_eigenvalues ( n, alpha, lambda ) !*****************************************************************************80 ! !! rodman_eigenvalues() returns the eigenvalues of the RODMAN matrix. ! ! Licensing: ! ! This code is distributed under the MIT license. ! ! Licensing: ! ! This code is distributed under the MIT license. ! ! Modified: ! ! 21 May 2002 ! ! Author: ! ! John Burkardt ! ! Input: ! ! integer N, the order of the matrix. ! ! real ( kind = rk ) ALPHA, the parameter. ! ! Output: ! ! real ( kind = rk ) LAMBDA(N), the eigenvalues. ! implicit none integer, parameter :: rk = kind ( 1.0D+00 ) integer n real ( kind = rk ) alpha real ( kind = rk ) lambda(n) lambda(1:n-1) = 1.0D+00 - alpha lambda(n) = 1.0D+00 + alpha * real ( n - 1, kind = rk ) return end subroutine rodman_inverse ( n, alpha, a ) !*****************************************************************************80 ! !! rodman_inverse() returns the inverse of the RODMAN matrix. ! ! Formula: ! ! If ( I = J ) then ! A(I,J) = ( 1 + ALPHA * ( N - 2 ) ) / ! ( 1 + ALPHA * ( N - 2 ) - ALPHA^2 * ( N - 1 ) ) ! else ! A(I,J) = - ALPHA / ! ( 1 + ALPHA * ( N - 2 ) - ALPHA^2 * ( N - 1 ) ) ! ! Example: ! ! N = 5, ALPHA = 2.0 ! ! -0.7778 0.2222 0.2222 0.2222 0.2222 ! 0.2222 -0.7778 0.2222 0.2222 0.2222 ! 0.2222 0.2222 -0.7778 0.2222 0.2222 ! 0.2222 0.2222 0.2222 -0.7778 0.2222 ! 0.2222 0.2222 0.2222 0.2222 -0.7778 ! ! Licensing: ! ! This code is distributed under the MIT license. ! ! Modified: ! ! 18 July 1998 ! ! Author: ! ! John Burkardt ! ! Reference: ! ! Joan Westlake, ! A Handbook of Numerical Matrix Inversion and Solution of ! Linear Equations, ! John Wiley, 1968, ! ISBN13: 978-0471936756, ! LC: QA263.W47. ! ! Input: ! ! integer N, the order of the matrix. ! ! real ( kind = rk ) ALPHA, the parameter. ! ! Output: ! ! real ( kind = rk ) A(N,N), the matrix. ! implicit none integer, parameter :: rk = kind ( 1.0D+00 ) integer n real ( kind = rk ) a(n,n) real ( kind = rk ) alpha real ( kind = rk ) bot integer i integer j bot = 1.0D+00 + alpha * real ( n - 2, kind = rk ) & - alpha * alpha * real ( n - 1, kind = rk ) do i = 1, n do j = 1, n if ( i == j ) then a(i,j) = ( 1.0D+00 + alpha * real ( n - 2, kind = rk ) ) / bot else a(i,j) = - alpha / bot end if end do end do return end subroutine rosser1_matrix ( a ) !*****************************************************************************80 ! !! rosser1_matrix() returns the ROSSER1 matrix. ! ! Example: ! ! 611 196 -192 407 -8 -52 -49 29 ! 196 899 113 -192 -71 -43 -8 -44 ! -192 113 899 196 61 49 8 52 ! 407 -192 196 611 8 44 59 -23 ! -8 -71 61 8 411 -599 208 208 ! -52 -43 49 44 -599 411 208 208 ! -49 -8 8 59 208 208 99 -911 ! 29 -44 52 -23 208 208 -911 99 ! ! Properties: ! ! A is singular. ! ! det ( A ) = 0. ! ! A is symmetric: A' = A. ! ! Because A is symmetric, it is normal. ! ! Because A is normal, it is diagonalizable. ! ! A is integral, therefore det ( A ) is integral, and ! det ( A ) * inverse ( A ) is integral. ! ! The eigenvalues of A are: ! ! a = sqrt(10405), b = sqrt(26), ! ! LAMBDA = (-10*a, 0, 510-100*b, 1000, 1000, 510+100*b, 1020, 10*a) ! ! ( 10*a = 1020.04901843, 510-100*b = 0.09804864072 ) ! ! The eigenvectors are ! ! ( 2, 1, 1, 2, 102+a, 102+a, -204-2a, -204-2a ) ! ( 1, 2, -2, -1, 14, 14, 7, 7 ) ! ( 2, -1, 1, -2, 5-b, -5+b, -10+2b, 10-2b ) ! ( 7, 14, -14, -7, -2, -2, -1, -1 ) ! ( 1, -2, -2, 1, -2, 2, -1, 1 ) ! ( 2, -1, 1, -2, 5+b, -5-b, -10-2b, 10+2b ) ! ( 1, -2, -2, 1, 2, -2, 1, -1 ) ! ( 2, 1, 1, 2, 102-a, 102-a, -204+2a, -204+2a ) ! ! trace ( A ) = 4040. ! ! Licensing: ! ! This code is distributed under the MIT license. ! ! Modified: ! ! 27 August 2008 ! ! Author: ! ! John Burkardt ! ! Reference: ! ! Robert Gregory, David Karney, ! A Collection of Matrices for Testing Computational Algorithms, ! Wiley, 1969, ! ISBN: 0882756494, ! LC: QA263.68 ! ! Joan Westlake, ! A Handbook of Numerical Matrix Inversion and Solution of ! Linear Equations, ! John Wiley, 1968, ! ISBN13: 978-0471936756, ! LC: QA263.W47. ! ! Output: ! ! real ( kind = rk ) A(8,8), the matrix. ! implicit none integer, parameter :: rk = kind ( 1.0D+00 ) real ( kind = rk ) a(8,8) ! ! Note that the matrix entries are listed by column. ! real ( kind = rk ), dimension ( 8, 8 ), save :: a_save = reshape ( (/ & 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 & /), (/ 8, 8 /) ) call r8mat_copy ( 8, 8, a_save, a ) return end subroutine rosser1_determinant ( determ ) !*****************************************************************************80 ! !! rosser1_determinant() returns the determinant of the ROSSER1 matrix. ! ! Licensing: ! ! This code is distributed under the MIT license. ! ! Modified: ! ! 10 October 2007 ! ! Author: ! ! John Burkardt ! ! Output: ! ! real ( kind = rk ) DETERM, the determinant. ! implicit none integer, parameter :: rk = kind ( 1.0D+00 ) real ( kind = rk ) determ determ = 0.0D+00 return end subroutine rosser1_eigen_left ( x ) !*****************************************************************************80 ! !! rosser1_eigen_left() returns the left eigenvectors of the ROSSER1 matrix. ! ! Licensing: ! ! This code is distributed under the MIT license. ! ! Modified: ! ! 17 October 2007 ! ! Author: ! ! John Burkardt ! ! Output: ! ! real ( kind = rk ) X(8,8), the matrix. ! implicit none integer, parameter :: rk = kind ( 1.0D+00 ) real ( kind = rk ) x(8,8) real ( kind = rk ), dimension(8,8), save :: x_save = reshape ( (/ & 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 /), (/ 8, 8 /) ) call r8mat_copy ( 8, 8, x_save, x ) call r8mat_transpose_in_place ( 8, x ) return end subroutine rosser1_eigen_right ( x ) !*****************************************************************************80 ! !! rosser1_eigen_right() returns the right eigenvectors of the ROSSER1 matrix. ! ! Licensing: ! ! This code is distributed under the MIT license. ! ! Modified: ! ! 17 October 2007 ! ! Author: ! ! John Burkardt ! ! Output: ! ! real ( kind = rk ) X(8,8), the right eigenvector matrix. ! implicit none integer, parameter :: rk = kind ( 1.0D+00 ) real ( kind = rk ) x(8,8) real ( kind = rk ), dimension(8,8), save :: x_save = reshape ( (/ & 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 /), (/ 8, 8 /) ) call r8mat_copy ( 8, 8, x_save, x ) return end subroutine rosser1_eigenvalues ( lambda ) !*****************************************************************************80 ! !! rosser1_eigenvalues() returns the eigenvalues of the ROSSER1 matrix. ! ! Licensing: ! ! This code is distributed under the MIT license. ! ! Modified: ! ! 13 June 2011 ! ! Author: ! ! John Burkardt ! ! Output: ! ! real ( kind = rk ) LAMBDA(8), the eigenvalues. ! implicit none integer, parameter :: rk = kind ( 1.0D+00 ) real ( kind = rk ) lambda(8) real ( kind = rk ), dimension ( 8 ), save :: 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 ) !*****************************************************************************80 ! !! rosser1_null_left() returns a left null vector of the ROSSER1 matrix. ! ! Licensing: ! ! This code is distributed under the MIT license. ! ! Modified: ! ! 12 March 2015 ! ! Author: ! ! John Burkardt ! ! Output: ! ! real ( kind = rk ) X(8), the null vector. ! implicit none integer, parameter :: rk = kind ( 1.0D+00 ) real ( kind = rk ) x(8) real ( kind = rk ), dimension ( 8 ), save :: 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 ) !*****************************************************************************80 ! !! rosser1_null_right() returns a right null vector of the ROSSER1 matrix. ! ! Licensing: ! ! This code is distributed under the MIT license. ! ! Modified: ! ! 17 October 2007 ! ! Author: ! ! John Burkardt ! ! Output: ! ! real ( kind = rk ) X(8), the null vector. ! implicit none integer, parameter :: rk = kind ( 1.0D+00 ) real ( kind = rk ) x(8) real ( kind = rk ), dimension ( 8 ), save :: 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_matrix ( n, v, a ) !*****************************************************************************80 ! !! routh_matrix() returns the ROUTH matrix. ! ! Formula: ! ! A is tridiagonal. ! A(1,1) = V(1). ! A(I-1,I) = sqrt ( V(I) ), for I = 2 to N. ! A(I,I-1) = - sqrt ( V(I) ), for I = 2 to N. ! ! Example: ! ! N = 5, X = ( 1, 4, 9, 16, 25 ) ! ! 1 -2 0 0 0 ! 2 0 -3 0 0 ! 0 3 0 -4 0 ! 0 0 4 0 -5 ! 0 0 0 5 0 ! ! Properties: ! ! A is generally not symmetric: A' /= A. ! ! A is tridiagonal. ! ! Because A is tridiagonal, it has property A (bipartite). ! ! A is banded, with bandwidth 3. ! ! A is integral, therefore det ( A ) is integral, and ! det ( A ) * inverse ( A ) is integral. ! ! det ( A ) = product ( V(N) * V(N-2) * V(N-4) * ... * V(N+1-2*(N/2)) ) ! ! The family of matrices is nested as a function of N. ! ! Licensing: ! ! This code is distributed under the MIT license. ! ! Modified: ! ! 04 March 2001 ! ! Author: ! ! John Burkardt ! ! Input: ! ! integer N, the order of the matrix. ! ! real ( kind = rk ) V(N), the data that defines the matrix. ! ! Output: ! ! real ( kind = rk ) A(N,N), the matrix. ! implicit none integer, parameter :: rk = kind ( 1.0D+00 ) integer n real ( kind = rk ) a(n,n) integer i integer j real ( kind = rk ) v(n) do i = 1, n do j = 1, n if ( i == 1 .and. j == 1 ) then a(i,j) = abs ( v(1) ) else if ( i == j + 1 ) then a(i,j) = sqrt ( abs ( v(i) ) ) else if ( i == j - 1 ) then a(i,j) = - sqrt ( abs ( v(i+1) ) ) else a(i,j) = 0.0D+00 end if end do end do return end subroutine routh_determinant ( n, v, determ ) !*****************************************************************************80 ! !! routh_determinant() returns the determinant of the ROUTH matrix. ! ! Licensing: ! ! This code is distributed under the MIT license. ! ! Modified: ! ! 24 May 2002 ! ! Author: ! ! John Burkardt ! ! Input: ! ! integer N, the order of the matrix. ! ! real ( kind = rk ) V(N), the data that defines the matrix. ! ! Output: ! ! real ( kind = rk ) DETERM, the determinant. ! implicit none integer, parameter :: rk = kind ( 1.0D+00 ) integer n real ( kind = rk ) determ real ( kind = rk ) v(n) determ = product ( v(n:1:-2) ) return end subroutine rowcolsum_matrix ( row_num, col_num, m, n, a ) !*****************************************************************************80 ! !! rowcolsum_matrix() returns the ROWCOLSUM matrix. ! ! Discussion: ! ! The row and column sum matrix is the linear operator which returns ! the sums of the rows and columns of a rectangular data array. ! ! For instance, if the data array has 2 rows and 3 columns, ! with the values: ! ! 1 2 3 ! 4 5 6 ! ! then the row sums are (6,15) and the column sums are (5,7,9), and ! the matrix, data, and row/column sums can be put in the form: ! ! 1 1 1 0 0 0 1 6 ! 0 0 0 1 1 1 2 15 ! 1 0 0 1 0 0 * 3 = 5 ! 0 1 0 0 1 0 4 7 ! 0 0 1 0 0 1 5 9 ! 6 ! ! Here, we have linearly arranged the data array to constitute an ! element X of an N = ROW_NUM * COL_NUM space, and the row and column sum ! vectors now form a right hand side vector B which is an element of ! M = ROW_NUM + COL_NUM space. ! ! The M by N matrix A has an interesting structure and properties. In ! particular, its row rank, rank, range, null space, eigenvalues and ! eigenvectors are worth knowing. In some cases, these abstract properties ! have an interesting explanation or interpretation when looked at ! in terms of the data array and its row and column sums. ! ! (Determining something about a matrix from its row and column sums ! comes up in computer tomography. A sort of generalized problem of ! determining the contents of the cells in a rectangular array based on ! row and column summary information is presented as a game called ! "Paint by Numbers" or "Descartes's Enigma". The interpretation of ! tables of data representing the abundance of different species in ! different habitats is of some interest in biology, and requires the ! ability to generate random matrices with 0 or 1 data entries and ! given row and column sum vectors.) ! ! Row Rank: ! ! It is clear that most values of ROW_NUM and COL_NUM, the matrix ! maps a very large space into a small one, and hence must be ! chock full of singularity. We may still wonder if the matrix ! has as much nonsingularity as possible. Except for the 1 by 1 case, ! it doesn't. ! ! The fact that the sum of the first ROW_NUM rows of the ! matrix equals the sum of the last COL_NUM rows of the matrix means ! that the matrix has row rank no more than M-1. Assuming that 1 < M, ! then this means we have less than full row rank, and hence there is ! a corresponding null vector. ! ! (But this loss of full row rank HAD to happen: the fact that ! the sum of the row sums equals the sum of the column sums means ! that the "B" objects that A creates are constrained. Hence A does ! not have full range in the image space, and hence there ! must be some additional loss of rank beyond the requirements imposed ! simply by the number of rows in the matrix!) ! ! To determine this null vector, note that: ! ! * if either ROW_NUM or COL_NUM is even, then a corresponding null ! vector is the checkerboard vector which is +1 on "red" data cells ! and -1 on "black" ones. ! ! * If ROW_NUM and COL_NUM are both odd and greater than 1, then ! put -1 in each corner, +4 in the center and zeros elsewhere. ! ! * If ROW_NUM and COL_NUM are both odd, and exactly one of them is 1, ! then the data array is a single row or column containing an odd number ! of cells greater than 1. Put a -1 in the first and last, and put ! +2 in the center cell. The other cells can be set to zero. ! ! * If ROW_NUM and COL_NUM are both odd, and both are in fact 1, then ! we already pointed out that the matrix has full row rank and there ! is no corresponding null vector. ! ! We can deduce that the row rank of A is exactly M-1 (when 1 < M ) ! by noting that if we placed the column summing rows first, ! and then listed the row summing rows, except that we replaced the ! first row summing row by a zero row, and moved that to the end, ! then A is in REDUCED ROW ECHELON FORM and hence must have row rank ! at least M-1, since there is a leading one in each row. ! ! Rank: ! ! This in turn means that (for 1 < M ) the rank of A is also M-1. ! ! Range: ! ! We have noted that, by construction, a vector B can be an image ! of some data vector X only if the sum of the row sum entries equals ! the sum of the column sum entries. In fact, we can regard this ! as defining the range of A, which is the linear subspace of ! M-space in which the sum of the first ROW_NUM entries equals the ! sum of the final COL_NUM entries. ! ! Licensing: ! ! This code is distributed under the MIT license. ! ! Modified: ! ! 05 July 2000 ! ! Author: ! ! John Burkardt ! ! Input: ! ! integer ROW_NUM, COL_NUM, the number of rows and ! columns in the data array associated with the row and column sum matrix. ! ! Output: ! ! integer M, the number of rows of A, which is ! ROW_NUM + COL_NUM. ! ! integer N, the number of columns of A, which is ! ROW_NUM * COL_NUM. ! ! real ( kind = rk ) A(ROW_NUM+COL_NUM,ROW_NUM * COL_NUM), the ! row and column sum matrix. ! implicit none integer, parameter :: rk = kind ( 1.0D+00 ) integer col_num integer row_num real ( kind = rk ) a(row_num+col_num,row_num*col_num) integer col integer jhi integer jlo integer m integer n integer row m = row_num + col_num n = row_num * col_num a(1:m,1:n) = 0.0D+00 ! ! Set the matrix rows that compute a row sum. ! do row = 1, row_num jlo = ( row - 1 ) * col_num + 1 jhi = row * col_num a(row,jlo:jhi) = 1.0D+00 end do ! ! Set the matrix rows that compute a column sum. ! do col = 1, col_num jlo = col jhi = ( row_num - 1 ) * col_num + col a(col+row_num,jlo:jhi:col_num) = 1.0D+00 end do return end subroutine rutis1_matrix ( a ) !*****************************************************************************80 ! !! rutis1_matrix() returns the RUTIS1 matrix. ! ! Example: ! ! 6 4 4 1 ! 4 6 1 4 ! 4 1 6 4 ! 1 4 4 6 ! ! Properties: ! ! A is symmetric: A' = A. ! ! A is integral, therefore det ( A ) is integral, and ! det ( A ) * inverse ( A ) is integral. ! ! A has constant row sums. ! ! Because it has a constant row sum of 15, ! A has an eigenvalue of 15, and ! a right eigenvector of ( 1, 1, 1, 1 ). ! ! A has constant column sums. ! ! Because it has a constant column sum of 15, ! A has an eigenvalue of 15, and ! a left eigenvector of ( 1, 1, 1, ..., 1 ). ! ! A has a repeated eigenvalue. ! ! Licensing: ! ! This code is distributed under the MIT license. ! ! Modified: ! ! 23 May 2002 ! ! Author: ! ! John Burkardt ! ! Reference: ! ! Joan Westlake, ! A Handbook of Numerical Matrix Inversion and Solution of ! Linear Equations, ! John Wiley, 1968, ! ISBN13: 978-0471936756, ! LC: QA263.W47. ! ! Output: ! ! real ( kind = rk ) A(4,4), the matrix. ! implicit none integer, parameter :: rk = kind ( 1.0D+00 ) real ( kind = rk ) a(4,4) ! ! Note that the matrix entries are listed by column. ! real ( kind = rk ), dimension ( 4, 4 ), save :: a_save = reshape ( (/ & 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 & /), (/ 4, 4 /) ) call r8mat_copy ( 4, 4, a_save, a ) return end subroutine rutis1_condition ( cond ) !*****************************************************************************80 ! !! rutis1_condition() returns the L1 condition of the RUTIS1 matrix. ! ! Licensing: ! ! This code is distributed under the MIT license. ! ! Modified: ! ! 21 January 2015 ! ! Author: ! ! John Burkardt ! ! Output: ! ! real ( kind = rk ) COND, the L1 condition. ! implicit none integer, parameter :: rk = kind ( 1.0D+00 ) real ( kind = rk ) a_norm real ( kind = rk ) b_norm real ( kind = rk ) cond a_norm = 15.0D+00 b_norm = 1.0D+00 cond = a_norm * b_norm return end subroutine rutis1_determinant ( determ ) !*****************************************************************************80 ! !! rutis1_determinant() returns the determinant of the RUTIS1 matrix. ! ! Licensing: ! ! This code is distributed under the MIT license. ! ! Modified: ! ! 13 October 2007 ! ! Author: ! ! John Burkardt ! ! Output: ! ! real ( kind = rk ) DETERM, the determinant. ! implicit none integer, parameter :: rk = kind ( 1.0D+00 ) real ( kind = rk ) determ determ = - 375.0D+00 return end subroutine rutis1_eigen_right ( a ) !*****************************************************************************80 ! !! rutis1_eigen_right() returns the right eigenvectors of the RUTIS1 matrix. ! ! Licensing: ! ! This code is distributed under the MIT license. ! ! Modified: ! ! 17 June 2011 ! ! Author: ! ! John Burkardt ! ! Output: ! ! real ( kind = rk ) A(4,4), the right eigenvector matrix. ! implicit none integer, parameter :: rk = kind ( 1.0D+00 ) real ( kind = rk ) a(4,4) ! ! Note that the matrix entries are listed by column. ! real ( kind = rk ), dimension ( 4, 4 ), save :: a_save = reshape ( (/ & 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 & /), (/ 4, 4 /) ) call r8mat_copy ( 4, 4, a_save, a ) return end subroutine rutis1_eigenvalues ( lambda ) !*****************************************************************************80 ! !! rutis1_eigenvalues() returns the eigenvalues of the RUTIS1 matrix. ! ! Licensing: ! ! This code is distributed under the MIT license. ! ! Modified: ! ! 16 June 2011 ! ! Author: ! ! John Burkardt ! ! Output: ! ! real ( kind = rk ) LAMBDA(4), the eigenvalues. ! implicit none integer, parameter :: rk = kind ( 1.0D+00 ) real ( kind = rk ) lambda(4) real ( kind = rk ), dimension ( 4 ), save :: 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 ) !*****************************************************************************80 ! !! rutis1_inverse() returns the inverse of the RUTIS1 matrix. ! ! Licensing: ! ! This code is distributed under the MIT license. ! ! Modified: ! ! 13 October 2007 ! ! Author: ! ! John Burkardt ! ! Reference: ! ! Joan Westlake, ! A Handbook of Numerical Matrix Inversion and Solution of ! Linear Equations, ! John Wiley, 1968, ! ISBN13: 978-0471936756, ! LC: QA263.W47. ! ! Output: ! ! real ( kind = rk ) A(4,4), the matrix. ! implicit none integer, parameter :: rk = kind ( 1.0D+00 ) real ( kind = rk ) a(4,4) a(1:4,1:4) = reshape ( (/ & -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 & /), (/ 4, 4 /) ) a(1:4,1:4) = a(1:4,1:4) / 15.0D+00 return end subroutine rutis2_matrix ( a ) !*****************************************************************************80 ! !! rutis2_matrix() returns the RUTIS2 matrix. ! ! Example: ! ! 5 4 1 1 ! 4 5 1 1 ! 1 1 4 2 ! 1 1 2 4 ! ! Properties: ! ! A is symmetric: A' = A. ! ! A is integral, therefore det ( A ) is integral, and ! det ( A ) * inverse ( A ) is integral. ! ! A has distinct eigenvalues. ! ! Licensing: ! ! This code is distributed under the MIT license. ! ! Modified: ! ! 17 June 2011 ! ! Author: ! ! John Burkardt ! ! Reference: ! ! Joan Westlake, ! A Handbook of Numerical Matrix Inversion and Solution of ! Linear Equations, ! John Wiley, 1968, ! ISBN13: 978-0471936756, ! LC: QA263.W47. ! ! Output: ! ! real ( kind = rk ) A(4,4), the matrix. ! implicit none integer, parameter :: rk = kind ( 1.0D+00 ) real ( kind = rk ) a(4,4) ! ! Note that the matrix entries are listed by column. ! real ( kind = rk ), dimension ( 4, 4 ), save :: a_save = reshape ( (/ & 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 & /), (/ 4, 4 /) ) call r8mat_copy ( 4, 4, a_save, a ) return end subroutine rutis2_condition ( cond ) !*****************************************************************************80 ! !! rutis2_condition() returns the L1 condition of the RUTIS2 matrix. ! ! Licensing: ! ! This code is distributed under the MIT license. ! ! Modified: ! ! 26 January 2015 ! ! Author: ! ! John Burkardt ! ! Output: ! ! real ( kind = rk ) COND, the L1 condition. ! implicit none integer, parameter :: rk = kind ( 1.0D+00 ) real ( kind = rk ) a_norm real ( kind = rk ) b_norm real ( kind = rk ) cond a_norm = 11.0D+00 b_norm = 1.04D+00 cond = a_norm * b_norm return end subroutine rutis2_determinant ( determ ) !*****************************************************************************80 ! !! rutis2_determinant() returns the determinant of the RUTIS2 matrix. ! ! Licensing: ! ! This code is distributed under the MIT license. ! ! Modified: ! ! 13 October 2007 ! ! Author: ! ! John Burkardt ! ! Output: ! ! real ( kind = rk ) DETERM, the determinant. ! implicit none integer, parameter :: rk = kind ( 1.0D+00 ) real ( kind = rk ) determ determ = 100.0D+00 return end subroutine rutis2_eigen_right ( a ) !*****************************************************************************80 ! !! rutis2_eigen_right() returns the right eigenvectors of the RUTIS2 matrix. ! ! Licensing: ! ! This code is distributed under the MIT license. ! ! Modified: ! ! 23 May 2002 ! ! Author: ! ! John Burkardt ! ! Output: ! ! real ( kind = rk ) A(4,4), the right eigenvector matrix. ! implicit none integer, parameter :: rk = kind ( 1.0D+00 ) real ( kind = rk ) a(4,4) ! ! Note that the matrix entries are listed by column. ! real ( kind = rk ), dimension ( 4, 4 ), save :: a_save = reshape ( (/ & 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 & /), (/ 4, 4 /) ) call r8mat_copy ( 4, 4, a_save, a ) return end subroutine rutis2_eigenvalues ( lambda ) !*****************************************************************************80 ! !! rutis2_eigenvalues() returns the eigenvalues of the RUTIS2 matrix. ! ! Licensing: ! ! This code is distributed under the MIT license. ! ! Modified: ! ! 23 May 2002 ! ! Author: ! ! John Burkardt ! ! Output: ! ! real ( kind = rk ) LAMBDA(4), the eigenvalues. ! implicit none integer, parameter :: rk = kind ( 1.0D+00 ) real ( kind = rk ) lambda(4) real ( kind = rk ), dimension ( 4 ), save :: 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 ) !*****************************************************************************80 ! !! rutis2_inverse() returns the inverse of the RUTIS2 matrix. ! ! Example: ! ! 0.5600 -0.4400 -0.0200 -0.0200 ! -0.4400 0.5600 -0.0200 -0.0200 ! -0.0200 -0.0200 0.3400 -0.1600 ! -0.0200 -0.0200 -0.1600 0.3400 ! ! Licensing: ! ! This code is distributed under the MIT license. ! ! Modified: ! ! 29 July 2008 ! ! Author: ! ! John Burkardt ! ! Reference: ! ! Joan Westlake, ! A Handbook of Numerical Matrix Inversion and Solution of ! Linear Equations, ! John Wiley, 1968, ! ISBN13: 978-0471936756, ! LC: QA263.W47. ! ! Output: ! ! real ( kind = rk ) A(4,4), the matrix. ! implicit none integer, parameter :: rk = kind ( 1.0D+00 ) real ( kind = rk ) a(4,4) ! ! Note that the matrix entries are listed by column. ! real ( kind = rk ), dimension ( 4, 4 ), save :: a_save = reshape ( (/ & 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 & /), (/ 4, 4 /) ) call r8mat_copy ( 4, 4, a_save, a ) return end subroutine rutis3_matrix ( a ) !*****************************************************************************80 ! !! rutis3_matrix() returns the RUTIS3 matrix. ! ! Example: ! ! 4 -5 0 3 ! 0 4 -3 -5 ! 5 -3 4 0 ! 3 0 5 4 ! ! Properties: ! ! A is not symmetric: A' /= A. ! ! A is integral, therefore det ( A ) is integral, and ! det ( A ) * inverse ( A ) is integral. ! ! A has distinct eigenvalues. ! ! A has a pair of complex eigenvalues. ! ! Licensing: ! ! This code is distributed under the MIT license. ! ! Modified: ! ! 23 May 2002 ! ! Author: ! ! John Burkardt ! ! Reference: ! ! Joan Westlake, ! A Handbook of Numerical Matrix Inversion and Solution of ! Linear Equations, ! John Wiley, 1968, ! ISBN13: 978-0471936756, ! LC: QA263.W47. ! ! Output: ! ! real ( kind = rk ) A(4,4), the matrix. ! implicit none integer, parameter :: rk = kind ( 1.0D+00 ) real ( kind = rk ) a(4,4) ! ! Note that the matrix entries are listed by column. ! real ( kind = rk ), dimension ( 4, 4 ), save :: a_save = reshape ( (/ & 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 & /), (/ 4, 4 /) ) call r8mat_copy ( 4, 4, a_save, a ) return end subroutine rutis3_condition ( cond ) !*****************************************************************************80 ! !! rutis3_condition() returns the L1 condition of the RUTIS3 matrix. ! ! Licensing: ! ! This code is distributed under the MIT license. ! ! Modified: ! ! 26 January 2015 ! ! Author: ! ! John Burkardt ! ! Output: ! ! real ( kind = rk ) COND, the L1 condition. ! implicit none integer, parameter :: rk = kind ( 1.0D+00 ) real ( kind = rk ) a_norm real ( kind = rk ) b_norm real ( kind = rk ) cond a_norm = 12.0D+00 b_norm = 0.5D+00 cond = a_norm * b_norm return end subroutine rutis3_determinant ( determ ) !*****************************************************************************80 ! !! rutis3_determinant() returns the determinant of the RUTIS3 matrix. ! ! Licensing: ! ! This code is distributed under the MIT license. ! ! Modified: ! ! 13 October 2007 ! ! Author: ! ! John Burkardt ! ! Output: ! ! real ( kind = rk ) DETERM, the determinant. ! implicit none integer, parameter :: rk = kind ( 1.0D+00 ) real ( kind = rk ) determ determ = 624.0D+00 return end subroutine rutis3_eigen_left ( a ) !*****************************************************************************80 ! !! rutis3_eigen_left() returns the left eigenvectors of the RUTIS3 matrix. ! ! Licensing: ! ! This code is distributed under the MIT license. ! ! Modified: ! ! 23 May 2002 ! ! Author: ! ! John Burkardt ! ! Output: ! ! complex ( kind = ck ) A(4,4), the left eigenvector matrix. ! implicit none integer, parameter :: rk = kind ( 1.0D+00 ) integer, parameter :: ck = kind ( ( 1.0D+00, 1.0D+00 ) ) complex ( kind = ck ) a(4,4) a(1:4,1:4) = reshape ( (/ & cmplx ( 1.0D+00, 0.0D+00, kind = ck ), & cmplx ( 1.0D+00, 0.0D+00, kind = ck ), & cmplx ( 1.0D+00, 0.0D+00, kind = ck ), & cmplx ( 1.0D+00, 0.0D+00, kind = ck ), & cmplx ( -1.0D+00, 0.0D+00, kind = ck ), & cmplx ( 1.0D+00, 0.0D+00, kind = ck ), & cmplx ( 0.0D+00, 1.0D+00, kind = ck ), & cmplx ( 0.0D+00, -1.0D+00, kind = ck ), & cmplx ( 1.0D+00, 0.0D+00, kind = ck ), & cmplx ( -1.0D+00, 0.0D+00, kind = ck ), & cmplx ( 0.0D+00, 1.0D+00, kind = ck ), & cmplx ( 0.0D+00, -1.0D+00, kind = ck ), & cmplx ( 1.0D+00, 0.0D+00, kind = ck ), & cmplx ( 1.0D+00, 0.0D+00, kind = ck ), & cmplx ( -1.0D+00, 0.0D+00, kind = ck ), & cmplx ( -1.0D+00, 0.0D+00, kind = ck ) & /), (/ 4, 4 /) ) return end subroutine rutis3_eigen_right ( a ) !*****************************************************************************80 ! !! rutis3_eigen_right() returns the right eigenvectors of the RUTIS3 matrix. ! ! Licensing: ! ! This code is distributed under the MIT license. ! Modified: ! ! 23 May 2002 ! ! Author: ! ! John Burkardt ! ! Output: ! ! complex ( kind = ck ) A(4,4), the right eigenvector matrix. ! implicit none integer, parameter :: rk = kind ( 1.0D+00 ) integer, parameter :: ck = kind ( ( 1.0D+00, 1.0D+00 ) ) complex ( kind = ck ) a(4,4) a(1:4,1:4) = reshape ( (/ & cmplx ( 1.0D+00, 0.0D+00, kind = ck ), & cmplx ( -1.0D+00, 0.0D+00, kind = ck ), & cmplx ( 1.0D+00, 0.0D+00, kind = ck ), & cmplx ( 1.0D+00, 0.0D+00, kind = ck ), & cmplx ( 1.0D+00, 0.0D+00, kind = ck ), & cmplx ( 0.0D+00, -1.0D+00, kind = ck ), & cmplx ( 0.0D+00, -1.0D+00, kind = ck ), & cmplx ( -1.0D+00, 0.0D+00, kind = ck ), & cmplx ( 1.0D+00, 0.0D+00, kind = ck ), & cmplx ( 0.0D+00, 1.0D+00, kind = ck ), & cmplx ( 0.0D+00, 1.0D+00, kind = ck ), & cmplx ( -1.0D+00, 0.0D+00, kind = ck ), & cmplx ( 1.0D+00, 0.0D+00, kind = ck ), & cmplx ( 1.0D+00, 0.0D+00, kind = ck ), & cmplx ( -1.0D+00, 0.0D+00, kind = ck ), & cmplx ( 1.0D+00, 0.0D+00, kind = ck ) & /), (/ 4, 4 /) ) return end subroutine rutis3_eigenvalues ( lambda ) !*****************************************************************************80 ! !! rutis3_eigenvalues() returns the eigenvalues of the RUTIS3 matrix. ! ! Licensing: ! ! This code is distributed under the MIT license. ! ! Modified: ! ! 23 May 2002 ! ! Author: ! ! John Burkardt ! ! Output: ! ! complex ( kind = ck ) LAMBDA(4), the eigenvalues. ! implicit none integer, parameter :: rk = kind ( 1.0D+00 ) integer, parameter :: ck = kind ( ( 1.0D+00, 1.0D+00 ) ) complex ( kind = ck ) lambda(4) lambda(1:4) = (/ & cmplx ( 12.0D+00, 0.0D+00, kind = ck ), & cmplx ( 1.0D+00, 5.0D+00, kind = ck ), & cmplx ( 1.0D+00, -5.0D+00, kind = ck ), & cmplx ( 2.0D+00, 0.0D+00, kind = ck ) /) return end subroutine rutis3_inverse ( a ) !*****************************************************************************80 ! !! rutis3_inverse() returns the inverse of the RUTIS3 matrix. ! ! Licensing: ! ! This code is distributed under the MIT license. ! ! Modified: ! ! 13 October 2007 ! ! Author: ! ! John Burkardt ! ! Reference: ! ! Joan Westlake, ! A Handbook of Numerical Matrix Inversion and Solution of ! Linear Equations, ! John Wiley, 1968, ! ISBN13: 978-0471936756, ! LC: QA263.W47. ! ! Output: ! ! real ( kind = rk ) A(4,4), the matrix. ! implicit none integer, parameter :: rk = kind ( 1.0D+00 ) real ( kind = rk ) a(4,4) a(1:4,1:4) = reshape ( (/ & 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 & /), (/ 4, 4 /) ) a(1:4,1:4) = transpose ( a(1:4,1:4) ) / 624.0D+00 return end subroutine rutis4_matrix ( n, a ) !*****************************************************************************80 ! !! rutis4_matrix() returns the RUTIS4 matrix. ! ! Example: ! ! N = 6 ! ! 14 14 6 1 0 0 ! 14 20 15 6 1 0 ! 6 15 20 15 6 1 ! 1 6 15 20 15 6 ! 0 1 6 15 20 14 ! 0 0 1 6 14 14 ! ! Properties: ! ! A is symmetric: A' = A. ! ! A is integral, therefore det ( A ) is integral, and ! det ( A ) * inverse ( A ) is integral. ! ! A is banded with a bandwidth of 7. ! ! A is persymmetric: A(I,J) = A(N+1-J,N+1-I). ! ! A is the cube of the scalar tridiagonal matrix whose diagonals ! are ( 1, 2, 1 ). ! ! LAMBDA(I) = 64 * ( cos ( i * pi / ( 2 * ( n + 1 ) ) ) )^6 ! ! Licensing: ! ! This code is distributed under the MIT license. ! ! Modified: ! ! 23 May 2002 ! ! Author: ! ! John Burkardt ! ! Reference: ! ! Joan Westlake, ! A Handbook of Numerical Matrix Inversion and Solution of ! Linear Equations, ! John Wiley, 1968, ! ISBN13: 978-0471936756, ! LC: QA263.W47. ! ! Input: ! ! integer N, the order of the matrix. ! ! Output: ! ! real ( kind = rk ) A(N,N), the matrix. ! implicit none integer, parameter :: rk = kind ( 1.0D+00 ) integer n real ( kind = rk ) a(n,n) integer i a(1:n,1:n) = 0.0D+00 do i = 1, n if ( 1 <= i - 3 ) then a(i,i-3) = 1.0D+00 end if if ( 1 <= i - 2 ) then a(i,i-2) = 6.0D+00 end if if ( 1 <= i - 1 ) then a(i,i-1) = 15.0D+00 end if a(i,i) = 20.0D+00 if ( i + 1 <= n ) then a(i,i+1) = 15.0D+00 end if if ( i + 2 <= n ) then a(i,i+2) = 6.0D+00 end if if ( i + 3 <= 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_condition ( n, cond ) !*****************************************************************************80 ! !! rutis4_condition() returns the L1 condition of the RUTIS4 matrix. ! ! Licensing: ! ! This code is distributed under the MIT license. ! ! Modified: ! ! 31 October 2021 ! ! Author: ! ! John Burkardt ! ! Output: ! ! real ( kind = rk ) COND, the L1 condition. ! implicit none integer, parameter :: rk = kind ( 1.0D+00 ) integer n real ( kind = rk ) A(n,n) real ( kind = rk ) a_norm real ( kind = rk ) B(n,n) real ( kind = rk ) b_norm real ( kind = rk ) cond real ( kind = rk ) r8mat_norm_l1 call rutis4_matrix ( n, A ) a_norm = r8mat_norm_l1 ( n, n, A ) call rutis4_inverse ( n, B ) b_norm = r8mat_norm_l1 ( n, n, B ) cond = a_norm * b_norm return end subroutine rutis4_determinant ( n, determ ) !*****************************************************************************80 ! !! rutis4_determinant() returns the determinant of the RUTIS4 matrix. ! ! Licensing: ! ! This code is distributed under the MIT license. ! ! Modified: ! ! 15 October 2007 ! ! Author: ! ! John Burkardt ! ! Input: ! ! integer N, the order of the matrix. ! ! Output: ! ! real ( kind = rk ) DETERM, the determinant. ! implicit none integer, parameter :: rk = kind ( 1.0D+00 ) integer n real ( kind = rk ) angle real ( kind = rk ) determ integer i real ( kind = rk ), parameter :: r8_pi = 3.141592653589793D+00 determ = 1.0D+00 do i = 1, n angle = real ( i, kind = rk ) * r8_pi / real ( 2 * ( n + 1 ), kind = rk ) determ = determ * 64.0D+00 * ( cos ( angle ) ) ** 6 end do return end subroutine rutis4_eigenvalues ( n, lambda ) !*****************************************************************************80 ! !! rutis4_eigenvalues() returns the eigenvalues of the RUTIS4 matrix. ! ! Licensing: ! ! This code is distributed under the MIT license. ! ! Modified: ! ! 24 May 2002 ! ! Author: ! ! John Burkardt ! ! Input: ! ! integer N, the order of the matrix. ! ! Output: ! ! real ( kind = rk ) LAMBDA(N), the eigenvalues. ! implicit none integer, parameter :: rk = kind ( 1.0D+00 ) integer n real ( kind = rk ) angle integer i real ( kind = rk ) lambda(n) real ( kind = rk ), parameter :: r8_pi = 3.141592653589793D+00 do i = 1, n angle = real ( i, kind = rk ) * r8_pi / real ( 2 * ( n + 1 ), kind = rk ) lambda(i) = 64.0D+00 * ( cos ( angle ) ) ** 6 end do return end subroutine rutis4_inverse ( n, a ) !*****************************************************************************80 ! !! rutis4_inverse() returns the inverse of the RUTIS4 matrix. ! ! Licensing: ! ! This code is distributed under the MIT license. ! ! Modified: ! ! 05 November 2007 ! ! Author: ! ! John Burkardt ! ! Input: ! ! integer N, the order of the matrix. ! ! Output: ! ! real ( kind = rk ) A(N,N), the matrix. ! implicit none integer, parameter :: rk = kind ( 1.0D+00 ) integer n real ( kind = rk ) a(n,n) call oto_inverse ( n, a ) a(1:n,1:n) = matmul ( a(1:n,1:n), matmul ( a(1:n,1:n), a(1:n,1:n) ) ) return end subroutine rutis5_matrix ( a ) !*****************************************************************************80 ! !! rutis5_matrix() returns the RUTIS5 matrix. ! ! Example: ! ! 10 1 4 0 ! 1 10 5 -1 ! 4 5 10 7 ! 0 -1 7 9 ! ! Properties: ! ! A is symmetric: A' = A. ! ! A is integral, therefore det ( A ) is integral, and ! det ( A ) * inverse ( A ) is integral. ! ! Licensing: ! ! This code is distributed under the MIT license. ! ! Modified: ! ! 27 May 2002 ! ! Author: ! ! John Burkardt ! ! Reference: ! ! John Todd, ! Basic Numerical Mathematics, ! Volume 2: Numerical Algebra, ! Birkhauser, 1980, ! ISBN: 0817608117, ! LC: QA297.T58. ! ! Output: ! ! real ( kind = rk ) A(4,4), the matrix. ! implicit none integer, parameter :: rk = kind ( 1.0D+00 ) real ( kind = rk ) a(4,4) ! ! Note that the matrix entries are listed by column. ! real ( kind = rk ), dimension ( 4, 4 ), save :: a_save = reshape ( (/ & 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 & /), (/ 4, 4 /) ) call r8mat_copy ( 4, 4, a_save, a ) return end subroutine rutis5_condition ( cond ) !*****************************************************************************80 ! !! rutis5_condition() returns the L1 condition of the RUTIS5 matrix. ! ! Licensing: ! ! This code is distributed under the MIT license. ! ! Modified: ! ! 08 April 2012 ! ! Author: ! ! John Burkardt ! ! Output: ! ! real ( kind = rk ) COND, the L1 condition. ! implicit none integer, parameter :: rk = kind ( 1.0D+00 ) real ( kind = rk ) cond cond = 62608.0D+00 return end subroutine rutis5_determinant ( determ ) !*****************************************************************************80 ! !! rutis5_determinant() returns the determinant of the RUTIS5 matrix. ! ! Licensing: ! ! This code is distributed under the MIT license. ! ! Modified: ! ! 13 October 2007 ! ! Author: ! ! John Burkardt ! ! Output: ! ! real ( kind = rk ) DETERM, the determinant. ! implicit none integer, parameter :: rk = kind ( 1.0D+00 ) real ( kind = rk ) determ determ = 1.0D+00 return end subroutine rutis5_eigen_right ( a ) !*****************************************************************************80 ! !! rutis5_eigen_right() returns the right eigenvectors of the RUTIS5 matrix. ! ! Licensing: ! ! This code is distributed under the MIT license. ! ! Modified: ! ! 14 June 2011 ! ! Author: ! ! John Burkardt ! ! Output: ! ! real ( kind = rk ) A(4,4), the right eigenvector matrix. ! implicit none integer, parameter :: rk = kind ( 1.0D+00 ) real ( kind = rk ) a(4,4) ! ! Note that the matrix entries are listed by column. ! real ( kind = rk ), dimension ( 4, 4 ), save :: a_save = reshape ( (/ & 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 /), (/ 4, 4 /) ) call r8mat_copy ( 4, 4, a_save, a ) return end subroutine rutis5_eigenvalues ( lambda ) !*****************************************************************************80 ! !! rutis5_eigenvalues() returns the eigenvalues of the RUTIS5 matrix. ! ! Licensing: ! ! This code is distributed under the MIT license. ! ! Modified: ! ! 27 May 2002 ! ! Author: ! ! John Burkardt ! ! Output: ! ! real ( kind = rk ) LAMBDA(4), the eigenvalues. ! implicit none integer, parameter :: rk = kind ( 1.0D+00 ) real ( kind = rk ) lambda(4) real ( kind = rk ), dimension ( 4 ), save :: 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 ) !*****************************************************************************80 ! !! rutis5_inverse() returns the inverse of the RUTIS5 matrix. ! ! Example: ! ! 105 167 -304 255 ! 167 266 -484 406 ! -304 -484 881 -739 ! 255 406 -739 620 ! ! Licensing: ! ! This code is distributed under the MIT license. ! ! Modified: ! ! 27 May 2002 ! ! Author: ! ! John Burkardt ! ! Reference: ! ! John Todd, ! Basic Numerical Mathematics, ! Volume 2: Numerical Algebra, ! Birkhauser, 1980, ! ISBN: 0817608117, ! LC: QA297.T58. ! ! Output: ! ! real ( kind = rk ) A(4,4), the matrix. ! implicit none integer, parameter :: rk = kind ( 1.0D+00 ) real ( kind = rk ) a(4,4) ! ! Note that the matrix entries are listed by column. ! real ( kind = rk ), dimension ( 4, 4 ), save :: a_save = reshape ( (/ & 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 & /), (/ 4, 4 /) ) call r8mat_copy ( 4, 4, a_save, a ) return end subroutine schur_block_matrix ( n, x, y, a ) !*****************************************************************************80 ! !! schur_block_matrix() returns the schur_block matrix. ! ! Formula: ! ! if ( i == j ) ! a(i,j) = x( (i+1)/2 ) ! else if ( mod ( i, 2 ) == 1 .and. j == i + 1 ) ! a(i,j) = y( (i+1)/2 ) ! else if ( mod ( i, 2 ) == 0 .and. j == i - 1 ) ! a(i,j) = -y( (i+1)/2 ) ! else ! a(i,j) = 0.0D+00 ! ! Example: ! ! N = 5, X = ( 1, 2, 3 ), Y = ( 4, 5 ) ! ! 1 4 0 0 0 ! -4 1 0 0 0 ! 0 0 2 5 0 ! 0 0 -5 2 0 ! 0 0 0 0 3 ! ! Properties: ! ! A is generally not symmetric: A' /= A. ! ! A is block diagonal, with the blocks being 2 by 2 or 1 by 1 in size. ! ! A is in real Schur form. ! ! The eigenvalues of A are X(I) +/- sqrt ( - 1 ) * Y(I) ! ! A is tridiagonal. ! ! A is banded, with bandwidth 3. ! ! Licensing: ! ! This code is distributed under the MIT license. ! ! Modified: ! ! 15 April 1999 ! ! Author: ! ! John Burkardt ! ! Reference: ! ! Francoise Chatelin, ! Section 4.2.7, ! Eigenvalues of Matrices, ! John Wiley, 1993. ! ! Francoise Chatelin, Valerie Fraysse, ! Qualitative computing: Elements of a theory for finite precision ! computation, Lecture notes, ! CERFACS, Toulouse, France and THOMSON-CSF, Orsay, France, June 1993. ! ! Input: ! ! integer N, the order of the matrix. ! ! real ( kind = rk ) X( (N+1)/2 ), specifies the diagonal elements ! of A. ! ! real ( kind = rk ) Y( N/2 ), specifies the off-diagonal elements ! of the Schur blocks. ! ! Output: ! ! real ( kind = rk ) A(N,N), the matrix. ! implicit none integer, parameter :: rk = kind ( 1.0D+00 ) integer n real ( kind = rk ) a(n,n) integer i integer j real ( kind = rk ) x((n+1)/2) real ( kind = rk ) y(n/2) a(1:n,1:n) = 0.0D+00 do j = 1, n do i = 1, n if ( i == j ) then a(i,j) = x( (i+1)/2 ) else if ( mod ( i, 2 ) == 1 .and. j == i + 1 ) then a(i,j) = y( (i+1)/2 ) else if ( mod ( i, 2 ) == 0 .and. j == 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 ) !*****************************************************************************80 ! !! schur_block_determinant() returns the determinant of the schur_block matrix. ! ! Licensing: ! ! This code is distributed under the MIT license. ! ! Modified: ! ! 20 October 2007 ! ! Author: ! ! John Burkardt ! ! Input: ! ! integer N, the order of the matrix. ! ! real ( kind = rk ) X( (N+1)/2 ), specifies the diagonal ! elements of A. ! ! real ( kind = rk ) Y( N/2 ), specifies the off-diagonal ! elements of the Schur blocks. ! ! Output: ! ! real ( kind = rk ) DETERM, the determinant of A. ! implicit none integer, parameter :: rk = kind ( 1.0D+00 ) integer n real ( kind = rk ) determ integer i real ( kind = rk ) x((n+1)/2) real ( kind = rk ) 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 ) == 1 ) then determ = determ * x((n+1)/2) end if return end subroutine schur_block_eigenvalues ( n, x, y, lambda ) !*****************************************************************************80 ! !! schur_block_eigenvalues() returns the eigenvalues of the schur_block matrix. ! ! Licensing: ! ! This code is distributed under the MIT license. ! ! Modified: ! ! 20 October 2007 ! ! Author: ! ! John Burkardt ! ! Input: ! ! integer N, the order of the matrix. ! ! real ( kind = rk ) X( (N+1)/2 ), specifies the diagonal ! elements of A. ! ! real ( kind = rk ) Y( N/2 ), specifies the off-diagonal ! elements of the Schur blocks. ! ! Output: ! ! complex ( kind = ck ) LAMBDA(N), the eigenvalues of A. ! implicit none integer, parameter :: rk = kind ( 1.0D+00 ) integer, parameter :: ck = kind ( ( 1.0D+00, 1.0D+00 ) ) integer n integer i integer k complex ( kind = ck ) lambda(n) real ( kind = rk ) x((n+1)/2) real ( kind = rk ) y(n/2) k = 0 do i = 1, n / 2 k = k + 1 lambda(k) = cmplx ( x(i), y(i), kind = ck ) k = k + 1 lambda(k) = cmplx ( x(i), -y(i), kind = ck ) end do if ( k < n ) then k = k + 1 lambda(k) = x((n+1)/2) end if return end subroutine schur_block_inverse ( n, x, y, a ) !*****************************************************************************80 ! !! schur_block_inverse() returns the inverse of the schur_block matrix. ! ! Licensing: ! ! This code is distributed under the MIT license. ! ! Modified: ! ! 20 October 2007 ! ! Author: ! ! John Burkardt ! ! Input: ! ! integer N, the order of the matrix. ! ! real ( kind = rk ) X( (N+1)/2 ), specifies the diagonal elements ! of A. ! ! real ( kind = rk ) Y( N/2 ), specifies the off-diagonal elements ! of the Schur blocks. ! ! Output: ! ! real ( kind = rk ) A(N,N), the matrix. ! implicit none integer, parameter :: rk = kind ( 1.0D+00 ) integer n real ( kind = rk ) a(n,n) integer i integer j integer k real ( kind = rk ) x((n+1)/2) real ( kind = rk ) y(n/2) do j = 1, n do i = 1, n k = ( i + 1 ) / 2 if ( i == j ) then if ( i == n .and. mod ( n, 2 ) == 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 ) == 1 .and. j == i + 1 ) then a(i,j) = - y(k) / ( x(k) * x(k) + y(k) * y(k) ) else if ( mod ( i, 2 ) == 0 .and. j == 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_matrix ( m, n, x, a ) !*****************************************************************************80 ! !! skew_circulant_matrix() returns a skew_circulant matrix. ! ! Formula: ! ! K = 1 + mod ( J - I, N ) ! ! if ( I <= J ) then ! A(I,J) = +X(K) ! else ! A(I,J) = -X(K) ! ! Example: ! ! M = 4, N = 4, X = ( 1, 2, 3, 4 ) ! ! 1 2 3 4 ! -4 1 2 3 ! -3 -4 1 2 ! -2 -3 -4 1 ! ! M = 4, N = 5, X = ( 1, 2, 3, 4, 5 ) ! ! 1 2 3 4 5 ! -5 1 2 3 4 ! -4 -5 1 2 3 ! -3 -4 -5 1 2 ! ! M = 5, N = 4, X = ( 1, 2, 3, 4 ) ! ! 1 2 3 4 ! -5 1 2 3 ! -4 -5 1 2 ! -3 -4 -5 1 ! -1 -2 -3 -4 ! ! Licensing: ! ! This code is distributed under the MIT license. ! ! Modified: ! ! 18 October 2007 ! ! Author: ! ! John Burkardt ! ! Input: ! ! integer M, N, the order of the matrix. ! ! real ( kind = rk ) X(N), the values in the first row of A. ! ! Output: ! ! real ( kind = rk ) A(M,N), the matrix. ! implicit none integer, parameter :: rk = kind ( 1.0D+00 ) integer m integer n real ( kind = rk ) a(m,n) integer i integer i4_modp integer j integer k real ( kind = rk ) x(n) do j = 1, n do i = 1, m k = 1 + i4_modp ( j - i, n ) if ( i <= 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 ) !*****************************************************************************80 ! !! skew_circulant_determinant() returns the determinant of the skew_circulant matrix. ! ! Licensing: ! ! This code is distributed under the MIT license. ! ! Modified: ! ! 20 October 2007 ! ! Author: ! ! John Burkardt ! ! Input: ! ! integer N, the order of the matrix. ! ! real ( kind = rk ) X(N), the values in the first row of A. ! ! Output: ! ! real ( kind = rk ) DETERM, the determinant. ! implicit none integer, parameter :: rk = kind ( 1.0D+00 ) integer, parameter :: ck = kind ( ( 1.0D+00, 1.0D+00 ) ) integer n real ( kind = rk ) angle real ( kind = rk ) determ integer j integer j_hi integer k complex ( kind = ck ) lambda real ( kind = rk ), parameter :: r8_pi = 3.141592653589793D+00 real ( kind = rk ) 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 = real ( ( 2 * j - 1 ) * ( k - 1 ), kind = rk ) * r8_pi & / real ( n, kind = rk ) lambda = lambda + x(k) * cmplx ( cos ( angle ), sin ( angle ), kind = ck ) end do if ( 2 * j <= 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 ) !*****************************************************************************80 ! !! skew_circulant_eigenvalues() returns eigenvalues of the skew_circulant matrix. ! ! Licensing: ! ! This code is distributed under the MIT license. ! ! Modified: ! ! 20 October 2007 ! ! Author: ! ! John Burkardt ! ! Input: ! ! integer N, the order of the matrix. ! ! real ( kind = rk ) X(N), the values in the first row of A. ! ! Output: ! ! complex ( kind = ck ) LAMBDA(N), the eigenvalues. ! implicit none integer, parameter :: rk = kind ( 1.0D+00 ) integer, parameter :: ck = kind ( ( 1.0D+00, 1.0D+00 ) ) integer n real ( kind = rk ) angle integer j integer k complex ( kind = ck ) lambda(n) real ( kind = rk ), parameter :: r8_pi = 3.141592653589793D+00 real ( kind = rk ) x(n) lambda(1:n) = 0.0D+00 do j = 1, n do k = 1, n angle = real ( ( 2 * j - 1 ) * ( k - 1 ), kind = rk ) * r8_pi & / real ( n, kind = rk ) lambda(j) = lambda(j) & + x(k) * cmplx ( cos ( angle ), sin ( angle ), kind = ck ) end do end do return end subroutine smoke1_matrix ( n, a ) !*****************************************************************************80 ! !! smoke1_matrix() returns the SMOKE1 matrix. ! ! Formula: ! ! W = exp ( 2 * PI * sqrt ( -1 ) / N ) ! ! If ( J = I + 1 ) then ! A(I,J) = 1 ! If ( I = N and J = 1 ) then ! A(I,J) = 1 ! If ( I = J ) then ! A(I,J) = W^I ! Else ! A(I,J) = 0 ! ! Example: ! ! N = 5 ! ! w 1 0 0 0 ! 0 w^2 1 0 0 ! 0 0 w^3 1 0 ! 0 0 0 w^4 1 ! 1 0 0 0 w^5 ! ! Properties: ! ! A is generally not symmetric: A' /= A. ! ! The matrix has an interesting spectrum. The eigenvalues are ! the N-th roots of unity times 2^(1/N). ! ! Licensing: ! ! This code is distributed under the MIT license. ! ! Modified: ! ! 25 October 2007 ! ! Author: ! ! John Burkardt ! ! Reference: ! ! Lothar Reichel, Lloyd Trefethen, ! Eigenvalues and pseudo-eigenvalues of Toeplitz matrices, ! Linear Algebra and Applications, ! Volume 162-164, 1992, pages 153-185. ! ! Input: ! ! integer N, the order of the matrix. ! ! Output: ! ! complex ( kind = ck ) A(N,N), the matrix. ! implicit none integer, parameter :: rk = kind ( 1.0D+00 ) integer, parameter :: ck = kind ( ( 1.0D+00, 1.0D+00 ) ) integer n complex ( kind = ck ) a(n,n) complex ( kind = ck ) c8_i integer i integer j real ( kind = rk ), parameter :: r8_pi = 3.141592653589793D+00 complex ( kind = ck ) w w = exp ( 2.0D+00 * r8_pi * c8_i ( ) / real ( n, kind = rk ) ) do j = 1, n do i = 1, n if ( i + 1 == j ) then a(i,j) = 1.0D+00 else if ( i == n .and. j == 1 ) then a(i,j) = 1.0D+00 else if ( i == 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 ) !*****************************************************************************80 ! !! smoke1_determinant() returns the determinant of the SMOKE1 matrix. ! ! Licensing: ! ! This code is distributed under the MIT license. ! ! Modified: ! ! 13 October 2007 ! ! Author: ! ! John Burkardt ! ! Input: ! ! integer N, the order of the matrix. ! ! Output: ! ! real ( kind = rk ) DETERM, the determinant. ! implicit none integer, parameter :: rk = kind ( 1.0D+00 ) real ( kind = rk ) determ integer n if ( mod ( n, 2 ) == 1 ) then determ = 2.0D+00 else determ = - 2.0D+00 end if return end subroutine smoke1_eigenvalues ( n, lambda ) !*****************************************************************************80 ! !! smoke1_eigenvalues() returns the eigenvalues of the SMOKE1 matrix. ! ! Licensing: ! ! This code is distributed under the MIT license. ! ! Modified: ! ! 27 May 2002 ! ! Author: ! ! John Burkardt ! ! Input: ! ! integer N, the order of the matrix. ! ! Output: ! ! complex ( kind = ck ) LAMBDA(N), the eigenvalues. ! implicit none integer, parameter :: rk = kind ( 1.0D+00 ) integer, parameter :: ck = kind ( ( 1.0D+00, 1.0D+00 ) ) integer n real ( kind = rk ) angle complex ( kind = ck ) c8_i integer i complex ( kind = ck ) lambda(n) real ( kind = rk ), parameter :: r8_pi = 3.141592653589793D+00 do i = 1, n angle = 2.0D+00 * r8_pi * real ( i, kind = rk ) / real ( n, kind = rk ) lambda(i) = exp ( angle * c8_i ( ) ) end do lambda(1:n) = lambda(1:n) * 2.0D+00 ** ( 1.0D+00 / real ( n, kind = rk ) ) return end subroutine smoke2_matrix ( n, a ) !*****************************************************************************80 ! !! smoke2_matrix() returns the SMOKE2 matrix. ! ! Formula: ! ! W = exp ( 2 * PI * sqrt ( -1 ) / N ) ! ! If ( J = I + 1 ) then ! A(I,J) = 1 ! If ( I = J ) then ! A(I,J) = W^I ! Else ! A(I,J) = 0 ! ! Example: ! ! N = 5 ! ! w 1 0 0 0 ! 0 w^2 1 0 0 ! 0 0 w^3 1 0 ! 0 0 0 w^4 1 ! 0 0 0 0 w^5 ! ! Properties: ! ! A is generally not symmetric: A' /= A. ! ! The eigenvalues are the N-th roots of unity. ! ! Licensing: ! ! This code is distributed under the MIT license. ! ! Modified: ! ! 25 October 2007 ! ! Author: ! ! John Burkardt ! ! Reference: ! ! Lothar Reichel, Lloyd Trefethen, ! Eigenvalues and pseudo-eigenvalues of Toeplitz matrices, ! Linear Algebra and Applications, ! Volume 162-164, 1992, pages 153-185. ! ! Input: ! ! integer N, the order of the matrix. ! ! Output: ! ! complex ( kind = ck ) A(N,N), the matrix. ! implicit none integer, parameter :: rk = kind ( 1.0D+00 ) integer, parameter :: ck = kind ( ( 1.0D+00, 1.0D+00 ) ) integer n complex ( kind = ck ) a(n,n) complex ( kind = ck ) c8_i integer i integer j real ( kind = rk ), parameter :: r8_pi = 3.141592653589793D+00 complex ( kind = ck ) w w = exp ( 2.0D+00 * r8_pi * c8_i ( ) / real ( n, kind = rk ) ) do j = 1, n do i = 1, n if ( i + 1 == j ) then a(i,j) = 1.0D+00 else if ( i == 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 ) !*****************************************************************************80 ! !! smoke2_determinant() returns the determinant of the SMOKE2 matrix. ! ! Licensing: ! ! This code is distributed under the MIT license. ! ! Modified: ! ! 25 October 2007 ! ! Author: ! ! John Burkardt ! ! Input: ! ! integer N, the order of the matrix. ! ! Output: ! ! real ( kind = rk ) DETERM, the determinant. ! implicit none integer, parameter :: rk = kind ( 1.0D+00 ) real ( kind = rk ) determ integer n if ( mod ( n, 2 ) == 1 ) then determ = 1.0D+00 else determ = - 1.0D+00 end if return end subroutine smoke2_eigenvalues ( n, lambda ) !*****************************************************************************80 ! !! smoke2_eigenvalues() returns the eigenvalues of the SMOKE2 matrix. ! ! Licensing: ! ! This code is distributed under the MIT license. ! ! Modified: ! ! 27 May 2002 ! ! Author: ! ! John Burkardt ! ! Input: ! ! integer N, the order of the matrix. ! ! Output: ! ! complex ( kind = ck ) LAMBDA(N), the eigenvalues. ! implicit none integer, parameter :: rk = kind ( 1.0D+00 ) integer, parameter :: ck = kind ( ( 1.0D+00, 1.0D+00 ) ) integer n real ( kind = rk ) angle complex ( kind = ck ) c8_i integer i complex ( kind = ck ) lambda(n) real ( kind = rk ), parameter :: r8_pi = 3.141592653589793D+00 do i = 1, n angle = 2.0D+00 * r8_pi * real ( i, kind = rk ) / real ( n, kind = rk ) lambda(i) = exp ( angle * c8_i ( ) ) end do return end subroutine snakes_matrix ( a ) !*****************************************************************************80 ! !! snakes_matrix() returns the Snakes and Ladders transition matrix. ! ! Discussion: ! ! The game of Snakes and Ladders, or Chutes and Ladders, is played on a ! 10x10 board of squares, numbered in boustrophedonic order, with the ! lower left corner numbered 1, and the upper left corner 100. ! ! Certain pairs of squares are joined by a ladder, and others by a snake. ! ! A player starts off the board, occupying fictitious square 0. ! A single die is rolled to determine the player's moves. Each roll of ! the die advances the player along the board. However, if the player ! lands on a square that is the bottom of a ladder, the player moves ! immediately to the top of the ladder, which is always a higher-numbered ! square. Similarly, landing on the "mouth" of a snake means that the ! player immediately drops back to the square that is the tail of the ! snake, a lower-numbered square. ! ! A player's game is over when the square 100 is reached. While the board ! game version stipulates that the 100 square must be reached by an exact ! roll, it is common for players to ignore this stipulation, so that a ! player's game is over when the next location is 100, or greater. ! ! The snakes and ladders matrix contains the transition probabilities, ! that is, A(I,J) is the probability that a player currently located ! at square J will end up at square I after a single roll of the dice. ! ! If we could ignore the snakes and ladders and the final squares, then ! the matrix would be all zero, except that entries A(I+1:I+6,J) would ! be 1/6. ! ! Licensing: ! ! This code is distributed under the MIT license. ! ! Modified: ! ! 15 July 2013 ! ! Author: ! ! John Burkardt ! ! Output: ! ! real ( kind = rk ) A(101,101), the matrix. ! implicit none integer, parameter :: rk = kind ( 1.0D+00 ) integer, parameter :: ladder_num = 9 integer, parameter :: n = 101 integer, parameter :: snake_num = 10 real ( kind = rk ) a(n,n) integer ihi integer j integer k integer l integer, dimension ( 2, ladder_num ) :: ladder = reshape ( (/ & 1, 38, & 4, 14, & 9, 31, & 21, 42, & 28, 84, & 36, 44, & 51, 67, & 71, 91, & 80, 100 /), (/ 2, ladder_num /) ) integer m integer s integer, dimension ( 2, snake_num ) :: snake = reshape ( (/ & 98, 78, & 95, 75, & 93, 73, & 87, 24, & 64, 60, & 62, 19, & 56, 53, & 49, 11, & 48, 26, & 16, 6 /), (/ 2, snake_num /) ) integer t a(1:n,1:n) = 0.0D+00 ! ! Start by ignoring snakes and ladders. ! do j = 1, n ihi = min ( j + 6, n ); a(j+1:ihi,j) = 1.0D+00 end do ! ! Deal with the fact that squares 96 through 101 have extra chances ! of ending up at 101. In particular, 101 will amount to a fixed point. ! do j = 96, n a(n,j) = a(n,j) + real ( j - 95, kind = rk ) end do ! ! For each snake, from S to T. ! All entries in row S are transferred to row T. ! Logically, column S is irrelevant, because we can never end on square S. ! For linear algebra's sake, set column S to zero, but A(T,S) to 1. ! do k = 1, snake_num s = snake(1,k) + 1 t = snake(2,k) + 1 a(t,1:n) = a(t,1:n) + a(s,1:n) a(s,1:n) = 0.0D+00 a(1:n,s) = 0.0D+00 a(t,s) = 6.0D+00 end do ! ! For each ladder, from L to M: ! All entries in row L are transferred to row M. ! Logically, column L is irrelevant, because we can never end on square L. ! For linear algebra's sake, set column L to zero, but A(M,L) to 1. ! do k = 1, ladder_num l = ladder(1,k) + 1 m = ladder(2,k) + 1 a(m,1:n) = a(m,1:n) + a(l,1:n) a(l,1:n) = 0.0D+00 a(1:n,l) = 0.0D+00 a(m,l) = 6.0D+00 end do ! ! Normalize. ! a(1:n,1:n) = a(1:n,1:n) / 6.0D+00 return end subroutine sort_heap_external ( n, indx, i, j, isgn ) !*****************************************************************************80 ! !! sort_heap_external() externally sorts a list of items into ascending order. ! ! Discussion: ! ! The actual list of data is not passed to the routine. Hence this ! routine may be used to sort integers, reals, numbers, names, ! dates, shoe sizes, and so on. After each call, the routine asks ! the user to compare or interchange two items, until a special ! return value signals that the sorting is completed. ! ! Licensing: ! ! This code is distributed under the MIT license. ! ! Modified: ! ! 05 February 2004 ! ! Author: ! ! Original FORTRAN77 version by Albert Nijenhuis, Herbert Wilf. ! FORTRAN90 version by John Burkardt. ! ! Reference: ! ! Albert Nijenhuis, Herbert Wilf, ! Combinatorial Algorithms for Computers and Calculators, ! Academic Press, 1978, ! ISBN: 0-12-519260-6, ! LC: QA164.N54. ! ! Input: ! ! integer N, the number of items to be sorted. ! ! integer INDX, the main communication signal. ! The user must set INDX to 0 before the first call. ! Thereafter, the user should not change the value of INDX until ! the sorting is done. ! ! integer ISGN, results of comparison of elements ! I and J. (Used only when the previous call returned INDX less than 0). ! ISGN <= 0 means I is less than or equal to J; ! 0 <= ISGN means I is greater than or equal to J. ! ! Output: ! ! integer INDX, the main communication signal. ! On return, if INDX is ! * greater than 0, ! > interchange items I and J; ! > call again. ! * less than 0, ! > compare items I and J; ! > set ISGN = -1 if I < J, ISGN = +1 if J < I; ! > call again. ! * equal to 0, the sorting is done. ! ! integer I, J, the indices of two items. ! On return with INDX positive, elements I and J should be interchanged. ! On return with INDX negative, elements I and J should be compared, and ! the result reported in ISGN on the next call. ! implicit none integer, parameter :: rk = kind ( 1.0D+00 ) integer i integer, save :: i_save = 0 integer indx integer isgn integer j integer, save :: j_save = 0 integer, save :: k = 0 integer, save :: k1 = 0 integer n integer, save :: n1 = 0 ! ! INDX = 0: This is the first call. ! if ( indx == 0 ) then i_save = 0 j_save = 0 k = n / 2 k1 = k n1 = n ! ! INDX < 0: The user is returning the results of a comparison. ! else if ( indx < 0 ) then if ( indx == -2 ) then if ( isgn < 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 < isgn ) then indx = 2 i = i_save j = j_save return end if if ( k <= 1 ) then if ( n1 == 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 ! ! 0 < INDX, the user was asked to make an interchange. ! else if ( indx == 1 ) then k1 = k end if do i_save = 2 * k1 if ( i_save == n1 ) then j_save = k1 k1 = i_save indx = -1 i = i_save j = j_save return else if ( i_save <= n1 ) then j_save = i_save + 1 indx = -2 i = i_save j = j_save return end if if ( k <= 1 ) then exit end if k = k - 1 k1 = k end do if ( n1 == 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 spd_random_determinant ( n, key, determ ) !*****************************************************************************80 ! !! spd_random_determinant() returns the determinant of the SPD_RANDOM matrix. ! ! Licensing: ! ! This code is distributed under the MIT license. ! ! Modified: ! ! 15 May 2021 ! ! Author: ! ! John Burkardt ! ! Input: ! ! integer N, the order of the matrix. ! ! integer KEY, a seed for the random number generator. ! ! Output: ! ! real ( kind = rk ) DETERM, the determinant. ! implicit none integer, parameter :: rk = kind ( 1.0D+00 ) integer n real ( kind = rk ) determ integer key real ( kind = rk ) lambda(n) integer seed seed = key call r8vec_uniform_01 ( n, seed, lambda ) determ = product ( lambda(1:n) ) return end subroutine spd_random_eigen_right ( n, key, q ) !*****************************************************************************80 ! !! spd_random_eigen_right(): right eigenvectors of the SPD_RANDOM matrix. ! ! Licensing: ! ! This code is distributed under the MIT license. ! ! Modified: ! ! 15 May 2021 ! ! Author: ! ! John Burkardt ! ! Input: ! ! integer N, the order of the matrix. ! ! integer KEY, a seed for the random number generator. ! ! Output: ! ! real ( kind = rk ) Q(N,N), the matrix. ! implicit none integer, parameter :: rk = kind ( 1.0D+00 ) integer n integer key real ( kind = rk ) lambda(n) real ( kind = rk ) q(n,n) integer seed ! ! Get a random set of eigenvalues. ! seed = key call r8vec_uniform_01 ( n, seed, lambda ) ! ! Get a random orthogonal matrix Q. ! call orthogonal_random_matrix ( n, seed, q ) return end subroutine spd_random_eigenvalues ( n, key, lambda ) !*****************************************************************************80 ! !! spd_random_eigenvalues() returns the eigenvalues of the SPD_RANDOM matrix. ! ! Licensing: ! ! This code is distributed under the MIT license. ! ! Modified: ! ! 15 May 2021 ! ! Author: ! ! John Burkardt ! ! Input: ! ! integer N, the order of the matrix. ! ! integer KEY, a seed for the random number generator. ! ! Output: ! ! real ( kind = rk ) LAMBDA(N), the eigenvalues. ! implicit none integer, parameter :: rk = kind ( 1.0D+00 ) integer n integer key real ( kind = rk ) lambda(n) integer seed seed = key call r8vec_uniform_01 ( n, seed, lambda ) return end subroutine spd_random_inverse ( n, key, a ) !*****************************************************************************80 ! !! spd_random_inverse() returns the inverse of the SPD_RANDOM matrix. ! ! Discussion: ! ! The matrix is a "random" positive definite symmetric matrix. ! ! The matrix returned will have eigenvalues in the range [0,1]. ! ! Properties: ! ! A is symmetric: A' = A. ! ! A is positive definite: 0 < x'*A*x for nonzero x. ! ! The eigenvalues of A will be real. ! ! Licensing: ! ! This code is distributed under the MIT license. ! ! Modified: ! ! 15 May 2021 ! ! Author: ! ! John Burkardt ! ! Input: ! ! integer N, the order of the matrix. ! ! integer KEY, a seed for the random number generator. ! ! Output: ! ! real ( kind = rk ) A(N,N), the matrix. ! implicit none integer, parameter :: rk = kind ( 1.0D+00 ) integer n real ( kind = rk ) a(n,n) integer i integer j integer k integer key real ( kind = rk ) lambda(n) real ( kind = rk ) q(n,n) integer seed ! ! Get a random set of eigenvalues. ! seed = key call r8vec_uniform_01 ( n, seed, lambda ) ! ! Get a random orthogonal matrix Q. ! call orthogonal_random_matrix ( n, seed, q ) ! ! Set A = Q * Lambda * Q'. ! 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 spd_random_matrix ( n, key, a ) !*****************************************************************************80 ! !! spd_random_matrix() returns the SPD_RANDOM matrix. ! ! Discussion: ! ! The matrix is a "random" positive definite symmetric matrix. ! ! The matrix returned will have eigenvalues in the range [0,1]. ! ! Properties: ! ! A is symmetric: A' = A. ! ! A is positive definite: 0 < x'*A*x for nonzero x. ! ! The eigenvalues of A will be real. ! ! Licensing: ! ! This code is distributed under the MIT license. ! ! Modified: ! ! 15 May 2021 ! ! Author: ! ! John Burkardt ! ! Input: ! ! integer N, the order of the matrix. ! ! integer KEY, a seed for the random number generator. ! ! Output: ! ! real ( kind = rk ) A(N,N), the matrix. ! implicit none integer, parameter :: rk = kind ( 1.0D+00 ) integer n real ( kind = rk ) a(n,n) integer i integer j integer k integer key real ( kind = rk ) lambda(n) real ( kind = rk ) q(n,n) integer seed ! ! Get a random set of eigenvalues. ! seed = key call r8vec_uniform_01 ( n, seed, lambda ) ! ! Get a random orthogonal matrix Q. ! call orthogonal_random_matrix ( n, seed, q ) ! ! Set A = Q * Lambda * Q'. ! 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 spline_matrix ( n, x, a ) !*****************************************************************************80 ! !! spline_matrix() returns the SPLINE matrix. ! ! Discussion: ! ! This matrix arises during interpolation with cubic splines. ! ! Formula: ! ! if ( I = 1 and J = I ) then ! A(I,J) = 2 * X(I) ! else if ( I = 1 and J = I + 1 ) then ! A(I,J) = X(I) ! else if ( I = N and J = I ) then ! A(I,J) = 2 * X(N-1) ! else if ( I = N and J = I - 1 ) then ! A(I,J) = X(N-1) ! else if ( J = I ) then ! A(I,J) = 2 * (X(I-1)+X(I)) ! else if ( J = I-1 ) then ! A(I,J) = X(I-1) ! else if ( J = I + 1 ) then ! A(I,J) = X(I) ! else ! A(I,J) = 0 ! ! Example: ! ! N = 5 ! X = ( 1, 1, 1, 1 ) ! ! 2 1 0 0 0 ! 1 4 1 0 0 ! 0 1 4 1 0 ! 0 0 1 4 1 ! 0 0 0 1 2 ! ! N = 5 ! X = ( 1, 2, 3, 4 ) ! ! 2 1 0 0 0 ! 1 6 2 0 0 ! 0 2 10 3 0 ! 0 0 3 14 4 ! 0 0 0 4 8 ! ! Properties: ! ! A is symmetric: A' = A. ! ! Because A is symmetric, it is normal. ! ! Because A is normal, it is diagonalizable. ! ! A is tridiagonal. ! ! Because A is tridiagonal, it has property A (bipartite). ! ! A is banded, with bandwidth 3. ! ! If the entries of X are positive, then A is positive definite. ! ! If the entries of X are all of one sign, then A is diagonally dominant. ! ! Licensing: ! ! This code is distributed under the MIT license. ! ! Modified: ! ! 28 March 2000 ! ! Author: ! ! John Burkardt ! ! Input: ! ! integer N, the order of the matrix. ! ! real ( kind = rk ) X(N-1), values that represent the spacing ! between points, and which define the entries of A. ! ! Output: ! ! real ( kind = rk ) A(N,N), the matrix. ! implicit none integer, parameter :: rk = kind ( 1.0D+00 ) integer n real ( kind = rk ) a(n,n) integer i integer j real ( kind = rk ) x(n-1) do j = 1, n do i = 1, n if ( i == 1 .and. j == i ) then a(i,j) = 2.0D+00 * x(1) else if ( i == 1 .and. j == i + 1 ) then a(i,j) = x(1) else if ( i == n .and. j == i ) then a(i,j) = 2.0D+00 * x(n-1) else if ( i == n .and. j == i - 1 ) then a(i,j) = x(n-1) else if ( j == i ) then a(i,j) = 2.0D+00 * ( x(i-1) + x(i) ) else if ( j == i - 1 ) then a(i,j) = x(i-1) else if ( j == 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 ) !*****************************************************************************80 ! !! spline_determinant() returns the determinant of the SPLINE matrix. ! ! Licensing: ! ! This code is distributed under the MIT license. ! ! Modified: ! ! 08 November 2007 ! ! Author: ! ! John Burkardt ! ! Input: ! ! integer N, the order of the matrix. ! ! real ( kind = rk ) X(N-1), the parameters. ! ! Output: ! ! real ( kind = rk ) DETERM, the determinant. ! implicit none integer, parameter :: rk = kind ( 1.0D+00 ) integer n real ( kind = rk ) determ real ( kind = rk ) determ_nm1 real ( kind = rk ) determ_nm2 integer i real ( kind = rk ) x(n-1) determ_nm1 = 2.0D+00 * x(n-1) if ( n == 1 ) then determ = determ_nm1 return end if determ_nm2 = determ_nm1 if ( n == 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 == 2 ) then determ = determ_nm1 return end if do i = n - 2, 1, -1 if ( i == 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 ) !*****************************************************************************80 ! !! spline_inverse() returns the inverse of the SPLINE matrix. ! ! Licensing: ! ! This code is distributed under the MIT license. ! ! Modified: ! ! 22 November 2007 ! ! Author: ! ! John Burkardt ! ! Reference: ! ! CM daFonseca, J Petronilho, ! Explicit Inverses of Some Tridiagonal Matrices, ! Linear Algebra and Its Applications, ! Volume 325, 2001, pages 7-21. ! ! Input: ! ! integer N, the order of the matrix. ! ! real ( kind = rk ) X(N-1), the parameters. ! ! Output: ! ! real ( kind = rk ) A(N,N), the inverse of the matrix. ! implicit none integer, parameter :: rk = kind ( 1.0D+00 ) integer n real ( kind = rk ) a(n,n) real ( kind = rk ) d(n) real ( kind = rk ) e(n) integer i integer j real ( kind = rk ) r8_mop real ( kind = rk ) 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 ) * product ( x(j:i-1) ) & * product ( d(i+1:n) ) / product ( e(j:n) ) end do do j = i + 1, n a(i,j) = r8_mop ( i + j ) * product ( x(i:j-1) ) & * product ( d(j+1:n) ) / product ( e(i:n) ) end do end do return end subroutine stirling_matrix ( m, n, a ) !*****************************************************************************80 ! !! stirling_matrix() returns the STIRLING matrix. ! ! Discussion: ! ! The entries of this matrix are the Stirling numbers of the first kind. ! ! The absolute value of the Stirling number S1(I,J) gives the number ! of permutations on I objects having exactly J cycles, while the ! sign of the Stirling number records the sign (odd or even) of ! the permutations. For example, there are six permutations on 3 objects: ! ! A B C 3 cycles (A) (B) (C) ! A C B 2 cycles (A) (BC) ! B A C 2 cycles (AB) (C) ! B C A 1 cycle (ABC) ! C A B 1 cycle (ABC) ! C B A 2 cycles (AC) (B) ! ! There are ! ! 2 permutations with 1 cycle, and S1(3,1) = 2 ! 3 permutations with 2 cycles, and S1(3,2) = -3, ! 1 permutation with 3 cycles, and S1(3,3) = 1. ! ! Since there are N! permutations of N objects, the sum of the absolute ! values of the Stirling numbers in a given row, ! ! sum ( 1 <= J <= I ) abs ( S1(I,J) ) = N! ! ! First terms: ! ! I/J: 1 2 3 4 5 6 7 8 ! ! 1 1 0 0 0 0 0 0 0 ! 2 -1 1 0 0 0 0 0 0 ! 3 2 -3 1 0 0 0 0 0 ! 4 -6 11 -6 1 0 0 0 0 ! 5 24 -50 35 -10 1 0 0 0 ! 6 -120 274 -225 85 -15 1 0 0 ! 7 720 -1764 1624 -735 175 -21 1 0 ! 8 -5040 13068 -13132 6769 -1960 322 -28 1 ! ! Recursion: ! ! S1(I,1) = (-1)^(I-1) * (I-1)! for all I. ! S1(I,I) = 1 for all I. ! S1(I,J) = 0 if I < J. ! ! S1(I,J) = S1(I-1,J-1) - (I-1) * S1(I-1,J) ! ! Properties: ! ! A is generally not symmetric: A' /= A. ! ! A is integral, therefore det ( A ) is integral, and ! det ( A ) * inverse ( A ) is integral. ! ! A is lower triangular. ! ! det ( A ) = 1. ! ! A is unimodular. ! ! LAMBDA(1:N) = 1. ! ! After row 1, each row sums to 0. ! ! The family of matrices is nested as a function of N. ! ! Licensing: ! ! This code is distributed under the MIT license. ! ! Modified: ! ! 01 July 2000 ! ! Author: ! ! John Burkardt ! ! Input: ! ! integer M, N, the order of the matrix. ! ! Output: ! ! real ( kind = rk ) A(M,N), the matrix. ! implicit none integer, parameter :: rk = kind ( 1.0D+00 ) integer m integer n real ( kind = rk ) a(m,n) integer i integer j a(1,1) = 1.0D+00 a(1,2:n) = 0.0D+00 do i = 2, m a(i,1) = - real ( i - 1, kind = rk ) * a(i-1,1) do j = 2, n a(i,j) = a(i-1,j-1) - real ( i - 1, kind = rk ) * a(i-1,j) end do end do return end subroutine stirling_determinant ( n, determ ) !*****************************************************************************80 ! !! stirling_determinant() returns the determinant of the STIRLING matrix. ! ! Licensing: ! ! This code is distributed under the MIT license. ! ! Modified: ! ! 08 October 2007 ! ! Author: ! ! John Burkardt ! ! Input: ! ! integer N, the order of the matrix. ! ! Output: ! ! real ( kind = rk ) DETERM, the determinant. ! implicit none integer, parameter :: rk = kind ( 1.0D+00 ) real ( kind = rk ) determ integer n call i4_fake_use ( n ) determ = 1.0D+00 return end subroutine stirling_eigenvalues ( n, lambda ) !*****************************************************************************80 ! !! stirling_eigenvalues() returns the eigenvalues of the STIRLING matrix. ! ! Licensing: ! ! This code is distributed under the MIT license. ! ! Modified: ! ! 15 August 2008 ! ! Author: ! ! John Burkardt ! ! Input: ! ! integer N, the order of the matrix. ! ! Output: ! ! real ( kind = rk ) LAMBDA(N), the eigenvalues. ! implicit none integer, parameter :: rk = kind ( 1.0D+00 ) integer n real ( kind = rk ) lambda(n) lambda(1:n) = 1.0D+00 return end subroutine stirling_inverse ( n, a ) !*****************************************************************************80 ! !! stirling_inverse() returns the inverse of the STIRLING matrix. ! ! Comments: ! ! The inverse of S1, the matrix of Stirling numbers of the first kind, ! is S2, the matrix of Stirling numbers of the second kind. ! ! S2(I,J) represents the number of distinct partitions of I elements ! into J nonempty sets. For any I, the sum over J of the Stirling ! numbers S2(I,J) is represented by B(I), called "Bell's number", ! and represents the number of distinct partitions of I elements. ! ! For example, with 4 objects, there are: ! ! 1 partition into 1 set: ! ! (A,B,C,D) ! ! 7 partitions into 2 sets: ! ! (A,B,C) (D) ! (A,B,D) (C) ! (A,C,D) (B) ! (A) (B,C,D) ! (A,B) (C,D) ! (A,C) (B,D) ! (A,D) (B,C) ! ! 6 partitions into 3 sets: ! ! (A,B) (C) (D) ! (A) (B,C) (D) ! (A) (B) (C,D) ! (A,C) (B) (D) ! (A,D) (B) (C) ! (A) (B,D) (C) ! ! 1 partition into 4 sets: ! ! (A) (B) (C) (D) ! ! So S2(4,1) = 1, S2(4,2) = 7, S2(4,3) = 6, S2(4,4) = 1, and B(4) = 15. ! ! ! First terms: ! ! I/J: 1 2 3 4 5 6 7 8 ! ! 1 1 0 0 0 0 0 0 0 ! 2 1 1 0 0 0 0 0 0 ! 3 1 3 1 0 0 0 0 0 ! 4 1 7 6 1 0 0 0 0 ! 5 1 15 25 10 1 0 0 0 ! 6 1 31 90 65 15 1 0 0 ! 7 1 63 301 350 140 21 1 0 ! 8 1 127 966 1701 1050 266 28 1 ! ! Recursion: ! ! S2(I,1) = 1 for all I. ! S2(I,I) = 1 for all I. ! S2(I,J) = 0 if I < J. ! ! S2(I,J) = J * S2(I-1,J) + S2(I-1,J-1) ! ! Properties: ! ! A is generally not symmetric: A' /= A. ! ! A is integral, therefore det ( A ) is integral, and ! det ( A ) * inverse ( A ) is integral. ! ! A is lower triangular. ! ! A is nonnegative. ! ! det ( A ) = 1. ! ! A is unimodular. ! ! LAMBDA(1:N) = 1. ! ! Licensing: ! ! This code is distributed under the MIT license. ! ! Modified: ! ! 01 July 2000 ! ! Author: ! ! John Burkardt ! ! Input: ! ! integer N, the order of the matrix. ! ! Output: ! ! real ( kind = rk ) A(N,N), the matrix. ! implicit none integer, parameter :: rk = kind ( 1.0D+00 ) integer n real ( kind = rk ) a(n,n) integer i integer j a(1,1) = 1.0D+00 a(1,2:n) = 0.0D+00 do i = 2, n a(i,1) = 1.0D+00 do j = 2, n a(i,j) = real ( j, kind = rk ) * a(i-1,j) + a(i-1,j-1) end do end do return end subroutine stripe_matrix ( n, a ) !*****************************************************************************80 ! !! stripe_matrix() returns the STRIPE matrix. ! ! Example: ! ! N = 7 ! ! 5 2 1 1 . . . ! 2 6 3 1 1 . . ! 1 3 6 3 1 1 . ! 1 1 3 6 3 1 1 ! . 1 1 3 6 3 1 ! . . 1 1 3 6 2 ! . . . 1 1 2 5 ! ! Properties: ! ! A is integral, therefore det ( A ) is integral, and ! det ( A ) * inverse ( A ) is integral. ! ! A is symmetric: A' = A. ! ! A is banded, with bandwidth 7. ! ! A is centrosymmetric: A(I,J) = A(N+1-I,N+1-J). ! ! Licensing: ! ! This code is distributed under the MIT license. ! ! Modified: ! ! 01 April 2000 ! ! Author: ! ! John Burkardt ! ! Reference: ! ! Joan Westlake, ! A Handbook of Numerical Matrix Inversion and Solution of ! Linear Equations, ! John Wiley, 1968, ! ISBN13: 978-0471936756, ! LC: QA263.W47. ! ! Input: ! ! integer N, the order of the matrix. ! ! Output: ! ! real ( kind = rk ) A(N,N), the matrix. ! implicit none integer, parameter :: rk = kind ( 1.0D+00 ) integer n real ( kind = rk ) a(n,n) integer i integer j do j = 1, n do i = 1, n if ( j == i - 3 ) then a(i,j) = 1.0D+00 else if ( j == i - 2 ) then a(i,j) = 1.0D+00 else if ( j == i - 1 ) then if ( j == 1 .or. j == n - 1 ) then a(i,j) = 2.0D+00 else a(i,j) = 3.0D+00 end if else if ( j == i ) then if ( i == 1 .or. i == n ) then a(i,j) = 5.0D+00 else a(i,j) = 6.0D+00 end if else if ( j == i + 1 ) then if ( j == 2 .or. j == n ) then a(i,j) = 2.0D+00 else a(i,j) = 3.0D+00 end if else if ( j == i + 2 ) then a(i,j) = 1.0D+00 else if ( j == 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, a ) !*****************************************************************************80 ! !! subset_random() selects a random subset of an N-set. ! ! Licensing: ! ! This code is distributed under the MIT license. ! ! Modified: ! ! 01 December 2000 ! ! Author: ! ! Original FORTRAN77 version by Albert Nijenhuis, Herbert Wilf. ! FORTRAN90 version by John Burkardt. ! ! Reference: ! ! Albert Nijenhuis, Herbert Wilf, ! Combinatorial Algorithms, ! Academic Press, 1978, second edition, ! ISBN 0-12-519260-6. ! ! Input: ! ! integer N, the size of the full set. ! ! Output: ! ! integer A(N). A vector to hold the information about ! the set chosen. On return, if A(I) = 1, then ! I is in the random subset, otherwise, A(I) = 0 ! and I is not in the random subset. ! implicit none integer, parameter :: rk = kind ( 1.0D+00 ) integer n integer a(n) integer i integer i4_uniform_ab do i = 1, n a(i) = i4_uniform_ab ( 0, 1 ) end do return end subroutine sudoku_adj_matrix ( a ) !*****************************************************************************80 ! !! sudoku_adj_matrix returns the Sudoku adjacency matrix. ! ! Discussion: ! ! A Sudoko is a 9x9 array, subdivided into 9 3x3 blocks. ! ! Two elements of the 9x9 array are adjacent if they lie in the same ! row, column, or 3x3 subblock. ! ! The eigenvalues of the Sudoku adjacency matrix are all integers. ! ! Licensing: ! ! This code is distributed under the MIT license. ! ! Modified: ! ! 20 February 2018 ! ! Author: ! ! John Burkardt ! ! Output: ! ! real A(81,81), the matrix. ! implicit none integer, parameter :: rk = kind ( 1.0D+00 ) real ( kind = rk ) a(81,81) integer bcoli integer bcolj integer browi integer browj integer coli integer colj integer i integer j integer rowi integer rowj a(1:81,1:81) = 0.0D+00 do i = 1, 81 rowi = 1 + ( ( i - 1 ) / 9 ) coli = 1 + mod ( i - 1, 9 ) browi = 1 + ( ( rowi - 1 ) / 3 ) bcoli = 1 + ( ( coli - 1 ) / 3 ) do j = 1, 81 rowj = 1 + ( ( j - 1 ) / 9 ) colj = 1 + mod ( j - 1, 9 ) browj = 1 + ( ( rowj - 1 ) / 3 ) bcolj = 1 + ( ( colj - 1 ) / 3 ) if ( rowi == rowj .or. & coli == colj .or. & ( browi == browj .and. bcoli == bcolj ) ) then a(i,j) = 1.0D+00 end if end do end do return end subroutine summation_matrix ( m, n, a ) !*****************************************************************************80 ! !! summation_matrix() returns the SUMMATION matrix. ! ! Example: ! ! M = 5, N = 5 ! ! 1 0 0 0 0 ! 1 1 0 0 0 ! 1 1 1 0 0 ! 1 1 1 1 0 ! 1 1 1 1 1 ! ! Properties: ! ! A is generally not symmetric: A' /= A. ! ! A is lower triangular. ! ! A is a 0/1 matrix. ! ! The vector Y = A * X contains the partial sums of the vector X. ! ! A is Toeplitz: constant along diagonals. ! ! A is nonsingular. ! ! det ( A ) = 1. ! ! A is unimodular. ! ! LAMBDA(1:N) = 1. ! ! The only eigenvector is (0,0,0,...,0,1). ! ! A is persymmetric: A(I,J) = A(N+1-J,N+1-I). ! ! The family of matrices is nested as a function of N. ! ! A is the Cholesky factor of the MINIJ matrix. ! ! Licensing: ! ! This code is distributed under the MIT license. ! ! Modified: ! ! 16 July 2008 ! ! Author: ! ! John Burkardt ! ! Input: ! ! integer M, N, the order of the matrix. ! ! Output: ! ! real ( kind = rk ) A(M,N), the matrix. ! implicit none integer, parameter :: rk = kind ( 1.0D+00 ) integer m integer n real ( kind = rk ) a(m,n) integer i integer j do j = 1, n do i = 1, m if ( j <= 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 ) !*****************************************************************************80 ! !! summation_condition() returns the L1 condition of the SUMMATION matrix. ! ! Licensing: ! ! This code is distributed under the MIT license. ! ! Modified: ! ! 08 April 2012 ! ! Author: ! ! John Burkardt ! ! Input: ! ! integer N, the order of the matrix. ! ! Output: ! ! real ( kind = rk ) COND, the L1 condition number. ! implicit none integer, parameter :: rk = kind ( 1.0D+00 ) integer n real ( kind = rk ) cond if ( n == 1 ) then cond = 1.0D+00 else cond = 2.0D+00 * real ( n, kind = rk ) end if return end subroutine summation_determinant ( n, determ ) !*****************************************************************************80 ! !! summation_determinant() returns the determinant of the SUMMATION matrix. ! ! Licensing: ! ! This code is distributed under the MIT license. ! ! Modified: ! ! 21 May 2002 ! ! Author: ! ! John Burkardt ! ! Input: ! ! integer N, the order of the matrix. ! ! Output: ! ! real ( kind = rk ) DETERM, the determinant. ! implicit none integer, parameter :: rk = kind ( 1.0D+00 ) real ( kind = rk ) determ integer n call i4_fake_use ( n ) determ = 1.0D+00 return end subroutine summation_eigenvalues ( n, lambda ) !*****************************************************************************80 ! !! summation_eigenvalues() returns the eigenvalues of the SUMMATION matrix. ! ! Licensing: ! ! This code is distributed under the MIT license. ! ! Modified: ! ! 13 October 2007 ! ! Author: ! ! John Burkardt ! ! Input: ! ! integer N, the order of the matrix. ! ! Output: ! ! real ( kind = rk ) LAMBDA(N), the eigenvalues. ! implicit none integer, parameter :: rk = kind ( 1.0D+00 ) integer n real ( kind = rk ) lambda(n) lambda(1:n) = 1.0D+00 return end subroutine summation_inverse ( n, a ) !*****************************************************************************80 ! !! summation_inverse() returns the inverse of the SUMMATION matrix. ! ! Example: ! ! N = 5 ! ! 1 0 0 0 0 ! -1 1 0 0 0 ! 0 -1 1 0 0 ! 0 0 -1 1 0 ! 0 0 0 -1 1 ! ! Properties: ! ! A is lower triangular. ! ! A is lower bidiagonal. ! ! Because A is bidiagonal, it has property A (bipartite). ! ! A is Toeplitz: constant along diagonals. ! ! A is nonsingular. ! ! det ( A ) = 1. ! ! A is unimodular. ! ! LAMBDA(1:N) = 1. ! ! A is persymmetric: A(I,J) = A(N+1-J,N+1-I). ! ! A is the inverse of the summation matrix. ! ! Licensing: ! ! This code is distributed under the MIT license. ! ! Modified: ! ! 15 April 1999 ! ! Author: ! ! John Burkardt ! ! Input: ! ! integer N, the order of the matrix. ! ! Output: ! ! real ( kind = rk ) A(N,N), the matrix. ! implicit none integer, parameter :: rk = kind ( 1.0D+00 ) integer n real ( kind = rk ) a(n,n) integer i integer j do j = 1, n do i = 1, n if ( i == j ) then a(i,j) = 1.0D+00 else if ( i == 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_matrix ( a ) !*****************************************************************************80 ! !! sweet1_matrix() returns the SWEET1 matrix. ! ! Example: ! ! 20.0 15.0 2.5 6.0 1.0 -2.0 ! 15.0 20.0 15.0 2.5 6.0 1.0 ! 2.5 15.0 20.0 15.0 2.5 6.0 ! 6.0 2.5 15.0 20.0 15.0 2.5 ! 1.0 6.0 2.5 15.0 20.0 15.0 ! -2.0 1.0 6.0 2.5 15.0 20.0 ! ! For testing, all the entries with value 2.5 are to be perturbed by ! the same value PERTURB, which should be a small multiple of the ! machine precision. ! ! Properties: ! ! A is symmetric: A' = A. ! ! Because A is symmetric, it is normal. ! ! Because A is normal, it is diagonalizable. ! ! A is Toeplitz: constant along diagonals. ! ! A is persymmetric: A(I,J) = A(N+1-J,N+1-I). ! ! Licensing: ! ! This code is distributed under the MIT license. ! ! Modified: ! ! 29 January 2015 ! ! Author: ! ! John Burkardt ! ! Reference: ! ! Per Hansen, Tony Chan, ! FORTRAN Subroutines for General Toeplitz Systems, ! ACM Transactions on Mathematical Software, ! Volume 18, Number 3, September 1992, pages 256-273. ! ! Douglas Sweet, ! The use of pivoting to improve the numerical performance of ! Toeplitz solvers, ! In "Advanced Algorithms and Architectures for Signal Processing", ! Edited by J M Speiser, ! Proceedings SPIE 696, 1986, pages 8-18. ! ! Output: ! ! real ( kind = rk ) A(6,6), the matrix. ! implicit none integer, parameter :: rk = kind ( 1.0D+00 ) integer, parameter :: n = 6 real ( kind = rk ) a(n,n) integer i integer j real ( kind = rk ), parameter, dimension ( 0:5 ) :: 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 ) !*****************************************************************************80 ! !! sweet1_condition() returns the L1 condition of the SWEET1 matrix. ! ! Licensing: ! ! This code is distributed under the MIT license. ! ! Modified: ! ! 08 February 2015 ! ! Author: ! ! John Burkardt ! ! Output: ! ! real ( kind = rk ) COND, the L1 condition. ! implicit none integer, parameter :: rk = kind ( 1.0D+00 ) real ( kind = rk ) a_norm real ( kind = rk ) b_norm real ( kind = rk ) cond a_norm = 61.0D+00 b_norm = 0.278145899201815D+00 cond = a_norm * b_norm return end subroutine sweet1_determinant ( determ ) !*****************************************************************************80 ! !! sweet1_determinant() returns the determinant of the SWEET1 matrix. ! ! Licensing: ! ! This code is distributed under the MIT license. ! ! Modified: ! ! 29 January 2015 ! ! Author: ! ! John Burkardt ! ! Output: ! ! real ( kind = rk ) DETERM, the determinant. ! implicit none integer, parameter :: rk = kind ( 1.0D+00 ) real ( kind = rk ) determ determ = - 2.0468186D+07 return end subroutine sweet1_inverse ( a ) !*****************************************************************************80 ! !! sweet1_inverse() returns the inverse of the SWEET1 matrix. ! ! Licensing: ! ! This code is distributed under the MIT license. ! ! Modified: ! ! 08 February 2015 ! ! Author: ! ! John Burkardt ! ! Output: ! ! real ( kind = rk ) A(6,6), the matrix. ! implicit none integer, parameter :: rk = kind ( 1.0D+00 ) integer, parameter :: n = 6 real ( kind = rk ) a(n,n) ! ! Note that the matrix entries are listed by column. ! real ( kind = rk ), dimension ( n, n ) :: a_save = reshape ( (/ & 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 /), & (/ 6, 6 /) ) a(1:n,1:n) = a_save(1:n,1:n) return end subroutine sweet2_matrix ( a ) !*****************************************************************************80 ! !! sweet2_matrix() returns the SWEET2 matrix. ! ! Example: ! ! 4.0 8.0 1.0 6.0 2.0 3.0 ! 6.0 4.0 8.0 1.0 6.0 2.0 ! A 6.0 4.0 8.0 1.0 6.0 ! 5.0 A 6.0 4.0 8.0 1.0 ! 3.0 5.0 A 6.0 4.0 8.0 ! 1.0 3.0 5.0 A 6.0 4.0 ! ! The entries labeled "A" have the value 71/15, but for testing, ! they would be uniformly perturbed by a value PERTURB, which should be a ! small multiple of the machine precision. ! ! Properties: ! ! A is Toeplitz: constant along diagonals. ! ! A is generally not symmetric: A' /= A. ! ! Licensing: ! ! This code is distributed under the MIT license. ! ! Modified: ! ! 29 January 2015 ! ! Author: ! ! John Burkardt ! ! Reference: ! ! Per Hansen, Tony Chan, ! FORTRAN Subroutines for General Toeplitz Systems, ! ACM Transactions on Mathematical Software, ! Volume 18, Number 3, September 1992, pages 256-273. ! ! Douglas Sweet, ! The use of pivoting to improve the numerical performance of ! Toeplitz solvers, ! In "Advanced Algorithms and Architectures for Signal Processing", ! Edited by J M Speiser, ! Proceedings SPIE 696, 1986, pages 8-18. ! ! Output: ! ! real ( kind = rk ) A(6,6), the matrix. ! implicit none integer, parameter :: rk = kind ( 1.0D+00 ) integer, parameter :: n = 6 real ( kind = rk ) a(n,n) integer i integer j real ( kind = rk ), parameter, dimension ( -5:5 ) :: value = & (/ 1.0D+00, 3.0D+00, 5.0D+00, 71.0D+00 / 15.0D+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 ) !*****************************************************************************80 ! !! sweet2_condition() returns the L1 condition of the SWEET2 matrix. ! ! Licensing: ! ! This code is distributed under the MIT license. ! ! Modified: ! ! 08 February 2015 ! ! Author: ! ! John Burkardt ! ! Output: ! ! real ( kind = rk ) COND, the L1 condition. ! implicit none integer, parameter :: rk = kind ( 1.0D+00 ) real ( kind = rk ) a_norm real ( kind = rk ) b_norm real ( kind = rk ) cond a_norm = 30.733333333333334D+00 b_norm = 1.601605164968818D+00 cond = a_norm * b_norm return end subroutine sweet2_determinant ( determ ) !*****************************************************************************80 ! !! sweet2_determinant() returns the determinant of the SWEET2 matrix. ! ! Licensing: ! ! This code is distributed under the MIT license. ! ! Modified: ! ! 29 January 2015 ! ! Author: ! ! John Burkardt ! ! Output: ! ! real ( kind = rk ) DETERM, the determinant. ! implicit none integer, parameter :: rk = kind ( 1.0D+00 ) real ( kind = rk ) determ determ = 9.562518834567902D+03 return end subroutine sweet2_inverse ( a ) !*****************************************************************************80 ! !! sweet2_inverse() returns the inverse of the SWEET2 matrix. ! ! Licensing: ! ! This code is distributed under the MIT license. ! ! Modified: ! ! 18 February 2015 ! ! Author: ! ! John Burkardt ! ! Output: ! ! real ( kind = rk ) A(6,6), the matrix. ! implicit none integer, parameter :: rk = kind ( 1.0D+00 ) integer, parameter :: n = 6 real ( kind = rk ) a(n,n) ! ! Note that the matrix entries are listed by column. ! real ( kind = rk ), dimension ( n, n ) :: a_save = reshape ( (/ & -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 & /), & (/ 6, 6 /) ) a(1:n,1:n) = a_save(1:n,1:n) return end subroutine sweet3_matrix ( a ) !*****************************************************************************80 ! !! sweet3_matrix() returns the SWEET3 matrix. ! ! Example: ! ! 8 4 1 6 2 3 ! 4 8 4 1 6 2 ! -34 4 8 4 1 6 ! 5 -34 4 8 4 1 ! 3 5 -34 4 8 4 ! 1 3 5 -34 4 8 ! ! For testing, the entries with the value -34.0 are also to ! be uniformly perturbed by a value PERTURB, which should be a ! small multiple of the machine precision. ! ! Properties: ! ! A is Toeplitz: constant along diagonals. ! ! A is generally not symmetric: A' /= A. ! ! Licensing: ! ! This code is distributed under the MIT license. ! ! Modified: ! ! 29 January 2015 ! ! Author: ! ! John Burkardt ! ! Reference: ! ! Per Hansen, Tony Chan, ! FORTRAN Subroutines for General Toeplitz Systems, ! ACM Transactions on Mathematical Software, ! Volume 18, Number 3, September 1992, pages 256-273. ! ! Douglas Sweet, ! The use of pivoting to improve the numerical performance of ! Toeplitz solvers, ! In "Advanced Algorithms and Architectures for Signal Processing", ! Edited by J M Speiser, ! Proceedings SPIE 696, 1986, pages 8-18. ! ! Output: ! ! real ( kind = rk ) A(6,6), the matrix. ! implicit none integer, parameter :: rk = kind ( 1.0D+00 ) integer, parameter :: n = 6 real ( kind = rk ) a(n,n) integer i integer j real ( kind = rk ), parameter, dimension ( -5:5 ) :: 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 ) !*****************************************************************************80 ! !! sweet3_condition() returns the L1 condition of the SWEET3 matrix. ! ! Licensing: ! ! This code is distributed under the MIT license. ! ! Modified: ! ! 23 February 2015 ! ! Author: ! ! John Burkardt ! ! Output: ! ! real ( kind = rk ) COND, the L1 condition. ! implicit none integer, parameter :: rk = kind ( 1.0D+00 ) real ( kind = rk ) a_norm real ( kind = rk ) b_norm real ( kind = rk ) cond a_norm = 58.0D+00 b_norm = 0.427215561206108D+00 cond = a_norm * b_norm return end subroutine sweet3_determinant ( determ ) !*****************************************************************************80 ! !! sweet3_determinant() returns the determinant of the SWEET3 matrix. ! ! Licensing: ! ! This code is distributed under the MIT license. ! ! Modified: ! ! 29 January 2015 ! ! Author: ! ! John Burkardt ! ! Output: ! ! real ( kind = rk ) DETERM, the determinant. ! implicit none integer, parameter :: rk = kind ( 1.0D+00 ) real ( kind = rk ) determ determ = -5.4056067D+07 return end subroutine sweet3_inverse ( a ) !*****************************************************************************80 ! !! sweet3_inverse() returns the inverse of the SWEET3 matrix. ! ! Licensing: ! ! This code is distributed under the MIT license. ! ! Modified: ! ! 23 February 2015 ! ! Author: ! ! John Burkardt ! ! Output: ! ! real ( kind = rk ) A(6,6), the matrix. ! implicit none integer, parameter :: rk = kind ( 1.0D+00 ) integer, parameter :: n = 6 real ( kind = rk ) a(n,n) ! ! Note that the matrix entries are listed by column. ! real ( kind = rk ), dimension ( n, n ) :: a_save = reshape ( (/ & 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 & /), & (/ 6, 6 /) ) a(1:n,1:n) = a_save(1:n,1:n) return end subroutine sweet4_matrix ( a ) !*****************************************************************************80 ! !! sweet4_matrix() returns the SWEET4 matrix. ! ! Example: ! ! 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 ! 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 ! -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 ! 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 ! -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 ! 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 ! -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 ! -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 ! 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 ! 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 ! -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 ! 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 ! -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 ! ! For testing, a fixed perturbation can be applied to all the values along ! the second subdiagonal. ! ! Properties: ! ! A is Toeplitz: constant along diagonals. ! ! Licensing: ! ! This code is distributed under the MIT license. ! ! Modified: ! ! 09 June 2003 ! ! Author: ! ! John Burkardt ! ! Reference: ! ! Per Hansen, Tony Chan, ! FORTRAN Subroutines for General Toeplitz Systems, ! ACM Transactions on Mathematical Software, ! Volume 18, Number 3, September 1992, pages 256-273. ! ! Douglas Sweet, ! The use of pivoting to improve the numerical performance of ! Toeplitz solvers, ! In "Advanced Algorithms and Architectures for Signal Processing", ! Edited by J M Speiser, ! Proceedings SPIE 696, 1986, pages 8-18. ! ! Output: ! ! real ( kind = rk ) A(13,13), the matrix. ! implicit none integer, parameter :: rk = kind ( 1.0D+00 ) integer, parameter :: n = 13 real ( kind = rk ) a(n,n) integer i integer j real ( kind = rk ), parameter, dimension ( -12:12 ) :: v = (/ & -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) = v ( j - i ) end do end do return end subroutine sweet4_condition ( value ) !*****************************************************************************80 ! !! sweet4_condition() returns the L1 condition of the SWEET4 matrix. ! ! Licensing: ! ! This code is distributed under the MIT license. ! ! Modified: ! ! 25 February 2015 ! ! Author: ! ! John Burkardt ! ! Output: ! ! real ( kind = rk ) VALUE, the L1 condition. ! implicit none integer, parameter :: rk = kind ( 1.0D+00 ) real ( kind = rk ) a_norm real ( kind = rk ) b_norm real ( kind = rk ) value a_norm = 100.3190000000000D+00 b_norm = 0.510081684645161D+00 value = a_norm * b_norm return end subroutine sweet4_determinant ( value ) !*****************************************************************************80 ! !! sweet4_determinant() returns the determinant of the SWEET4 matrix. ! ! Licensing: ! ! This code is distributed under the MIT license. ! ! Modified: ! ! 29 January 2015 ! ! Author: ! ! John Burkardt ! ! Output: ! ! real ( kind = rk ) VALUE, the determinant. ! implicit none integer, parameter :: rk = kind ( 1.0D+00 ) real ( kind = rk ) value value = -6.463481763930611D+16 return end subroutine sweet4_inverse ( a ) !*****************************************************************************80 ! !! sweet4_inverse() returns the inverse of the SWEET4 matrix. ! ! Licensing: ! ! This code is distributed under the MIT license. ! ! Modified: ! ! 25 February 2015 ! ! Author: ! ! John Burkardt ! ! Output: ! ! real ( kind = rk ) A(13,13), the matrix. ! implicit none integer, parameter :: rk = kind ( 1.0D+00 ) integer, parameter :: n = 13 real ( kind = rk ) a(n,n) ! ! Note that the matrix entries are listed by column. ! real ( kind = rk ), dimension ( n, n ) :: a_save = reshape ( (/ & -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 /), & (/ 13, 13 /) ) a(1:n,1:n) = a_save(1:n,1:n) return end subroutine sylvester_matrix ( n, nx, x, ny, y, a ) !*****************************************************************************80 ! !! sylvester_matrix() returns the SYLVESTER matrix. ! ! Formula: ! ! For rows 1 through NY, ! ! A(I,J) = X(NX+I-J) ! ! For rows NY+1 through NY+NX: ! ! A(I,J) = Y(I-J) ! ! Example: ! ! N = 5, ! NX = 3, X = ( 1, 2, 3, 4 ), ! NY = 2, Y = ( 5, 6, 7 ) ! ! 4 3 2 1 0 ! 0 4 3 2 1 ! 7 6 5 0 0 ! 0 7 6 5 0 ! 0 0 7 6 5 ! ! Properties: ! ! A is generally not symmetric: A' /= A. ! ! Given two polynomials, P1(X) and P2(X) of orders N1 and N2 respectively, ! if P1 has the the roots X1 through XN1, and leading coefficient ! A, then the resultant R(P1,P2) is ! ! R1(P1,P2) = A^N2 * P2(X1) * P2(X2) * ... * P2(XN1). ! ! The resultant is zero if and only if P1 and P2 have a common root. ! ! ! The determinant of the Sylvester matrix is the resultant of the ! polynomials whose coefficient vectors are X and Y. Thus, the ! polynomials have a common zero if and only if the resultant is zero. ! This fact allows the resultant to be calculated without determining ! the roots of the polynomial. ! ! ! The coefficient vector C(0:N) represents the polynomial ! ! C(N) * X^N + C(N-1) * X^(N-1) + ... + C(1) * X + C(0). ! ! Licensing: ! ! This code is distributed under the MIT license. ! ! Modified: ! ! 01 March 2001 ! ! Author: ! ! John Burkardt ! ! Reference: ! ! Jacqueline Burm, Paul Fishback, ! Period-3 Orbits Via Sylvester's Theorem and Resultants, ! Mathematics Magazine, ! Volume 74, Number 1, February 2001, pages 47-51. ! ! Input: ! ! integer N, the order of the matrix. ! ! integer NX, the dimension of X. ! ! real ( kind = rk ) X(0:NX), the first polynomial coefficient vector. ! ! integer NY, the dimension of Y. ! ! real ( kind = rk ) Y(0:NY), the second polynomial coefficient vector. ! ! Output: ! ! real ( kind = rk ) A(N,N), the matrix. ! implicit none integer, parameter :: rk = kind ( 1.0D+00 ) integer n integer nx integer ny real ( kind = rk ) a(n,n) integer i integer j real ( kind = rk ) x(0:nx) real ( kind = rk ) y(0:ny) if ( nx + ny /= 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 a(1:n,1:n) = 0.0D+00 do i = 1, nx + ny if ( i <= 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_matrix ( n, a ) !*****************************************************************************80 ! !! sylvester_kac_matrix() returns the SYLVESTER_KAC matrix. ! ! Formula: ! ! If J = I - 1 ! A(I,J) = N + 1 - I ! If J = I + 1 ! A(I,J) = I ! ! Example: ! ! N = 5, ! ! 0 1 0 0 0 ! 4 0 2 0 0 ! 0 3 0 3 0 ! 0 0 2 0 4 ! 0 0 0 1 0 ! ! Properties: ! ! A is generally not symmetric: A' /= A. ! ! A is tridiagonal. ! ! If N is odd, the eigenvalues are: ! -(N-1), -(N-3), ..., -2, 0, 2, ... (N-3), (N-1). ! ! If N is even, the eigenvalues are: ! -(N-1), -(N-3), ..., -1, +1, ..., (N-3), (N-1). ! ! Licensing: ! ! This code is distributed under the MIT license. ! ! Modified: ! ! 12 April 2015 ! ! Author: ! ! John Burkardt ! ! Reference: ! ! Paul Clement, ! A class of triple-diagonal matrices for test purposes, ! SIAM Review, ! Volume 1, 1959, pages 50-52. ! ! Olga Taussky, John Todd, ! Another Look at a Matrix of Mark Kac, ! Linear Algebra and its Applications, ! Volume 150, 1991, pages 341-360. ! ! Input: ! ! integer N, the order of the matrix. ! ! Output: ! ! real ( kind = rk ) A(N,N), the matrix. ! implicit none integer, parameter :: rk = kind ( 1.0D+00 ) integer n real ( kind = rk ) a(n,n) integer i a(1:n,1:n) = 0.0D+00 do i = 1, n - 1 a(i,i+1) = real ( i, kind = rk ) a(i+1,i) = real ( n - i, kind = rk ) end do return end subroutine sylvester_kac_determinant ( n, value ) !*****************************************************************************80 ! !! sylvester_kac_determinant() returns the determinant of the SYLVESTER_KAC matrix. ! ! Licensing: ! ! This code is distributed under the MIT license. ! ! Modified: ! ! 12 April 2015 ! ! Author: ! ! John Burkardt ! ! Input: ! ! integer N, the order of the matrix. ! ! Output: ! ! real ( kind = rk ) VALUE, the determinant. ! implicit none integer, parameter :: rk = kind ( 1.0D+00 ) integer n integer i real ( kind = rk ) value if ( mod ( n, 2 ) == 1 ) then value = 0.0D+00 else value = 1.0D+00 do i = - n + 1, n - 1, 2 value = value * real ( i, kind = rk ) end do end if return end subroutine sylvester_kac_eigen_right ( n, v ) !*****************************************************************************80 ! !! sylvester_kac_eigen_right() returns right eigenvectors of the SYLVESTER_KAC matrix. ! ! Licensing: ! ! This code is distributed under the MIT license. ! ! Modified: ! ! 14 April 2015 ! ! Author: ! ! John Burkardt ! ! Input: ! ! integer N, the order of the matrix. ! ! Output: ! ! real ( kind = rk ) V(N,N), the matrix. ! implicit none integer, parameter :: rk = kind ( 1.0D+00 ) integer n real ( kind = rk ) a(n) real ( kind = rk ) b(n-1) real ( kind = rk ) bot real ( kind = rk ) c(n-1) integer i integer j real ( kind = rk ) lam real ( kind = rk ) r8_mop real ( kind = rk ) v(n,n) do i = 1, n - 1 b(i) = real ( i, kind = rk ) c(i) = real ( n - i, kind = rk ) end do do j = 1, n lam = real ( - n - 1 + 2 * j, kind = rk ) 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 ) !*****************************************************************************80 ! !! sylvester_kac_eigenvalues() returns eigenvalues of the SYLVESTER_KAC matrix. ! ! Licensing: ! ! This code is distributed under the MIT license. ! ! Modified: ! ! 12 April 2015 ! ! Author: ! ! John Burkardt ! ! Input: ! ! integer N, the order of the matrix. ! ! Output: ! ! real ( kind = rk ) LAM(N), the eigenvalues. ! implicit none integer, parameter :: rk = kind ( 1.0D+00 ) integer n integer i integer j real ( kind = rk ) lam(n) i = 1 do j = - n + 1, n - 1, 2 lam(i) = real ( j, kind = rk ) i = i + 1 end do return end subroutine sylvester_kac_inverse ( n, a ) !*****************************************************************************80 ! !! sylvester_kac_inverse() returns the inverse of the SYLVESTER_KAC matrix. ! ! Example: ! ! N = 6: ! ! 0 1/5 0 -2/15 0 8/15 ! 1 0 0 0 0 0 ! 0 0 0 1/3 0 -4/3 ! -4/3 0 1/3 0 0 0 ! 0 0 0 0 0 1 ! 8/15 0 -2/15 0 1/5 0 ! ! Licensing: ! ! This code is distributed under the MIT license. ! ! Modified: ! ! 16 April 2015 ! ! Author: ! ! John Burkardt ! ! Input: ! ! integer N, the order of the matrix. ! ! Output: ! ! real ( kind = rk ) A(N,N), the matrix. ! implicit none integer, parameter :: rk = kind ( 1.0D+00 ) integer n real ( kind = rk ) a(n,n) integer i integer j real ( kind = rk ) p1 real ( kind = rk ) p2 if ( mod ( n, 2 ) == 1 ) then write ( *, '(a)' ) ' ' write ( *, '(a)' ) 'SYLVESTER_KAC_INVERSE - Fatal error!' write ( *, '(a)' ) ' The matrix is singular for odd N.' stop 1 end if a(1:n,1:n) = 0.0D+00 do i = 1, n if ( mod ( i, 2 ) == 1 ) then p1 = 1.0D+00 p2 = 1.0D+00 do j = i, n - 1, 2 if ( j == i ) then p1 = p1 / real ( n - j, kind = rk ) p2 = p2 / real ( j, kind = rk ) else p1 = - p1 * real ( j - 1, kind = rk ) / real ( n - j, kind = rk ) p2 = - p2 * real ( n - j + 1, kind = rk ) / real ( j, kind = rk ) end if a(i,j+1) = p1 a(j+1,i) = p2 end do end if end do return end subroutine symmetric_random_matrix ( n, d, key, a ) !*****************************************************************************80 ! !! symmetric_random_matrix() returns the symmetric_random matrix. ! ! Discussion: ! ! symmetric_random is a random symmetric matrix. ! ! The user is able to specify the eigenvalues. ! ! Properties: ! ! A is symmetric: A' = A. ! ! The eigenvalues of A will be real. ! ! Licensing: ! ! This code is distributed under the MIT license. ! ! Modified: ! ! 10 March 2015 ! ! Author: ! ! John Burkardt ! ! Input: ! ! integer N, the order of the matrix. ! ! real ( kind = rk ) D(N), the desired eigenvalues for the matrix. ! ! integer KEY, a positive integer that selects the data. ! ! Output: ! ! real ( kind = rk ) A(N,N), the matrix. ! implicit none integer, parameter :: rk = kind ( 1.0D+00 ) integer n real ( kind = rk ) a(n,n) real ( kind = rk ) d(n) integer i integer j integer k integer key real ( kind = rk ) q(n,n) integer seed ! ! Get a random orthogonal matrix Q. ! seed = key call orthogonal_random_matrix ( n, seed, q ) ! ! Set A = Q * Lambda * Q'. ! 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 symmetric_random_determinant ( n, d, key, value ) !*****************************************************************************80 ! !! symmetric_random_determinant() returns the determinant of the symmetric_random matrix. ! ! Licensing: ! ! This code is distributed under the MIT license. ! ! Modified: ! ! 10 March 2015 ! ! Author: ! ! John Burkardt ! ! Input: ! ! integer N, the order of the matrix. ! ! real ( kind = rk ) D(N), the desired eigenvalues for the matrix. ! ! integer KEY, a positive integer that selects the data. ! ! Output: ! ! real ( kind = rk ) VALUE, the determinant. ! implicit none integer, parameter :: rk = kind ( 1.0D+00 ) integer n real ( kind = rk ) d(n) integer key real ( kind = rk ) value call i4_fake_use ( key ) value = product ( d(1:n) ) return end subroutine symmetric_random_eigen_left ( n, d, key, v ) !*****************************************************************************80 ! !! symmetric_random_eigen_left(): left eigenvectors of the symmetric_random matrix. ! ! Discussion: ! ! The user is able to specify the eigenvalues. ! ! Licensing: ! ! This code is distributed under the MIT license. ! ! Modified: ! ! 10 March 2015 ! ! Author: ! ! John Burkardt ! ! Input: ! ! integer N, the order of the matrix. ! ! real ( kind = rk ) D(N), the desired eigenvalues for the matrix. ! ! integer KEY, a positive integer that selects the data. ! ! Output: ! ! real ( kind = rk ) V(N,N), the matrix. ! implicit none integer, parameter :: rk = kind ( 1.0D+00 ) integer n real ( kind = rk ) d(n) integer i integer j integer key integer seed real ( kind = rk ) t real ( kind = rk ) v(n,n) call r8_fake_use ( d(1) ) ! ! Get a random orthogonal matrix. ! seed = key call orthogonal_random_matrix ( n, seed, v ) ! ! Transpose. ! 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 symmetric_random_eigen_right ( n, d, key, v ) !*****************************************************************************80 ! !! symmetric_random_eigen_right(): right eigenvectors of the symmetric_random matrix. ! ! Discussion: ! ! The user is able to specify the eigenvalues. ! ! Licensing: ! ! This code is distributed under the MIT license. ! ! Modified: ! ! 10 March 2015 ! ! Author: ! ! John Burkardt ! ! Input: ! ! integer N, the order of the matrix. ! ! real ( kind = rk ) D(N), the desired eigenvalues for the matrix. ! ! integer KEY, a positive integer that selects the data. ! ! Output: ! ! real ( kind = rk ) V(N,N), the matrix. ! implicit none integer, parameter :: rk = kind ( 1.0D+00 ) integer n real ( kind = rk ) d(n) integer key integer seed real ( kind = rk ) v(n,n) call r8_fake_use ( d(1) ) ! ! Get a random orthogonal matrix Q. ! seed = key call orthogonal_random_matrix ( n, seed, v ) return end subroutine symmetric_random_eigenvalues ( n, d, key, lambda ) !*****************************************************************************80 ! !! symmetric_random_eigenvalues() returns the eigenvalues of the symmetric_random matrix. ! ! Licensing: ! ! This code is distributed under the MIT license. ! ! Modified: ! ! 10 March 2015 ! ! Author: ! ! John Burkardt ! ! Input: ! ! integer N, the order of the matrix. ! ! real ( kind = rk ) D(N), the desired eigenvalues for the matrix. ! ! integer KEY, a positive integer that selects the data. ! ! Output: ! ! real ( kind = rk ) LAMBDA(N), the eigenvalues. ! implicit none integer, parameter :: rk = kind ( 1.0D+00 ) integer n real ( kind = rk ) d(n) integer key real ( kind = rk ) lambda(n) call i4_fake_use ( key ) lambda(1:n) = d(1:n) return end subroutine symmetric_random_inverse ( n, d, key, a ) !*****************************************************************************80 ! !! symmetric_random_inverse() returns the inverse of the symmetric_random matrix. ! ! Licensing: ! ! This code is distributed under the MIT license. ! ! Modified: ! ! 15 August 2008 ! ! Author: ! ! John Burkardt ! ! Input: ! ! integer N, the order of the matrix. ! ! real ( kind = rk ) D(N), the desired eigenvalues for the matrix. ! ! integer KEY, a positive integer that selects the data. ! ! Output: ! ! real ( kind = rk ) A(N,N), the matrix. ! implicit none integer, parameter :: rk = kind ( 1.0D+00 ) integer n real ( kind = rk ) a(n,n) real ( kind = rk ) d(n) integer i integer j integer k integer key real ( kind = rk ) q(n,n) integer seed ! ! Get a random orthogonal matrix Q. ! seed = key call orthogonal_random_matrix ( n, seed, q ) ! ! Set A = Q * Lambda * Q'. ! 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 ( ) !*****************************************************************************80 ! !! timestamp() prints the current YMDHMS date as a time stamp. ! ! Example: ! ! 31 May 2001 9:45:54.872 AM ! ! Licensing: ! ! This code is distributed under the MIT license. ! ! Modified: ! ! 18 May 2013 ! ! Author: ! ! John Burkardt ! implicit none integer, parameter :: rk = kind ( 1.0D+00 ) character ( len = 8 ) ampm integer d integer h integer m integer mm character ( len = 9 ), parameter, dimension(12) :: month = (/ & 'January ', 'February ', 'March ', 'April ', & 'May ', 'June ', 'July ', 'August ', & 'September', 'October ', 'November ', 'December ' /) integer n integer s integer values(8) integer y call date_and_time ( values = values ) y = values(1) m = values(2) d = values(3) h = values(5) n = values(6) s = values(7) mm = values(8) if ( h < 12 ) then ampm = 'AM' else if ( h == 12 ) then if ( n == 0 .and. s == 0 ) then ampm = 'Noon' else ampm = 'PM' end if else h = h - 12 if ( h < 12 ) then ampm = 'PM' else if ( h == 12 ) then if ( n == 0 .and. s == 0 ) then ampm = 'Midnight' else ampm = 'AM' end if end if end if write ( *, '(i2,1x,a,1x,i4,2x,i2,a1,i2.2,a1,i2.2,a1,i3.3,1x,a)' ) & d, trim ( month(m) ), y, h, ':', n, ':', s, '.', mm, trim ( ampm ) return end subroutine toeplitz_matrix ( n, x, a ) !*****************************************************************************80 ! !! toeplitz_matrix() returns a TOEPLITZ matrix. ! ! Formula: ! ! A(I,J) = X(N+J-I) ! ! Example: ! ! N = 5, X = ( 1, 2, 3, 4, 5, 6, 7, 8, 9 ) ! ! 5 6 7 8 9 ! 4 5 6 7 8 ! 3 4 5 6 7 ! 2 3 4 5 6 ! 1 2 3 4 5 ! ! Properties: ! ! A is generally not symmetric: A' /= A. ! ! A is persymmetric: A(I,J) = A(N+1-J,N+1-I). ! ! A is Toeplitz: constant along diagonals. ! ! Licensing: ! ! This code is distributed under the MIT license. ! ! Modified: ! ! 15 April 1999 ! ! Author: ! ! John Burkardt ! ! Input: ! ! integer N, the order of the matrix. ! ! real ( kind = rk ) X(2*N-1), the diagonals of A, with X(1) being ! the A(N,1) entry, X(N) being the main diagonal value of A, ! and X(2*N-1) being the A(1,N) entry. ! ! Output: ! ! real ( kind = rk ) A(N,N), the matrix. ! implicit none integer, parameter :: rk = kind ( 1.0D+00 ) integer n real ( kind = rk ) a(n,n) integer i real ( kind = rk ) x(2*n-1) do i = 1, n a(i,1:n) = x(n-i+1:n-i+n) end do return end subroutine toeplitz_5diag_matrix ( n, d1, d2, d3, d4, d5, a ) !*****************************************************************************80 ! !! toeplitz_5diag_matrix() returns the TOEPLITZ_5DIAG matrix. ! ! Discussion: ! ! The matrix is a pentadiagonal Toeplitz matrix. ! ! Formula: ! ! if ( I - J == 2 ) then ! A(I,J) = D1 ! else if ( I - J == 1 ) then ! A(I,J) = D2 ! else if ( I - J == 0 ) then ! A(I,J) = D3 ! else if ( I - J == -1 ) then ! A(I,J) = D4 ! else if ( I - J == -2 ) then ! A(I,J) = D5 ! else ! A(I,J) = 0.0D+00 ! ! Example: ! ! N = 5, D1 = 1, D2 = -10, D3 = 0, D4 = 10, D5 = 1 ! ! 0 10 1 . . ! -10 0 10 1 . ! 1 -10 0 10 1 ! . 1 -10 0 10 ! . . 1 -10 0 ! ! Properties: ! ! A is generally not symmetric: A' /= A. ! ! A is Toeplitz: constant along diagonals. ! ! A is banded, with bandwidth 5. ! ! A is persymmetric: A(I,J) = A(N+1-J,N+1-I). ! ! The special data D1 = 1, D2 = -10, D3 = 0, D4 = 10, D5 = 1 corresponds ! to a matrix of Rutishauser. ! ! The matrix has eigenvalues lying approximately on the complex line ! segment 2 * cos ( 2 * t ) + 20 * I * sin ( t ). ! ! The family of matrices is nested as a function of N. ! ! Licensing: ! ! This code is distributed under the MIT license. ! ! Modified: ! ! 15 April 1999 ! ! Author: ! ! John Burkardt ! ! Reference: ! ! RM Beam, RF Warming, ! The asymptotic spectra of banded Toeplitz and quasi-Toeplitz matrices, ! SIAM Journal on Scientific and Statistical Computing, ! Volume 14, Number 4, 1993, pages 971-1006. ! ! Heinz Rutishauser, ! On test matrices, ! Programmation en Mathematiques Numeriques, ! Centre National de la Recherche Scientifique, ! 1966, pages 349-365. ! ! Input: ! ! integer N, the order of the matrix. ! N should be at least 3. ! ! real ( kind = rk ) D1, D2, D3, D4, D5, values that define the ! nonzero diagonals of the matrix. ! ! Output: ! ! real ( kind = rk ) A(N,N), the matrix. ! implicit none integer, parameter :: rk = kind ( 1.0D+00 ) integer n real ( kind = rk ) a(n,n) real ( kind = rk ) d1 real ( kind = rk ) d2 real ( kind = rk ) d3 real ( kind = rk ) d4 real ( kind = rk ) d5 integer i integer j do j = 1, n do i = 1, n if ( i - j == 2 ) then a(i,j) = d1 else if ( i - j == 1 ) then a(i,j) = d2 else if ( i - j == 0 ) then a(i,j) = d3 else if ( i - j == -1 ) then a(i,j) = d4 else if ( i - j == -2 ) then a(i,j) = d5 else a(i,j) = 0.0D+00 end if end do end do return end subroutine toeplitz_5s_matrix ( row_num, col_num, alpha, beta, gamma, n, a ) !*****************************************************************************80 ! !! toeplitz_5s_matrix() returns the TOEPLITZ_5S matrix. ! ! Discussion: ! ! The matrix is a block matrix, symmetric, ! of order N = ROW_NUM * COL_NUM, with 5 constant diagonals. ! ! Formula: ! ! if ( J = I ) ! A(I,J) = ALPHA ! else if ( J = I + 1 or J = I - 1 ) ! A(I,J) = BETA ! else if ( J = I + COL_NUM or J = I - COL_NUM ) ! A(I,J) = GAMMA ! else ! A(I,J) = 0 ! ! Example: ! ! ROW_NUM = 2, COL_NUM = 3, ! ALPHA = 6, BETA = 4, GAMMA = 2 ! ! 6 4 0 | 2 0 0 ! 4 6 4 | 0 2 0 ! 0 4 6 | 0 0 2 ! ------+------ ! 2 0 0 | 6 4 0 ! 0 2 0 | 4 6 4 ! 0 0 2 | 0 4 6 ! ! Properties: ! ! A is symmetric: A' = A. ! ! Because A is symmetric, it is normal. ! ! Because A is normal, it is diagonalizable. ! ! A is Toeplitz: constant along diagonals. ! ! A has just 5 nonzero diagonals. ! ! A is persymmetric: A(I,J) = A(N+1-J,N+1-I). ! ! A is "block tridiagonal". ! ! A has eigenvalues ! ! LAMBDA(I,J) = ALPHA + 2 * BETA * COS(I*PI/(COL_NUM+1)) ! + 2 * GAMMA * COS(J*PI/(ROW_NUM+1)), ! I = 1 to COL_NUM, J = 1 to ROW_NUM ! ! If ALPHA = -4, BETA = GAMMA = 1, the matrix is associated with ! approximations to the Laplacian operator on a rectangular ! ROW_NUM by COL_NUM grid of equally spaced points. See routine POISSON. ! ! Licensing: ! ! This code is distributed under the MIT license. ! ! Modified: ! ! 27 October 2007 ! ! Author: ! ! John Burkardt ! ! Reference: ! ! Robert Gregory, David Karney, ! A Collection of Matrices for Testing Computational Algorithms, ! Wiley, 1969, ! ISBN: 0882756494, ! LC: QA263.68 ! ! Input: ! ! integer ROW_NUM, the block order of the matrix. ! ! integer COL_NUM, the order of the subblocks. ! ! real ( kind = rk ) ALPHA, BETA, GAMMA, the scalars. ! ! Output: ! ! integer N, the order of the matrix. ! ! real ( kind = rk ) A(ROW_NUM*COL_NUM,ROW_NUM*COL_NUM), ! the matrix. ! implicit none integer, parameter :: rk = kind ( 1.0D+00 ) integer col_num integer row_num real ( kind = rk ) a(row_num*col_num,row_num*col_num) real ( kind = rk ) alpha real ( kind = rk ) beta real ( kind = rk ) gamma integer i integer j integer n n = row_num * col_num do j = 1, n do i = 1, n if ( j == i ) then a(i,j) = alpha else if ( j == i + 1 .or. j == i - 1 ) then a(i,j) = beta else if ( j == i + col_num .or. j == 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, value ) !*****************************************************************************80 ! !! toeplitz_5s_determinant() returns the determinant of the TOEPLITZ_5S matrix. ! ! Licensing: ! ! This code is distributed under the MIT license. ! ! Modified: ! ! 18 March 2015 ! ! Author: ! ! John Burkardt ! ! Input: ! ! integer ROW_NUM, the block order of A. ! ! integer COL_NUM, the order of the subblocks of A. ! ! real ( kind = rk ) ALPHA, BETA, GAMMA, the scalars that define A. ! ! Output: ! ! real ( kind = rk ) VALUE, the determinant. ! implicit none integer, parameter :: rk = kind ( 1.0D+00 ) integer col_num integer row_num real ( kind = rk ) alpha real ( kind = rk ) beta real ( kind = rk ) gamma real ( kind = rk ) lambda(row_num*col_num) real ( kind = rk ) value value = 1.0D+00 call toeplitz_5s_eigenvalues ( row_num, col_num, alpha, beta, & gamma, lambda ) value = product ( lambda(1:row_num*col_num) ) return end subroutine toeplitz_5s_eigenvalues ( row_num, col_num, alpha, beta, & gamma, lambda ) !*****************************************************************************80 ! !! toeplitz_5s_eigenvalues() returns the eigenvalues of the TOEPLITZ_5S matrix. ! ! Licensing: ! ! This code is distributed under the MIT license. ! ! Modified: ! ! 27 October 2007 ! ! Author: ! ! John Burkardt ! ! Reference: ! ! Robert Gregory, David Karney, ! A Collection of Matrices for Testing Computational Algorithms, ! Wiley, 1969, ! ISBN: 0882756494, ! LC: QA263.68 ! ! Input: ! ! integer ROW_NUM, the block order of A. ! ! integer COL_NUM, the order of the subblocks of A. ! ! real ( kind = rk ) ALPHA, BETA, GAMMA, the scalars that define A. ! ! Output: ! ! real ( kind = rk ) LAMBDA(ROW_NUM*COL_NUM), the eigenvalues. ! implicit none integer, parameter :: rk = kind ( 1.0D+00 ) integer col_num integer row_num real ( kind = rk ) alpha real ( kind = rk ) angle_i real ( kind = rk ) angle_j real ( kind = rk ) beta real ( kind = rk ) gamma integer i integer j integer k real ( kind = rk ) lambda(row_num*col_num) real ( kind = rk ), parameter :: r8_pi = 3.141592653589793D+00 k = 0 do i = 1, col_num angle_i = r8_pi * real ( i, kind = rk ) / real ( col_num + 1, kind = rk ) do j = 1, row_num angle_j = r8_pi * real ( j, kind = rk ) / real ( row_num + 1, kind = rk ) 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_spd_matrix ( m, n, x, y, a ) !*****************************************************************************80 ! !! toeplitz_spd_matrix() returns the TOEPLITZ_SPD matrix. ! ! Discussion: ! ! The matrix is a Toeplitz symmetric positive definite matrix. ! ! Formula: ! ! A(I,J) = sum ( 1 <= K <= M ) Y(K) * cos ( 2 * PI * X(K) * (I-J) ) ! ! Example: ! ! N = 5, M = 5, ! X = ( -0.0625, - 0.03125, 0.0, 0.03125, 0.0625 ), ! Y = ( 0.2, 0.2, 0.2, 0.2, 0.2) ! ! 1.000000 0.961866 0.852395 0.685661 0.482843 ! 0.961866 1.000000 0.961866 0.852395 0.685661 ! 0.852395 0.961866 1.000000 0.961866 0.852395 ! 0.685661 0.852395 0.961866 1.000000 0.961866 ! 0.482843 0.685661 0.852395 0.961866 1.000000 ! ! Properties: ! ! A is symmetric: A' = A. ! ! Because A is symmetric, it is normal. ! ! Because A is normal, it is diagonalizable. ! ! A is Toeplitz: constant along diagonals. ! ! A is persymmetric: A(I,J) = A(N+1-J,N+1-I). ! ! A is positive definite or positive semi-definite, depending on ! the values of X. ! ! Licensing: ! ! This code is distributed under the MIT license. ! ! Modified: ! ! 15 April 1999 ! ! Author: ! ! John Burkardt ! ! Reference: ! ! George Cybenko, Charles Van Loan, ! Computing the minimum eigenvalue of a symmetric positive definite ! Toeplitz matrix, ! SIAM Journal on Scientific and Statistical Computing, ! Volume 7, 1986, pages 123-131. ! ! Input: ! ! integer M, the number of terms of X and Y. ! ! integer N, the order of the matrix. ! ! real ( kind = rk ) X(M), used to define the matrix. ! ! real ( kind = rk ) Y(M), a set of positive weights ! used to define the matrix. ! ! Output: ! ! real ( kind = rk ) A(N,N), the matrix. ! implicit none integer, parameter :: rk = kind ( 1.0D+00 ) integer m integer n real ( kind = rk ) a(n,n) real ( kind = rk ) angle integer i integer j integer k real ( kind = rk ), parameter :: r8_pi = 3.141592653589793D+00 real ( kind = rk ) x(m) real ( kind = rk ) 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) * real ( i - j, kind = rk ) a(i,j) = a(i,j) + y(k) * cos ( angle ) end do end do end do return end subroutine tournament_random_matrix ( n, seed, a ) !*****************************************************************************80 ! !! tournament_random_matrix() returns the TOURNAMENT_RANDOM matrix. ! ! Example: ! ! N = 5 ! ! 0 -1 1 1 -1 ! 1 0 1 1 1 ! -1 -1 0 1 -1 ! -1 -1 -1 0 -1 ! 1 -1 1 1 0 ! ! Properties: ! ! A is generally not symmetric: A' /= A. ! ! A is antisymmetric: A' = -A. ! ! Because A is antisymmetric, it is normal. ! ! Because A is normal, it is diagonalizable. ! ! The diagonal of A is zero. ! ! All the eigenvalues of A are imaginary, or zero. ! ! If N is odd, then A is singular. ! ! If N is even, then A is nonsingular. ! ! Licensing: ! ! This code is distributed under the MIT license. ! ! Modified: ! ! 06 July 2011 ! ! Author: ! ! John Burkardt ! ! Input: ! ! integer N, the order of the matrix. ! ! integer SEED, a seed for the random number generator. ! ! Output: ! ! real ( kind = rk ) A(N,N), the matrix. ! ! integer SEED, an updated seed. ! implicit none integer, parameter :: rk = kind ( 1.0D+00 ) integer n real ( kind = rk ) a(n,n) integer i integer j integer seed 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 < 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, seed, value ) !*****************************************************************************80 ! !! tournament_random_determinant() returns determinant of the TOURNAMENT_RANDOM matrix. ! ! Licensing: ! ! This code is distributed under the MIT license. ! ! Modified: ! ! 06 July 2011 ! ! Author: ! ! John Burkardt ! ! Input: ! ! integer N, the order of the matrix. ! ! integer SEED, a seed for the random ! number generator. ! ! Output: ! ! real ( kind = rk ) VALUE, the determinant. ! implicit none integer, parameter :: rk = kind ( 1.0D+00 ) integer n integer seed real ( kind = rk ) value call i4_fake_use ( n ) call i4_fake_use ( seed ) value = 0.0D+00 return end subroutine transition_random_matrix ( n, seed, a ) !*****************************************************************************80 ! !! transition_random_matrix() returns the TRANSITION_RANDOM matrix. ! ! Discussion: ! ! A transition matrix is distinguished by two properties: ! ! * All matrix entries are nonnegative; ! * The sum of the entries in each column is 1. ! ! Example: ! ! N = 4 ! ! 1/10 1 5/10 2/10 2/10 ! 2/10 0 2/10 2/10 2/10 ! 3/10 0 3/10 2/10 2/10 ! 4/10 0 0/10 4/10 4/10 ! ! Properties: ! ! A is generally not symmetric: A' /= A. ! ! A is nonnegative. ! ! 0 <= A(I,J) <= 1.0D+00 for every I and J. ! ! The sum of the entries in each column of A is 1. ! ! Because A has a constant column sum of 1, ! it has an eigenvalue of 1, ! and it has a left eigenvector of (1,1,1,...,1). ! ! All the eigenvalues of A have modulus no greater than 1. ! ! Licensing: ! ! This code is distributed under the MIT license. ! ! Modified: ! ! 07 July 2000 ! ! Author: ! ! John Burkardt ! ! Input: ! ! integer N, the order of the matrix. ! ! integer SEED, a seed for the random number generator. ! ! Output: ! ! real ( kind = rk ) A(N,N), the matrix. ! ! integer SEED, an updated seed. ! implicit none integer, parameter :: rk = kind ( 1.0D+00 ) integer n real ( kind = rk ) a(n,n) real ( kind = rk ) col_sum integer j integer seed call r8mat_uniform_01 ( n, n, seed, a ) do j = 1, n col_sum = sum ( a(1:n,j) ) a(1:n,j) = a(1:n,j) / col_sum end do return end subroutine trench_matrix ( alpha, m, n, a ) !*****************************************************************************80 ! !! trench_matrix() returns the TRENCH matrix. ! ! Discussion: ! ! Using a small value of ALPHA causes every third leading principal ! submatrix to be nearly singular. The standard Levinson algorithm ! for fast solution of Toeplitz matrices will perform poorly if ! the leading principal submatrices are poorly conditioned in this way, ! although the full matrix may have a good condition number. ! ! A is related to the KMS matrix. ! ! Formula: ! ! if I == J ! A(I,J) = ALPHA ! else ! A(I,J) = (1/2)^( abs ( I - J ) - 1 ) ! ! Example: ! ! ALPHA = 0.01, N = 5 ! ! 0.01 1 1/2 1/4 1/8 ! 1 0.01 1 1/2 1/4 ! 1/2 1 0.01 1 1/2 ! 1/4 1/2 1 0.01 1 ! 1/8 1/4 1/2 1 0.01 ! ! Properties: ! ! A is Toeplitz: constant along diagonals. ! ! A is symmetric: A' = A. ! ! Because A is symmetric, it is normal. ! ! Because A is normal, it is diagonalizable. ! ! A is persymmetric: A(I,J) = A(N+1-J,N+1-I). ! ! A is centrosymmetric: A(I,J) = A(N+1-I,N+1-J). ! ! If ALPHA = 0, then every third leading principal submatrix ! is exactly singular. ! ! The family of matrices is nested as a function of N. ! ! Licensing: ! ! This code is distributed under the MIT license. ! ! Modified: ! ! 20 May 2002 ! ! Author: ! ! John Burkardt ! ! Reference: ! ! Per Christian Hansen, Tony Chan, ! FORTRAN Subroutines for General Toeplitz Systems, ! ACM Transactions on Mathematical Software, ! Volume 18, Number 3, September 1992, pages 256-273. ! ! William Trench, ! Numerical solution of the eigenvalue problem for Hermitian ! Toeplitz matrices, ! SIAM Journal on Matrix Analysis and Applications, ! Volume 10, 1989, pages 135-146. ! ! Input: ! ! real ( kind = rk ) ALPHA, the scalar that defines A. For testing ! Toeplitz solvers, ALPHA should be a small multiple of the ! machine precision. ! ! integer M, N, the order of the matrix. ! ! Output: ! ! real ( kind = rk ) A(M,N), the matrix. ! implicit none integer, parameter :: rk = kind ( 1.0D+00 ) integer m integer n real ( kind = rk ) a(m,n) real ( kind = rk ) alpha integer i integer j do j = 1, n do i = 1, m if ( i == j ) then a(i,j) = alpha else a(i,j) = 1.0D+00 / real ( 2 ** ( abs ( i - j ) - 1 ), kind = rk ) end if end do end do return end subroutine tri_l1_inverse ( n, a, b ) !*****************************************************************************80 ! !! tri_l1_inverse() returns the inverse of a unit lower triangular R8MAT. ! ! Discussion: ! ! An R8MAT is an array of R8 values. ! ! A unit lower triangular matrix is a matrix with only 1's on the main ! diagonal, and only 0's above the main diagonal. ! ! The inverse of a unit lower triangular matrix is also ! a unit lower triangular matrix. ! ! This routine can invert a matrix in place, that is, with no extra ! storage. If the matrix is stored in A, then the call ! ! call r8mat_l1_inverse ( n, a, a ) ! ! will result in A being overwritten by its inverse. ! ! Licensing: ! ! This code is distributed under the MIT license. ! ! Modified: ! ! 05 December 2004 ! ! Author: ! ! John Burkardt ! ! Reference: ! ! Albert Nijenhuis, Herbert Wilf, ! Combinatorial Algorithms, ! Academic Press, 1978, second edition, ! ISBN 0-12-519260-6. ! ! Input: ! ! integer N, the order of the matrix. ! ! real ( kind = rk ) A(N,N), the unit lower triangular matrix. ! ! Output: ! ! real ( kind = rk ) B(N,N), the inverse matrix. ! implicit none integer, parameter :: rk = kind ( 1.0D+00 ) integer n real ( kind = rk ) a(n,n) real ( kind = rk ) b(n,n) integer i integer j do j = 1, n do i = 1, n if ( i < j ) then b(i,j) = 0.0D+00 else if ( j == i ) then b(i,j) = 1.0D+00 else b(i,j) = - dot_product ( a(i,1:i-1), b(1:i-1,j) ) end if end do end do return end subroutine tri_u_inverse ( n, a, b ) !*****************************************************************************80 ! !! tri_u_inverse() returns the inverse of an upper triangular R8MAT. ! ! Discussion: ! ! An R8MAT is an array of R8 values. ! ! An upper triangular matrix is a matrix whose only nonzero entries ! occur on or above the diagonal. ! ! The inverse of an upper triangular matrix is an upper triangular matrix. ! ! Licensing: ! ! This code is distributed under the MIT license. ! ! Modified: ! ! 11 December 2004 ! ! Author: ! ! Original FORTRAN77 version by Albert Nijenhuis, Herbert Wilf. ! FORTRAN90 version by John Burkardt. ! ! Reference: ! ! Albert Nijenhuis, Herbert Wilf, ! Combinatorial Algorithms, ! Academic Press, 1978, second edition, ! ISBN 0-12-519260-6. ! ! Input: ! ! integer N, the order of the matrix. ! ! real ( kind = rk ) A(N,N), the upper triangular matrix. ! ! Output: ! ! real ( kind = rk ) B(N,N), the inverse matrix. ! implicit none integer, parameter :: rk = kind ( 1.0D+00 ) integer n real ( kind = rk ) a(n,n) real ( kind = rk ) b(n,n) integer i integer j do j = n, 1, -1 do i = n, 1, -1 if ( j < i ) then b(i,j) = 0.0D+00 else if ( i == j ) then b(i,j) = 1.0D+00 / a(i,j) else b(i,j) = - dot_product ( a(i,i+1:j), b(i+1:j,j) ) / a(i,i) end if end do end do return end subroutine tri_upper_matrix ( alpha, n, a ) !*****************************************************************************80 ! !! tri_upper_matrix() returns the tri_upper matrix. ! ! Discussion: ! ! This matrix is known as the Wilkinson upper triangular matrix. ! ! Formula: ! ! if ( I = J ) ! A(I,J) = 1 ! if ( I < J ) ! A(I,J) = ALPHA ! else ! A(I,J) = 0 ! ! Example: ! ! ALPHA = 3, N = 5 ! ! 1 3 3 3 3 ! 0 1 3 3 3 ! 0 0 1 3 3 ! 0 0 0 1 3 ! 0 0 0 0 1 ! ! Properties: ! ! A is generally not symmetric: A' /= A. ! ! A is nonsingular. ! ! A is upper triangular. ! ! det ( A ) = 1. ! ! A is unimodular. ! ! LAMBDA(1:N) = 1. ! ! A is Toeplitz: constant along diagonals. ! ! A is persymmetric: A(I,J) = A(N+1-J,N+1-I). ! ! The family of matrices is nested as a function of N. ! ! Licensing: ! ! This code is distributed under the MIT license. ! ! Modified: ! ! 15 April 1999 ! ! Author: ! ! John Burkardt ! ! Input: ! ! real ( kind = rk ) ALPHA, value used on the superdiagonals. ! ! integer N, the order of the matrix. ! ! Output: ! ! real ( kind = rk ) A(N,N), the matrix. ! implicit none integer, parameter :: rk = kind ( 1.0D+00 ) integer n real ( kind = rk ) a(n,n) real ( kind = rk ) alpha integer i integer j do j = 1, n do i = 1, n if ( i == j ) then a(i,j) = 1.0D+00 else if ( i < 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 ) !*****************************************************************************80 ! !! tri_upper_condition() returns the L1 condition of the tri_upper matrix. ! ! Licensing: ! ! This code is distributed under the MIT license. ! ! Modified: ! ! 18 January 2015 ! ! Author: ! ! John Burkardt ! ! Input: ! ! real ( kind = rk ) ALPHA, value used on the superdiagonals. ! ! integer N, the order of the matrix. ! ! Output: ! ! real ( kind = rk ) COND, the L1 condition. ! implicit none integer, parameter :: rk = kind ( 1.0D+00 ) real ( kind = rk ) a_norm real ( kind = rk ) alpha real ( kind = rk ) b_norm real ( kind = rk ) cond integer n a_norm = real ( n - 1, kind = rk ) * 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, value ) !*****************************************************************************80 ! !! tri_upper_determinant() returns the determinant of the tri_upper matrix. ! ! Licensing: ! ! This code is distributed under the MIT license. ! ! Modified: ! ! 24 October 2007 ! ! Author: ! ! John Burkardt ! ! Input: ! ! real ( kind = rk ) ALPHA, value used on the superdiagonals. ! ! integer N, the order of the matrix. ! ! Output: ! ! real ( kind = rk ) VALUE, the determinant. ! implicit none integer, parameter :: rk = kind ( 1.0D+00 ) real ( kind = rk ) alpha integer n real ( kind = rk ) value call r8_fake_use ( alpha ) call i4_fake_use ( n ) value = 1.0D+00 return end subroutine tri_upper_eigenvalues ( n, lambda ) !*****************************************************************************80 ! !! tri_upper_eigenvalues() returns the eigenvalues of the tri_upper matrix. ! ! Licensing: ! ! This code is distributed under the MIT license. ! ! Modified: ! ! 19 October 2007 ! ! Author: ! ! John Burkardt ! ! Input: ! ! integer N, the order of the matrix. ! ! Output: ! ! real ( kind = rk ) LAMBDA(N), the eigenvalues. ! implicit none integer, parameter :: rk = kind ( 1.0D+00 ) integer n real ( kind = rk ) lambda(n) lambda(1:n) = 1.0D+00 return end subroutine tri_upper_inverse ( alpha, n, a ) !*****************************************************************************80 ! !! tri_upper_inverse() returns the inverse of the tri_upper matrix. ! ! Formula: ! ! if ( I = J ) then ! A(I,J) = 1 ! else if ( I = J - 1 ) then ! A(I,J) = -ALPHA ! else if ( I < J ) then ! A(I,J) = - ALPHA * ( 1-ALPHA)^(J-I-1) ! else ! A(I,J) = 0 ! ! Example: ! ! ALPHA = 3, N = 5 ! ! 1 -3 6 -12 24 ! 0 1 -3 6 -12 ! 0 0 1 -3 6 ! 0 0 0 1 -3 ! 0 0 0 0 1 ! ! Properties: ! ! A is generally not symmetric: A' /= A. ! ! A is nonsingular. ! ! A is upper triangular. ! ! A is Toeplitz: constant along diagonals. ! ! A is persymmetric: A(I,J) = A(N+1-J,N+1-I). ! ! det ( A ) = 1. ! ! A is unimodular. ! ! LAMBDA(1:N) = 1. ! ! Licensing: ! ! This code is distributed under the MIT license. ! ! Modified: ! ! 15 April 1999 ! ! Author: ! ! John Burkardt ! ! Input: ! ! real ( kind = rk ) ALPHA, value used on the superdiagonals. ! ! integer N, the order of the matrix. ! ! Output: ! ! real ( kind = rk ) A(N,N), the matrix. ! implicit none integer, parameter :: rk = kind ( 1.0D+00 ) integer n real ( kind = rk ) a(n,n) real ( kind = rk ) alpha integer i integer j do j = 1, n do i = 1, n if ( i == j ) then a(i,j) = 1.0D+00 else if ( i == j - 1 ) then a(i,j) = - alpha else if ( i < 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 tribonacci_roots ( alpha, beta, gamma ) !*****************************************************************************80 ! !! tribonacci_roots() returns the Tribonacci roots. ! ! Discussion: ! ! The Nth Tribonacci number is defined by: ! T(N) = T(N-1) + T(N-2) + T(N-3) ! with ! T(1) = 0, T(2) = 0, T(3) = 1. ! ! The related polynomial equation ! x^3 - x^2 - x - 1 = 0 ! ! ALPHA, BETA, and GAMMA are the roots of this equation. ! ! Licensing: ! ! This code is distributed under the MIT license. ! ! Modified: ! ! 14 May 2021 ! ! Author: ! ! John Burkardt ! ! Reference: ! ! W R Spickerman, ! Binet's formula for the Tribonacci sequence, ! Fibonacci Quarterly, ! Volume 20, Number 2, pages 118-120, May 1982. ! ! Output: ! ! real ( kind = rk ) ALPHA, ! complex ( kind = ck ) BETA, ! complex ( kind = ck ) GAMMA, the roots. ! implicit none integer, parameter :: rk = kind ( 1.0D+00 ) integer, parameter :: ck = kind ( ( 1.0D+00, 1.0D+00 ) ) real ( kind = rk ) a real ( kind = rk ) alpha real ( kind = rk ) b complex ( kind = ck ) beta complex ( kind = ck ) gamma real ( kind = rk ) r8_cube_root real ( kind = rk ) rho real ( kind = rk ) tau rho = r8_cube_root ( 19.0D+00 + 3.0D+00 * sqrt ( 33.0D+00 ) ) tau = r8_cube_root ( 19.0D+00 - 3.0D+00 * sqrt ( 33.0D+00 ) ) a = ( 2.0D+00 - rho - tau ) / 6.0D+00 b = sqrt ( 3.0D+00 ) * ( rho - tau ) / 6.0D+00 alpha = ( 1.0D+00 + rho + tau ) / 3.0D+00 beta = cmplx ( a, b, kind = ck ) gamma = cmplx ( a, - b, kind = ck ) return end subroutine tribonacci2_determinant ( n, determ ) !*****************************************************************************80 ! !! tribonacci2_determinant() returns the determinant of the TRIBONACCI2 matrix. ! ! Licensing: ! ! This code is distributed under the MIT license. ! ! Modified: ! ! 14 May 2021 ! ! Author: ! ! John Burkardt ! ! Input: ! ! integer N, the order of the matrix. ! ! Output: ! ! real ( kind = rk ) DETERM, the determinant. ! implicit none integer, parameter :: rk = kind ( 1.0D+00 ) real ( kind = rk ) determ integer n if ( n <= 2 ) then determ = 0.0D+00 else determ = 1.0D+00 end if return end subroutine tribonacci2_eigen_right ( n, v ) !*****************************************************************************80 ! !! tribonacci2_eigen_right(): right eigenvectors of the TRIBONACCI2 matrix. ! ! Licensing: ! ! This code is distributed under the MIT license. ! ! Modified: ! ! 14 May 2021 ! ! Author: ! ! John Burkardt ! ! Input: ! ! integer N, the order of the matrix. ! ! Output: ! ! complex ( kind = ck ) V(N,N), the right eigenvectors. ! implicit none integer, parameter :: rk = kind ( 1.0D+00 ) integer, parameter :: ck = kind ( ( 1.0D+00, 1.0D+00 ) ) integer n real ( kind = rk ) alpha complex ( kind = ck ) beta complex ( kind = ck ) gamma integer i complex ( kind = ck ) p complex ( kind = ck ) v(n,n) v(1:n,1:n) = 0.0D+00 if ( 3 <= n ) then call tribonacci_roots ( alpha, beta, gamma ) p = 1.0D+00 do i = 1, n v(i,1) = p p = p * alpha end do v(n,2:n-2) = 1.0 p = 1.0D+00 do i = 1, n v(i,n-1) = p p = p * beta end do p = 1.0D+00 do i = 1, n v(i,n) = p p = p * gamma end do end if return end subroutine tribonacci2_eigenvalues ( n, lambda ) !*****************************************************************************80 ! !! tribonacci2_eigenvalues() returns the eigenvalues of the TRIBONACCI2 matrix. ! ! Licensing: ! ! This code is distributed under the MIT license. ! ! Modified: ! ! 14 May 2021 ! ! Author: ! ! John Burkardt ! ! Input: ! ! integer N, the order of the matrix. ! ! Output: ! ! real ( kind = rk ) LAMBDA(N,1), the eigenvalues. ! implicit none integer, parameter :: rk = kind ( 1.0D+00 ) integer, parameter :: ck = kind ( ( 1.0D+00, 1.0D+00 ) ) integer n real ( kind = rk ) alpha complex ( kind = ck ) beta complex ( kind = ck ) gamma complex ( kind = ck ) lambda(n) lambda(1:n) = 0.0D+00 if ( 3 <= n ) then call tribonacci_roots ( alpha, beta, gamma ) lambda(1) = alpha lambda(2:n-2) = 1.0D+00 lambda(n-1) = beta lambda(n) = gamma end if return end subroutine tribonacci2_matrix ( n, a ) !*****************************************************************************80 ! !! tribonacci2_matrix() returns the TRIBONACCI2 matrix. ! ! Example: ! ! N = 5 ! ! 0 1 0 0 0 ! 0 0 1 0 0 ! 1 1 1 0 0 ! 0 1 1 1 0 ! 0 0 1 1 1 ! ! Properties: ! ! A is generally not symmetric: A' /= A. ! ! A is banded, with bandwidth 4. ! ! A is integral: int ( A ) = A. ! ! A is a zero/one matrix. ! ! If N <= 2 then ! det ( A ) = 0 ! else ! det ( A ) = 1 ! ! A is defective, for 4 < N. ! ! The family of matrices is nested as a function of N. ! ! A is not diagonally dominant. ! ! For 3 <= N, A has the eigenvalues: ! ! 1 (N-3) times, ! A once, 1/3 * (1+4 cosh(1/3 acosh(2+3/8) ) ) approx 1.83928 ! B+Ci once, approx -0.4196 + 0.6063i ! B-Ci once, approx -0.4196 - 0.6063i ! where A, B+Ci and B-Ci are the roots of x^3+x^2-x-1=0. ! ! Licensing: ! ! This code is distributed under the MIT license. ! ! Modified: ! ! 14 May 2021 ! ! Author: ! ! John Burkardt ! ! Input: ! ! integer N, the order of A. ! ! Output: ! ! real ( kind = rk ) A(N,N), the matrix. ! implicit none integer, parameter :: rk = kind ( 1.0D+00 ) integer n real ( kind = rk ) a(n,n) integer i a(1:n,1:n) = 0.0D+00 if ( n == 2 ) then a(1,2) = 1.0D+00 else if ( 2 < n ) then do i = 1, n if ( i == 1 ) then a(i,2) = 1.0D+00 else if ( i == 2 ) then a(i,3) = 1.0D+00 else a(i,i-2:i) = 1.0D+00 end if end do end if return end subroutine tridiagonal_determinant ( n, a, value ) !*****************************************************************************80 ! !! tridiagonal_determinant() computes the determinant of a tridiagonal matrix. ! ! Licensing: ! ! This code is distributed under the MIT license. ! ! Modified: ! ! 06 November 2007 ! ! Author: ! ! John Burkardt ! ! Input: ! ! integer N, the order of the matrix. ! ! real ( kind = rk ) A(N,N), the matrix. ! ! Output: ! ! real ( kind = rk ) VALUE, the determinant. ! implicit none integer, parameter :: rk = kind ( 1.0D+00 ) integer n real ( kind = rk ) a(n,n) real ( kind = rk ) determ real ( kind = rk ) determ_nm1 real ( kind = rk ) determ_nm2 integer i real ( kind = rk ) value determ_nm1 = a(n,n) if ( n == 1 ) then value = 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 == 2 ) then value = 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 value = determ return end subroutine tris_matrix ( m, n, x, y, z, a ) !*****************************************************************************80 ! !! tris_matrix() returns the TRIS matrix. ! ! Discussion: ! ! The matrix is a tridiagonal matrix defined by three scalars. ! ! See page 155 of the Todd reference. ! ! Formula: ! ! if ( J = I-1 ) ! A(I,J) = X ! else if ( J = I ) ! A(I,J) = Y ! else if ( J = I + 1 ) ! A(I,J) = Z ! else ! A(I,J) = 0 ! ! Example: ! ! M = 5, N = 5, X = 1, Y = 2, Z = 3 ! ! 2 3 0 0 0 ! 1 2 3 0 0 ! 0 1 2 3 0 ! 0 0 1 2 3 ! 0 0 0 1 2 ! ! Properties: ! ! A is generally not symmetric: A' /= A. ! ! A is tridiagonal. ! ! Because A is tridiagonal, it has property A (bipartite). ! ! A is banded, with bandwidth 3. ! ! A is Toeplitz: constant along diagonals. ! ! If Y is not zero, then for A to be singular, it must be the case that ! ! 0.5 * Y / sqrt ( X * Z ) < 1 ! ! and ! ! cos (K*PI/(N+1)) = - 0.5 * Y / sqrt ( X * Z ) for some 1 <= K <= N. ! ! If Y is zero, then A is singular when N is odd, or if X or Z is zero. ! ! A is persymmetric: A(I,J) = A(N+1-J,N+1-I). ! ! A has eigenvalues ! ! LAMBDA(I) = Y + 2 * sqrt(X*Z) * COS(I*PI/(N+1)) ! ! The eigenvalues will be complex if X * Z < 0. ! ! If X = Z, the matrix is symmetric. ! ! As long as X and Z are nonzero, the matrix is irreducible. ! ! If X = Z = -1, and Y = 2, the matrix is a symmetric, positive ! definite M matrix, the negative of the second difference matrix. ! ! The family of matrices is nested as a function of N. ! ! Licensing: ! ! This code is distributed under the MIT license. ! ! Modified: ! ! 01 July 2000 ! ! Author: ! ! John Burkardt ! ! Reference: ! ! John Todd, ! Basic Numerical Mathematics, ! Volume 2: Numerical Algebra, ! Birkhauser, 1980, ! ISBN: 0817608117, ! LC: QA297.T58. ! ! Input: ! ! integer M, N, the order of the matrix. ! ! real ( kind = rk ) X, Y, Z, the scalars that define A. ! ! Output: ! ! real ( kind = rk ) A(M,N), the matrix. ! implicit none integer, parameter :: rk = kind ( 1.0D+00 ) integer m integer n real ( kind = rk ) a(m,n) integer i integer j real ( kind = rk ) x real ( kind = rk ) y real ( kind = rk ) z do j = 1, n do i = 1, m if ( j == i - 1 ) then a(i,j) = x else if ( j == i ) then a(i,j) = y else if ( j == 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, value ) !*****************************************************************************80 ! !! tris_determinant() returns the determinant of the TRIS matrix. ! ! Licensing: ! ! This code is distributed under the MIT license. ! ! Modified: ! ! 03 November 2007 ! ! Author: ! ! John Burkardt ! ! Input: ! ! integer N, the order of the matrix. ! ! real ( kind = rk ) X, Y, Z, the scalars that define the matrix. ! ! Output: ! ! real ( kind = rk ) VALUE, the determinant. ! implicit none integer, parameter :: rk = kind ( 1.0D+00 ) real ( kind = rk ) angle integer i integer i_hi integer n real ( kind = rk ), parameter :: r8_pi = 3.141592653589793D+00 real ( kind = rk ) value real ( kind = rk ) x real ( kind = rk ) y real ( kind = rk ) z value = 1.0D+00 if ( 0.0D+00 <= x * z ) then do i = 1, n angle = real ( i, kind = rk ) * r8_pi / real ( n + 1, kind = rk ) value = value * ( y + 2.0D+00 * sqrt ( x * z ) * cos ( angle ) ) end do else i_hi = n / 2 do i = 1, i_hi angle = real ( i, kind = rk ) * r8_pi / real ( n + 1, kind = rk ) value = value * ( y * y - 4.0D+00 * x * z * cos ( angle ) ** 2 ) end do if ( mod ( n, 2 ) == 1 ) then value = value * y end if end if return end subroutine tris_eigenvalues ( n, x, y, z, lambda ) !*****************************************************************************80 ! !! tris_eigenvalues() returns the eigenvalues of the TRIS matrix. ! ! Discussion: ! ! The eigenvalues will be complex if X * Z < 0. ! ! Licensing: ! ! This code is distributed under the MIT license. ! ! Modified: ! ! 09 June 2003 ! ! Author: ! ! John Burkardt ! ! Input: ! ! integer N, the order of the matrix. ! ! real ( kind = rk ) X, Y, Z, the scalars that define A. ! ! Output: ! ! complex ( kind = ck ) LAMBDA(N), the eigenvalues. ! implicit none integer, parameter :: rk = kind ( 1.0D+00 ) integer, parameter :: ck = kind ( ( 1.0D+00, 1.0D+00 ) ) integer n real ( kind = rk ) angle complex ( kind = ck ) arg integer i complex ( kind = ck ) lambda(n) real ( kind = rk ), parameter :: r8_pi = 3.141592653589793D+00 real ( kind = rk ) x real ( kind = rk ) y real ( kind = rk ) z do i = 1, n angle = real ( i, kind = rk ) * r8_pi / real ( n + 1, kind = rk ) arg = cmplx ( x * z, 0.0D+00, kind = ck ) lambda(i) = y + 2.0D+00 * sqrt ( arg ) * cos ( angle ) end do return end subroutine tris_inverse ( n, alpha, beta, gamma, a ) !*****************************************************************************80 ! !! tris_inverse() returns the inverse of the TRIS matrix. ! ! Example: ! ! N = 5, ALPHA = 1, BETA = 2.0, GAMMA = 3.0 ! ! 1.1000 -1.2000 -0.9000 5.4000 -8.1000 ! -0.4000 0.8000 0.6000 -3.6000 5.4000 ! -0.1000 0.2000 -0.1000 0.6000 -0.9000 ! 0.2000 -0.4000 0.2000 0.8000 -1.2000 ! -0.1000 0.2000 -0.1000 -0.4000 1.1000 ! ! Licensing: ! ! This code is distributed under the MIT license. ! ! Modified: ! ! 19 November 2007 ! ! Author: ! ! John Burkardt ! ! Reference: ! ! CM daFonseca, J Petronilho, ! Explicit Inverses of Some Tridiagonal Matrices, ! Linear Algebra and Its Applications, ! Volume 325, 2001, pages 7-21. ! ! Input: ! ! integer N, the order of the matrix. ! ! real ( kind = rk ) ALPHA, BETA, GAMMA, the constant values ! associated with the subdiagonal, diagonal and superdiagonal of ! the matrix. ! ! Output: ! ! real ( kind = rk ) A(N,N), the inverse of the matrix. ! implicit none integer, parameter :: rk = kind ( 1.0D+00 ) integer n real ( kind = rk ) a(n,n) real ( kind = rk ) alpha real ( kind = rk ) beta real ( kind = rk ) d(n) real ( kind = rk ) gamma integer i integer j real ( kind = rk ) r8_mop 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 ) & * product ( d(i+1:n) ) / product ( d(1:n+1-j) ) end do do j = i + 1, n a(i,j) = r8_mop ( i + j ) * gamma ** ( j - i ) & * product ( d(j+1:n) ) / product ( d(1:n+1-i) ) end do end do return end subroutine triv_matrix ( n, x, y, z, a ) !*****************************************************************************80 ! !! triv_matrix() returns the TRIV matrix. ! ! Discussion: ! ! The three vectors define the subdiagonal, main diagonal, and ! superdiagonal. ! ! Formula: ! ! if ( J = I - 1 ) ! A(I,J) = X(J) ! else if ( J = I ) ! A(I,J) = Y(I) ! else if ( J = I + 1 ) ! A(I,J) = Z(I) ! else ! A(I,J) = 0 ! ! Example: ! ! N = 5, X = ( 1, 2, 3, 4 ), Y = ( 5, 6, 7, 8, 9 ), Z = ( 10, 11, 12, 13 ) ! ! 5 10 0 0 0 ! 1 6 11 0 0 ! 0 2 7 12 0 ! 0 0 3 8 13 ! 0 0 0 4 9 ! ! Properties: ! ! A is tridiagonal. ! ! A is banded, with bandwidth 3. ! ! A is generally not symmetric: A' /= A. ! ! The family of matrices is nested as a function of N. ! ! Licensing: ! ! This code is distributed under the MIT license. ! ! Modified: ! ! 15 April 1999 ! ! Author: ! ! John Burkardt ! ! Input: ! ! integer N, the order of the matrix. ! ! real ( kind = rk ) X(N-1), Y(N), Z(N-1), the vectors that define ! the subdiagonal, diagonal, and superdiagonal of A. ! ! Output: ! ! real ( kind = rk ) A(N,N), the matrix. ! implicit none integer, parameter :: rk = kind ( 1.0D+00 ) integer n real ( kind = rk ) a(n,n) integer i integer j real ( kind = rk ) x(n-1) real ( kind = rk ) y(n) real ( kind = rk ) z(n-1) do j = 1, n do i = 1, n if ( j == i - 1 ) then a(i,j) = x(j) else if ( j == i ) then a(i,j) = y(i) else if ( j == 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 ) !*****************************************************************************80 ! !! triv_determinant() returns the determinant of the TRIV matrix. ! ! Licensing: ! ! This code is distributed under the MIT license. ! ! Modified: ! ! 06 November 2007 ! ! Author: ! ! John Burkardt ! ! Input: ! ! integer N, the order of the matrix. ! ! real ( kind = rk ) X(N-1), Y(N), Z(N-1), the vectors that define ! the subdiagonal, diagonal, and superdiagonal of A. ! ! Output: ! ! real ( kind = rk ) DETERM, the determinant. ! implicit none integer, parameter :: rk = kind ( 1.0D+00 ) integer n real ( kind = rk ) determ real ( kind = rk ) determ_nm1 real ( kind = rk ) determ_nm2 integer i real ( kind = rk ) x(n-1) real ( kind = rk ) y(n) real ( kind = rk ) z(n-1) determ_nm1 = y(n) if ( n == 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 == 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 ) !*****************************************************************************80 ! !! triv_inverse() returns the inverse of the TRIV matrix. ! ! Licensing: ! ! This code is distributed under the MIT license. ! ! Modified: ! ! 08 April 2015 ! ! Author: ! ! John Burkardt ! ! Reference: ! ! CM daFonseca, J Petronilho, ! Explicit Inverses of Some Tridiagonal Matrices, ! Linear Algebra and Its Applications, ! Volume 325, 2001, pages 7-21. ! ! Input: ! ! integer N, the order of the matrix. ! ! real ( kind = rk ) X(N-1), Y(N), Z(N-1), the vectors that define ! the subdiagonal, diagonal, and superdiagonal of A. No entry of Y can ! be zero. ! ! Output: ! ! real ( kind = rk ) A(N,N), the inverse of the matrix. ! implicit none integer, parameter :: rk = kind ( 1.0D+00 ) integer n real ( kind = rk ) a(n,n) real ( kind = rk ) d(n) real ( kind = rk ) e(n) integer i integer j real ( kind = rk ) r8_mop real ( kind = rk ) x(n-1) real ( kind = rk ) y(n) real ( kind = rk ) z(n-1) if ( any ( y(1:n) == 0.0D+00 ) ) then write ( *, '(a)' ) '' write ( *, '(a)' ) 'triv_INVERSE - Fatal error!' write ( *, '(a)' ) ' No entry of Y(1:N) can be zero!' stop 1 end if 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 ) * product ( x(j:i-1) ) & * product ( d(i+1:n) ) / product ( e(j:n) ) end do do j = i + 1, n a(i,j) = r8_mop ( i + j ) * product ( z(i:j-1) ) & * product ( d(j+1:n) ) / product ( e(i:n) ) end do end do return end subroutine triw_matrix ( alpha, k, n, a ) !*****************************************************************************80 ! !! triw_matrix() returns the TRIW matrix. ! ! Discussion: ! ! The matrix is the Wilkinson banded upper triangular matrix. ! ! Formula: ! ! if ( I = J ) ! A(I,J) = 1 ! else if ( I < J and J <= K + I ) ! A(I,J) = ALPHA ! else ! A(I,J) = 0 ! ! Example: ! ! ALPHA = 3, K = 2, N = 5 ! ! 1 3 3 0 0 ! 0 1 3 3 0 ! 0 0 1 3 3 ! 0 0 0 1 3 ! 0 0 0 0 1 ! ! Properties: ! ! A is generally not symmetric: A' /= A. ! ! A is nonsingular. ! ! A is upper triangular. ! ! det ( A ) = 1. ! ! A is unimodular. ! ! LAMBDA(1:N) = 1. ! ! A is Toeplitz: constant along diagonals. ! ! A is persymmetric: A(I,J) = A(N+1-J,N+1-I). ! ! Adding -2^(2-N) to the (N,1) element makes the matrix singular. ! ! The family of matrices is nested as a function of N. ! ! Licensing: ! ! This code is distributed under the MIT license. ! ! Modified: ! ! 15 April 1999 ! ! Author: ! ! John Burkardt ! ! Reference: ! ! Gene Golub, James Wilkinson, ! Ill-conditioned eigensystems and the computation of the Jordan ! canonical form, ! SIAM Review, ! Volume 18, Number 4, 1976, pages 578-619. ! ! W Kahan, ! Numerical linear algebra, ! Canadian Mathematical Bulletin, ! Volume 9, 1966, pages 757-801. ! ! AM Ostrowski, ! On the spectrum of a one-parametric family of matrices, ! Journal fuer Reine und Angewandte Mathematik, ! Volume 193, Number (3/4), 1954, pages 143-160. ! ! James Wilkinson, ! Singular-value decomposition - basic aspects, ! in Numerical Software - Needs and Availability, ! edited by DAH Jacobs, ! Academic Press, London, 1978, pages 109-135. ! ! Input: ! ! real ( kind = rk ) ALPHA, the superdiagonal value. ! A typical value is -1. ! ! integer K, the number of nonzero superdiagonals. ! A typical value is N-1. ! ! integer N, the order of the matrix. ! ! Output: ! ! real ( kind = rk ) A(N,N), the matrix. ! implicit none integer, parameter :: rk = kind ( 1.0D+00 ) integer n real ( kind = rk ) a(n,n) real ( kind = rk ) alpha integer i integer j integer k do j = 1, n do i = 1, n if ( i == j ) then a(i,j) = 1.0D+00 else if ( i < j .and. j - i <= 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 ) !*****************************************************************************80 ! !! triw_determinant() returns the determinant of the TRIW matrix. ! ! Licensing: ! ! This code is distributed under the MIT license. ! ! Modified: ! ! 08 October 2007 ! ! Author: ! ! John Burkardt ! ! Input: ! ! real ( kind = rk ) ALPHA, the superdiagonal value. ! A typical value is -1. ! ! integer K, the number of nonzero superdiagonals. ! A typical value is N-1. ! ! integer N, the order of the matrix. ! ! Output: ! ! real ( kind = rk ) DETERM, the determinant. ! implicit none integer, parameter :: rk = kind ( 1.0D+00 ) real ( kind = rk ) alpha real ( kind = rk ) determ integer k integer n call r8_fake_use ( alpha ) call i4_fake_use ( k ) call i4_fake_use ( n ) determ = 1.0D+00 return end subroutine triw_eigenvalues ( n, lambda ) !*****************************************************************************80 ! !! triw_eigenvalues() returns the eigenvalues of the TRIW matrix. ! ! Licensing: ! ! This code is distributed under the MIT license. ! ! Modified: ! ! 19 October 2007 ! ! Author: ! ! John Burkardt ! ! Input: ! ! integer N, the order of the matrix. ! ! Output: ! ! real ( kind = rk ) LAMBDA(N), the eigenvalues. ! implicit none integer, parameter :: rk = kind ( 1.0D+00 ) integer n real ( kind = rk ) lambda(n) lambda(1:n) = 1.0D+00 return end subroutine triw_inverse ( alpha, k, n, a ) !*****************************************************************************80 ! !! triw_inverse() returns the inverse of the TRIW matrix. ! ! Example: ! ! ALPHA = 3, K = 2, N = 5 ! ! 1 -3 6 -9 9 ! 0 1 -3 6 -9 ! 0 0 1 -3 6 ! 0 0 0 1 -3 ! 0 0 0 0 1 ! ! Properties: ! ! A is nonsingular. ! ! A is upper triangular. ! ! A is Toeplitz: constant along diagonals. ! ! A is persymmetric: A(I,J) = A(N+1-J,N+1-I). ! ! det ( A ) = 1. ! ! A is unimodular. ! ! LAMBDA(1:N) = 1. ! ! Licensing: ! ! This code is distributed under the MIT license. ! ! Modified: ! ! 15 April 1999 ! ! Author: ! ! John Burkardt ! ! Input: ! ! real ( kind = rk ) ALPHA, value used on the superdiagonals. ! ! integer K, the number of nonzero superdiagonals. ! ! integer N, the order of the matrix. ! ! Output: ! ! real ( kind = rk ) A(N,N), the matrix. ! implicit none integer, parameter :: rk = kind ( 1.0D+00 ) integer n real ( kind = rk ) a(n,n) real ( kind = rk ) alpha integer i integer j integer k integer kk integer klo real ( kind = rk ) prod a(1:n,1:n) = 0.0D+00 do i = 1, n a(i,i) = 1.0D+00 end do ! ! Compute the product of row 1 of the inverse with columns 2, ! 3,..., N of the original matrix, up to, but not including, ! the next unknown entry of the inverse. That unknown entry ! is multiplied by 1, and the resulting sum must be zero. ! So the unknown entry equals minus the sum of all the ! other products. And all the entries along its superdiagonal ! have the same value. ! 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_matrix ( n, key, a ) !*****************************************************************************80 ! !! unitary_random_matrix() returns the unitary_random matrix. ! ! Properties: ! ! The inverse of A is equal to A^H. ! ! A is unitary: A * A^H = A^H * A = I. ! ! Because A is unitary, it is normal: A^H * A = A * A^H. ! ! Columns and rows of A have unit Euclidean norm. ! ! Distinct pairs of columns of A are complex orthogonal. ! ! Distinct pairs of rows of A are complex orthogonal. ! ! The L2 vector norm of A*x = the L2 vector norm of x for any vector x. ! ! The L2 matrix norm of A*B = the L2 matrix norm of B for any matrix B. ! ! det ( A ) = +1 or -1. ! ! A is unimodular. ! ! All the eigenvalues of A have modulus 1. ! ! All singular values of A are 1. ! ! Every entry of A is no greater than 1 in complex absolute value. ! ! Licensing: ! ! This code is distributed under the MIT license. ! ! Modified: ! ! 30 May 2002 ! ! Author: ! ! John Burkardt ! ! Reference: ! ! Pete Stewart, ! Efficient Generation of Random Orthogonal Matrices With an Application ! to Condition Estimators, ! SIAM Journal on Numerical Analysis, ! Volume 17, Number 3, June 1980, pages 403-409. ! ! Input: ! ! integer N, the order of the matrix. ! ! integer SEED, a seed for the random number generator. ! ! Output: ! ! complex ( kind = ck ) A(N,N), the matrix. ! ! integer SEED, an updated seed. ! implicit none integer, parameter :: rk = kind ( 1.0D+00 ) integer, parameter :: ck = kind ( ( 1.0D+00, 1.0D+00 ) ) integer n complex ( kind = ck ) a(n,n) integer i integer j integer key complex ( kind = ck ) v(n) complex ( kind = ck ) x(n) complex ( kind = ck ) c8_normal_01 call random_seed_initialize ( key ) ! ! Start with A = the identity matrix. ! do j = 1, n do i = 1, n if ( i == j ) then a(i,j) = cmplx ( 1.0D+00, 0.0D+00, kind = ck ) else a(i,j) = cmplx ( 0.0D+00, 0.0D+00, kind = ck ) end if end do end do ! ! Now behave as though we were computing the QR factorization of ! some other random matrix. Generate the N elements of the first column, ! compute the Householder matrix H1 that annihilates the subdiagonal elements, ! and set A := A * conjg ( H1 ) = A * H. ! ! On the second step, generate the lower N-1 elements of the second column, ! compute the Householder matrix H2 that annihilates them, ! and set A := A * conjg ( H2 ) = A * H2 = H1 * H2. ! ! On the N-1 step, generate the lower 2 elements of column N-1, ! compute the Householder matrix HN-1 that annihilates them, and ! and set A := A * conjg ( H(N-1) ) = A * H(N-1) = H1 * H2 * ... * H(N-1). ! This is our random unitary matrix. ! do j = 1, n - 1 ! ! Set the vector that represents the J-th column to be annihilated. ! x(1:j-1) = cmplx ( 0.0D+00, 0.0D+00, kind = ck ) do i = j, n x(i) = c8_normal_01 ( ) end do ! ! Compute the vector V that defines a Householder transformation matrix ! H(V) that annihilates the subdiagonal elements of X. ! call c8vec_house_column ( n, x, j, v ) ! ! Postmultiply the matrix A by conjg ( H(V) ) = H(V). ! call c8mat_house_axh ( n, a, v, a ) end do return end subroutine unitary_random_determinant ( n, key, determ ) !*****************************************************************************80 ! !! unitary_random_determinant(): determinant of a unitary_random matrix. ! ! Licensing: ! ! This code is distributed under the MIT license. ! ! Modified: ! ! 07 February 2015 ! ! Author: ! ! John Burkardt ! ! Input: ! ! integer N, the order of the matrix. ! ! integer KEY, a seed for the random number generator. ! ! Output: ! ! complex ( kind = ck ) DETERM, the determinant. ! implicit none integer, parameter :: rk = kind ( 1.0D+00 ) integer, parameter :: ck = kind ( ( 1.0D+00, 1.0D+00 ) ) integer n complex ( kind = ck ) determ integer key call i4_fake_use ( n ) call random_seed_initialize ( key ) determ = cmplx ( 1.0D+00, 0.0D+00, kind = ck ) return end subroutine unitary_random_inverse ( n, key, a ) !*****************************************************************************80 ! !! unitary_random_inverse() returns the inverse of a unitary_random matrix. ! ! Licensing: ! ! This code is distributed under the MIT license. ! ! Modified: ! ! 07 February 2015 ! ! Author: ! ! John Burkardt ! ! Reference: ! ! Pete Stewart, ! Efficient Generation of Random Orthogonal Matrices With an Application ! to Condition Estimators, ! SIAM Journal on Numerical Analysis, ! Volume 17, Number 3, June 1980, pages 403-409. ! ! Input: ! ! integer N, the order of the matrix. ! ! integer KEY, a seed for the random number generator. ! ! Output: ! ! complex ( kind = ck ) A(N,N), the matrix. ! implicit none integer, parameter :: rk = kind ( 1.0D+00 ) integer, parameter :: ck = kind ( ( 1.0D+00, 1.0D+00 ) ) integer n complex ( kind = ck ) a(n,n) integer key call unitary_random_matrix ( n, key, a ) a = transpose ( conjg ( a ) ) return end subroutine upshift_matrix ( n, a ) !*****************************************************************************80 ! !! upshift_matrix() returns the UPSHIFT matrix. ! ! Formula: ! ! if ( J-I == 1 mod ( n ) ) ! A(I,J) = 1 ! else ! A(I,J) = 0 ! ! Example: ! ! N = 4 ! ! 0 1 0 0 ! 0 0 1 0 ! 0 0 0 1 ! 1 0 0 0 ! ! Properties: ! ! A is integral, therefore det ( A ) is integral, and ! det ( A ) * inverse ( A ) is integral. ! ! A is a zero/one matrix. ! ! A is generally not symmetric: A' /= A. ! ! A is nonsingular. ! ! A is a permutation matrix. ! ! If N is even, det ( A ) = -1. ! If N is odd, det ( A ) = +1. ! ! A is unimodular. ! ! A is persymmetric: A(I,J) = A(N+1-J,N+1-I). ! ! A is a Hankel matrix: constant along anti-diagonals. ! ! A is an N-th root of the identity matrix. ! ! The inverse of A is the downshift matrix. ! ! A is a circulant matrix: each row is shifted once to get the next row. ! ! A circulant matrix C, whose first row is (c1, c2, ..., cn), can be ! written as a polynomial in A: ! ! C = c1 * I + c2 * A + c3 * A^2 + ... + cn * A^n-1. ! ! Licensing: ! ! This code is distributed under the MIT license. ! ! Modified: ! ! 07 March 2001 ! ! Author: ! ! John Burkardt ! ! Input: ! ! integer N, the order of the matrix. ! ! Output: ! ! real ( kind = rk ) A(N,N), the matrix. ! implicit none integer, parameter :: rk = kind ( 1.0D+00 ) integer n real ( kind = rk ) a(n,n) integer i integer j integer i4_modp do j = 1, n do i = 1, n if ( i4_modp ( j - i, n ) == 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 ) !*****************************************************************************80 ! !! upshift_condition() returns the L1 condition of the UPSHIFT matrix. ! ! Licensing: ! ! This code is distributed under the MIT license. ! ! Modified: ! ! 07 February 2015 ! ! Author: ! ! John Burkardt ! ! Input: ! ! integer N, the order of the matrix. ! ! Output: ! ! real ( kind = rk ) COND, the L1 condition. ! implicit none integer, parameter :: rk = kind ( 1.0D+00 ) real ( kind = rk ) a_norm real ( kind = rk ) b_norm real ( kind = rk ) cond integer n call i4_fake_use ( n ) a_norm = 1.0D+00 b_norm = 1.0D+00 cond = a_norm * b_norm return end subroutine upshift_determinant ( n, determ ) !*****************************************************************************80 ! !! upshift_determinant() returns the determinant of the UPSHIFT matrix. ! ! Licensing: ! ! This code is distributed under the MIT license. ! ! Modified: ! ! 07 October 2007 ! ! Author: ! ! John Burkardt ! ! Input: ! ! integer N, the order of the matrix. ! ! Output: ! ! real ( kind = rk ) DETERM, the determinant. ! implicit none integer, parameter :: rk = kind ( 1.0D+00 ) real ( kind = rk ) determ integer n if ( mod ( n, 2 ) == 0 ) then determ = -1.0D+00 else determ = +1.0D+00 end if return end subroutine upshift_eigenvalues ( n, lambda ) !*****************************************************************************80 ! !! upshift_eigenvalues() returns the eigenvalues of the UPSHIFT matrix. ! ! Licensing: ! ! This code is distributed under the MIT license. ! ! Modified: ! ! 19 October 2007 ! ! Author: ! ! John Burkardt ! ! Input: ! ! integer N, the order of the matrix. ! ! Output: ! ! complex ( kind = ck ) LAMBDA(N), the eigenvalues. ! implicit none integer, parameter :: rk = kind ( 1.0D+00 ) integer, parameter :: ck = kind ( ( 1.0D+00, 1.0D+00 ) ) integer n complex ( kind = ck ) lambda(n) call c8vec_unity ( n, lambda ) return end subroutine upshift_inverse ( n, a ) !*****************************************************************************80 ! !! upshift_inverse() returns the inverse of the UPSHIFT matrix. ! ! Licensing: ! ! This code is distributed under the MIT license. ! ! Modified: ! ! 19 October 2007 ! ! Author: ! ! John Burkardt ! ! Input: ! ! integer N, the order of the matrix. ! ! Output: ! ! real ( kind = rk ) A(N,N), the matrix. ! implicit none integer, parameter :: rk = kind ( 1.0D+00 ) integer n real ( kind = rk ) a(n,n) call downshift_matrix ( n, a ) return end subroutine vand1_matrix ( n, x, a ) !*****************************************************************************80 ! !! vand1_matrix() returns the VAND1 matrix. ! ! Formula: ! ! A(I,J) = X(J)^(I-1) ! ! Example: ! ! N = 5, X = ( 2, 3, 4, 5, 6 ) ! ! 1 1 1 1 1 ! 2 3 4 5 6 ! 4 9 16 25 36 ! 8 27 64 125 216 ! 16 81 256 625 1296 ! ! Properties: ! ! A is generally not symmetric: A' /= A. ! ! A is nonsingular if, and only if, the X values are distinct. ! ! det ( A ) = product ( 1 <= I <= N ) ( 1 <= J < I ) ( X(I) - X(J) ). ! = product ( 1 <= J <= N ) X(J) ! * product ( 1 <= I < J ) ( X(J) - X(I) ). ! ! A is generally ill-conditioned. ! ! The family of matrices is nested as a function of N. ! ! Licensing: ! ! This code is distributed under the MIT license. ! ! Modified: ! ! 15 April 1999 ! ! Author: ! ! John Burkardt ! ! Reference: ! ! Robert Gregory, David Karney, ! A Collection of Matrices for Testing Computational Algorithms, ! Wiley, 1969, ! ISBN: 0882756494, ! LC: QA263.68 ! ! Nicholas Higham, ! Stability analysis of algorithms for solving confluent ! Vandermonde-like systems, ! SIAM Journal on Matrix Analysis and Applications, ! Volume 11, 1990, pages 23-41. ! ! Input: ! ! integer N, the order of the matrix. ! ! real ( kind = rk ) X(N), the values that define A. ! ! Output: ! ! real ( kind = rk ) A(N,N), the matrix. ! implicit none integer, parameter :: rk = kind ( 1.0D+00 ) integer n real ( kind = rk ) a(n,n) integer i integer j real ( kind = rk ) x(n) do j = 1, n do i = 1, n if ( i == 1 .and. x(j) == 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 ) !*****************************************************************************80 ! !! vand1_determinant() returns the determinant of the VAND1 matrix. ! ! Licensing: ! ! This code is distributed under the MIT license. ! ! Modified: ! ! 21 May 2002 ! ! Author: ! ! John Burkardt ! ! Input: ! ! integer N, the order of the matrix. ! ! real ( kind = rk ) X(N), the values that define A. ! ! Output: ! ! real ( kind = rk ) DETERM, the determinant. ! implicit none integer, parameter :: rk = kind ( 1.0D+00 ) integer n real ( kind = rk ) determ integer i integer j real ( kind = rk ) 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 ) !*****************************************************************************80 ! !! vand1_inverse() returns the inverse of the VAND1 matrix. ! ! Formula: ! ! A(I,J) = coefficient of X^(J-1) in I-th Lagrange basis polynomial. ! ! Example: ! ! N = 5, X = ( 2, 3, 4, 5, 6 ) ! ! 15.00 -14.25 4.96 -0.75 0.04 ! -40.00 44.67 -17.33 2.83 -0.17 ! 45.00 -54.00 22.75 -4.00 0.25 ! -24.00 30.00 -13.33 2.50 -0.17 ! 5.00 -6.42 2.96 -0.58 0.04 ! ! Properties: ! ! The sum of the entries of A is ! ! 1 - product ( 1 <= I <= N ) ( 1 - 1 / X(I) ). ! ! Licensing: ! ! This code is distributed under the MIT license. ! ! Modified: ! ! 10 January 1999 ! ! Author: ! ! John Burkardt ! ! Input: ! ! integer N, the order of the matrix. ! ! real ( kind = rk ) X(N), the values that define A. ! ! Output: ! ! real ( kind = rk ) A(N,N), the matrix. ! implicit none integer, parameter :: rk = kind ( 1.0D+00 ) integer n real ( kind = rk ) a(n,n) integer i integer index integer j integer k real ( kind = rk ) x(n) do j = 1, n do i = 1, n if ( j == 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 /= 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 < 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 ) !*****************************************************************************80 ! !! vand1_inverse_ul() returns the UL factors of the Vandermonde1 inverse. ! ! Discussion: ! ! inverse ( A ) = U * L. ! ! Licensing: ! ! This code is distributed under the MIT license. ! ! Modified: ! ! 01 November 2013 ! ! Author: ! ! John Burkardt ! ! Reference: ! ! Richard Turner, ! Inverse of the Vandermonde Matrix with Applications, ! NASA Technical Note TN D-3547, 1966. ! ! Input: ! ! integer N, the order of the matrix. ! ! real ( kind = rk ) X(N), the values that define A. ! ! Output: ! ! real ( kind = rk ) U(N,N), L(N,N), the UL factors of inverse(A). ! implicit none integer, parameter :: rk = kind ( 1.0D+00 ) integer n integer i integer j integer k real ( kind = rk ) l(n,n) real ( kind = rk ) u(n,n) real ( kind = rk ) x(n) do i = 1, n u(1:i,i) = 1.0D+00 u(i+1,i) = 0.0D+00 do j = 1, i do k = 1, i if ( j /= k ) then u(j,i) = u(j,i) / ( x(j) - x(k) ) end if end do end do end do do i = 1, n l(1:i-1,i) = 0.0D+00 l(i,i) = 1.0D+00 if ( i == 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_matrix ( n, x, a ) !*****************************************************************************80 ! !! vand2_matrix() returns the VAND2 matrix. ! ! Discussion: ! ! For this version of the Vandermonde matrix, the 1's occur in the ! first column. ! ! Formula: ! ! A(I,J) = X(I)^(J-1) ! ! Example: ! ! N = 5, X = (2, 3, 4, 5, 6) ! ! 1 2 4 8 16 ! 1 3 9 27 81 ! 1 4 16 64 256 ! 1 5 25 125 625 ! 1 6 36 216 1296 ! ! Properties: ! ! A is generally not symmetric: A' /= A. ! ! A is nonsingular if, and only if, the X values are distinct. ! ! det ( A ) = product ( 1 <= I <= N ) ( ! product ( 1 <= J < I ) ( ( X(I) - X(J) ) ) ). ! ! det ( A ) = product ( 1 <= I <= N ) ( ! X(I) * product ( 1 <= J <= I - 1 ) ( ( X(I) - X(J) ) ). ! ! A is generally ill-conditioned. ! ! The sum of the entries of A is ! ! 1 - product ( 1 <= I <= N ) ( 1 - 1 / X(I) ). ! ! The family of matrices is nested as a function of N. ! ! Licensing: ! ! This code is distributed under the MIT license. ! ! Modified: ! ! 15 April 1999 ! ! Author: ! ! John Burkardt ! ! Reference: ! ! Nicholas Higham, ! Stability analysis of algorithms for solving confluent ! Vandermonde-like systems, ! SIAM Journal on Matrix Analysis and Applications, ! Volume 11, 1990, pages 23-41. ! ! Input: ! ! integer N, the order of the matrix. ! ! real ( kind = rk ) X(N), the values that define A. ! ! Output: ! ! real ( kind = rk ) A(N,N), the matrix. ! implicit none integer, parameter :: rk = kind ( 1.0D+00 ) integer n real ( kind = rk ) a(n,n) integer i integer j real ( kind = rk ) x(n) do j = 1, n do i = 1, n if ( j == 1 .and. x(i) == 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 ) !*****************************************************************************80 ! !! vand2_determinant() returns the determinant of the VAND2 matrix. ! ! Licensing: ! ! This code is distributed under the MIT license. ! ! Modified: ! ! 21 May 2002 ! ! Author: ! ! John Burkardt ! ! Input: ! ! integer N, the order of the matrix. ! ! real ( kind = rk ) X(N), the values that define A. ! ! Output: ! ! real ( kind = rk ) DETERM, the determinant. ! implicit none integer, parameter :: rk = kind ( 1.0D+00 ) integer n real ( kind = rk ) determ integer i integer j real ( kind = rk ) 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 ) !*****************************************************************************80 ! !! vand2_inverse() returns the inverse of the VAND2 matrix. ! ! Formula: ! ! A(I,J) = coefficient of X^(I-1) in J-th Lagrange basis polynomial. ! ! Example: ! ! N = 5, X = ( 2, 3, 4, 5, 6 ) ! ! 15.00 -40.00 45.00 -24.00 5.00 ! -14.25 44.67 -54.00 30.00 -6.42 ! 4.96 -17.33 22.75 -13.33 2.96 ! -0.75 2.83 -4.00 2.50 -0.58 ! 0.04 -0.17 0.25 -0.17 0.04 ! ! Licensing: ! ! This code is distributed under the MIT license. ! ! Modified: ! ! 10 January 1999 ! ! Author: ! ! John Burkardt ! ! Input: ! ! integer N, the order of the matrix. ! ! real ( kind = rk ) X(N), the values that define the matrix. ! ! Output: ! ! real ( kind = rk ) A(N,N), the matrix. ! implicit none integer, parameter :: rk = kind ( 1.0D+00 ) integer n real ( kind = rk ) a(n,n) integer i integer index integer j integer k real ( kind = rk ) x(n) do j = 1, n do i = 1, n if ( i == 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 /= 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 < 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 ) !*****************************************************************************80 ! !! vand2_inverse_ul() returns the UL factors of the Vandermonde2 inverse. ! ! Discussion: ! ! inverse ( A ) = U * L. ! ! Licensing: ! ! This code is distributed under the MIT license. ! ! Modified: ! ! 01 November 2013 ! ! Author: ! ! John Burkardt ! ! Reference: ! ! Richard Turner, ! Inverse of the Vandermonde Matrix with Applications, ! NASA Technical Note TN D-3547, 1966. ! ! Input: ! ! integer N, the order of the matrix. ! ! real ( kind = rk ) X(N), the values that define A. ! ! Output: ! ! real ( kind = rk ) U(N,N), L(N,N), the UL factors of inverse(A). ! implicit none integer, parameter :: rk = kind ( 1.0D+00 ) integer n integer i integer j integer k real ( kind = rk ) l(n,n) real ( kind = rk ) u(n,n) real ( kind = rk ) x(n) do i = 1, n u(i,1:i-1) = 0.0D+00 u(i,i) = 1.0D+00 if ( i == 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 l(i,1:i) = 1.0D+00 do j = 1, i do k = 1, i if ( j /= k ) then l(i,j) = l(i,j) / ( x(j) - x(k) ) end if end do end do l(i,i+1:n) = 0.0D+00 end do return end subroutine vand2_lu ( n, x, l, u ) !*****************************************************************************80 ! !! vand2_lu() returns the LU factors of the Vandermonde2 matrix. ! ! Licensing: ! ! This code is distributed under the MIT license. ! ! Modified: ! ! 05 November 2013 ! ! Author: ! ! John Burkardt ! ! Reference: ! ! Halil Oruc, George Phillips, ! Explicit factorization of the Vandermonde matrix, ! Linear Algebra and its Applications, ! Volume 315, Number 1-3, 15 August 2000, pages 113-123. ! ! Input: ! ! integer N, the order of the matrix. ! ! real ( kind = rk ) X(N), the values that define the matrix. ! ! Output: ! ! real ( kind = rk ) L(N,N), U(N,N), the LU factors of the matrix. ! implicit none integer, parameter :: rk = kind ( 1.0D+00 ) integer n integer i integer j integer k real ( kind = rk ) l(n,n) real ( kind = rk ) u(n,n) real ( kind = rk ) value real ( kind = rk ) 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 ) !*****************************************************************************80 ! !! vand2_plu() returns the PLU factors of the Vandermonde2 matrix. ! ! Licensing: ! ! This code is distributed under the MIT license. ! ! Modified: ! ! 05 November 2013 ! ! Author: ! ! John Burkardt ! ! Reference: ! ! Halil Oruc, George Phillips, ! Explicit factorization of the Vandermonde matrix, ! Linear Algebra and its Applications, ! Volume 315, Number 1-3, 15 August 2000, pages 113-123. ! ! Input: ! ! integer N, the order of the matrix. ! ! real ( kind = rk ) X(N), the values that define the matrix. ! ! Output: ! ! real ( kind = rk ) P(N,N), L(N,N), U(N,N), the PLU factors. ! implicit none integer, parameter :: rk = kind ( 1.0D+00 ) integer n integer i integer j integer k real ( kind = rk ) l(n,n) real ( kind = rk ) p(n,n) real ( kind = rk ) u(n,n) real ( kind = rk ) value real ( kind = rk ) 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_matrix ( nx, ny, n, a ) !*****************************************************************************80 ! !! wathen_matrix() returns the WATHEN matrix. ! ! Discussion: ! ! The Wathen matrix is a finite element matrix which is sparse. ! ! The entries of the matrix depend in part on a physical quantity ! related to density. That density is here assigned random values between ! 0 and 100. ! ! The matrix order N is determined by the input quantities NX and NY, ! which would usually be the number of elements in the X and Y directions. ! The value of N is ! ! N = 3*NX*NY + 2*NX + 2*NY + 1, ! ! and sufficient storage in A must have been set aside to hold ! the matrix. ! ! A is the consistent mass matrix for a regular NX by NY grid ! of 8 node serendipity elements. ! ! The local element numbering is ! ! 3--2--1 ! | | ! 4 8 ! | | ! 5--6--7 ! ! Here is an illustration for NX = 3, NX = 2: ! ! 23-24-25-26-27-28-29 ! | | | | ! 19 20 21 22 ! | | | | ! 12-13-14-15-16-17-18 ! | | | | ! 8 9 10 11 ! | | | | ! 1--2--3--4--5--6--7 ! ! In this case, the total number of nodes is, as expected, ! ! N = 3 * 3 * 2 + 2 * 2 + 2 * 3 + 1 = 29 ! ! Properties: ! ! A is symmetric positive definite for any positive values of the ! density RHO(NX,NY), which is here given the value 1. ! ! The problem could be reprogrammed so that RHO is nonconstant, ! but positive. ! ! Licensing: ! ! This code is distributed under the MIT license. ! ! Modified: ! ! 01 July 2014 ! ! Author: ! ! John Burkardt ! ! Reference: ! ! Nicholas Higham, ! Algorithm 694: A Collection of Test Matrices in MATLAB, ! ACM Transactions on Mathematical Software, ! Volume 17, Number 3, September 1991, pages 289-305. ! ! Andrew Wathen, ! Realistic eigenvalue bounds for the Galerkin mass matrix, ! IMA Journal of Numerical Analysis, ! Volume 7, Number 4, October 1987, pages 449-457. ! ! Input: ! ! integer NX, NY, values which determine the size of A. ! ! integer N, the order of the matrix. ! ! Output: ! ! real ( kind = rk ) A(N,N), the matrix. ! implicit none integer, parameter :: rk = kind ( 1.0D+00 ) integer n real ( kind = rk ) a(n,n) real ( kind = rk ), dimension ( 8, 8 ), save :: em = reshape ( (/ & 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 /), & (/ 8, 8 /) ) integer i integer j integer kcol integer krow integer nx integer ny integer node(8) real ( kind = rk ) rho integer seed a(1:n,1:n) = 0.0D+00 seed = 123456789 do j = 1, ny do i = 1, nx ! ! For the element (I,J), determine the indices of the 8 nodes. ! 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(5) = ( 3 * j - 3 ) * nx + 2 * j + 2 * i - 3 node(6) = node(5) + 1 node(7) = node(5) + 2 node(8) = node(4) + 1 call random_number ( harvest = rho ) rho = 100.0D+00 * rho 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 ) !*****************************************************************************80 ! !! wathen_order() returns the order of the WATHEN matrix. ! ! Discussion: ! ! N = 3 * 3 * 2 + 2 * 2 + 2 * 3 + 1 = 29 ! ! Licensing: ! ! This code is distributed under the MIT license. ! ! Modified: ! ! 17 June 2011 ! ! Author: ! ! John Burkardt ! ! Reference: ! ! Nicholas Higham, ! Algorithm 694: A Collection of Test Matrices in MATLAB, ! ACM Transactions on Mathematical Software, ! Volume 17, Number 3, September 1991, pages 289-305. ! ! Andrew Wathen, ! Realistic eigenvalue bounds for the Galerkin mass matrix, ! IMA Journal of Numerical Analysis, ! Volume 7, 1987, pages 449-457. ! ! Input: ! ! integer NX, NY, values which determine the size of A. ! ! Output: ! ! integer N, the order of the matrix, ! as determined by NX and NY. ! implicit none integer, parameter :: rk = kind ( 1.0D+00 ) integer n integer nx integer ny n = 3 * nx * ny + 2 * nx + 2 * ny + 1 return end subroutine wilk03_matrix ( a ) !*****************************************************************************80 ! !! wilk03_matrix() returns the WILK03 matrix. ! ! Example: ! ! 1.0E-10 0.9 -0.4 ! 0 0.9 -0.4 ! 0 0 1.0E-10 ! ! Discussion: ! ! The linear equation under study is ! A * X = B, ! where A is the 3 by 3 Wilkinson matrix, and ! B = ( 0, 0, 1 )' ! and the correct solution is ! X = ( 0, 4.0D+10 / 9.0D+00, 1.0D+10 ) ! ! Since the matrix is already in upper triangular form, errors can ! occur only in the backsubstitution. ! ! Properties: ! ! A is generally not symmetric: A' /= A. ! ! A is upper triangular. ! ! det ( A ) = 0.9D-20 ! ! LAMBDA = ( 1.0D-10, 0.9, 1.0D-10 ) ! ! Licensing: ! ! This code is distributed under the MIT license. ! ! Modified: ! ! 21 May 2002 ! ! Author: ! ! John Burkardt ! ! Reference: ! ! James Wilkinson, ! Error Analysis of Direct Methods of Matrix Inversion, ! Journal of the Association for Computing Machinery, ! Volume 8, 1961, pages 281-330. ! ! Output: ! ! real ( kind = rk ) A(3,3), the matrix. ! implicit none integer, parameter :: rk = kind ( 1.0D+00 ) real ( kind = rk ) a(3,3) ! ! Note that the matrix entries are listed by column. ! real ( kind = rk ), dimension ( 3, 3 ), save :: a_save = reshape ( (/ & 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 /), (/ 3, 3 /) ) call r8mat_copy ( 3, 3, a_save, a ) return end subroutine wilk03_condition ( cond ) !*****************************************************************************80 ! !! wilk03_condition() returns the L1 condition of the WILK03 matrix. ! ! Licensing: ! ! This code is distributed under the MIT license. ! ! Modified: ! ! 18 January 2015 ! ! Author: ! ! John Burkardt ! ! Reference: ! ! James Wilkinson, ! Error Analysis of Direct Methods of Matrix Inversion, ! Journal of the Association for Computing Machinery, ! Volume 8, 1961, pages 281-330. ! ! Output: ! ! real ( kind = rk ) COND, the L1 condition. ! implicit none integer, parameter :: rk = kind ( 1.0D+00 ) real ( kind = rk ) cond cond = 1.8D+00 * ( 13.0D+00 * 1.0D+10 / 9.0D+00 ) return end subroutine wilk03_determinant ( determ ) !*****************************************************************************80 ! !! wilk03_determinant() returns the determinant of the WILK03 matrix. ! ! Licensing: ! ! This code is distributed under the MIT license. ! ! Modified: ! ! 01 October 2007 ! ! Author: ! ! John Burkardt ! ! Reference: ! ! James Wilkinson, ! Error Analysis of Direct Methods of Matrix Inversion, ! Journal of the Association for Computing Machinery, ! Volume 8, 1961, pages 281-330. ! ! Output: ! ! real ( kind = rk ) DETERM, the determinant of the matrix. ! implicit none integer, parameter :: rk = kind ( 1.0D+00 ) real ( kind = rk ) determ determ = 0.9D-20 return end subroutine wilk03_eigenvalues ( lambda ) !*****************************************************************************80 ! !! wilk03_eigenvalues() returns the eigenvalues of the WILK03 matrix. ! ! Licensing: ! ! This code is distributed under the MIT license. ! ! Modified: ! ! 15 August 2008 ! ! Author: ! ! John Burkardt ! ! Reference: ! ! James Wilkinson, ! Error Analysis of Direct Methods of Matrix Inversion, ! Journal of the Association for Computing Machinery, ! Volume 8, 1961, pages 281-330. ! ! Output: ! ! real ( kind = rk ) LAMBDA(3), the eigenvalues of the matrix. ! implicit none integer, parameter :: rk = kind ( 1.0D+00 ) real ( kind = rk ) lambda(3) real ( kind = rk ), dimension ( 3 ), save :: lambda_save = (/ & 1.0D-10, 1.0D-10, 0.9D+00 /) call r8vec_copy ( 3, lambda_save, lambda ) return end subroutine wilk03_inverse ( a ) !*****************************************************************************80 ! !! wilk03_inverse() returns the inverse of the WILK03 matrix. ! ! Example: ! ! 1.0E+10 -1.0E+10 0 ! 0 10/9 4/9 * 1.0E+10 ! 0 0 1.0E+10 ! ! Licensing: ! ! This code is distributed under the MIT license. ! ! Modified: ! ! 15 April 1999 ! ! Author: ! ! John Burkardt ! ! Output: ! ! real ( kind = rk ) A(3,3), the matrix. ! implicit none integer, parameter :: rk = kind ( 1.0D+00 ) real ( kind = rk ) 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 ) !*****************************************************************************80 ! !! wilk03_rhs() returns the right hand side of the WILK03 linear system. ! ! Licensing: ! ! This code is distributed under the MIT license. ! ! Modified: ! ! 21 May 2002 ! ! Author: ! ! John Burkardt ! ! Output: ! ! real ( kind = rk ) B(3), the right hand side of the system. ! implicit none integer, parameter :: rk = kind ( 1.0D+00 ) real ( kind = rk ) b(3) real ( kind = rk ), dimension(3), save :: b_save = (/ & 0.0D+00, 0.0D+00, 1.0D+00 /) call r8vec_copy ( 3, b_save, b ) return end subroutine wilk03_solution ( x ) !*****************************************************************************80 ! !! wilk03_solution() returns the solution of the WILK03 linear system. ! ! Licensing: ! ! This code is distributed under the MIT license. ! ! Modified: ! ! 21 May 2002 ! ! Author: ! ! John Burkardt ! ! Output: ! ! real ( kind = rk ) X(3), the solution of the linear system. ! implicit none integer, parameter :: rk = kind ( 1.0D+00 ) real ( kind = rk ) x(3) real ( kind = rk ), dimension(3), save :: x_save = (/ & 0.0D+00, 4444444444.4444444D+00, 10000000000.0D+00 /) call r8vec_copy ( 3, x_save, x ) return end subroutine wilk04_matrix ( a ) !*****************************************************************************80 ! !! wilk04_matrix() returns the WILK04 matrix. ! ! Example: ! ! 0.9143E-04 0.0 0.0 0.0 ! 0.8762 0.7156E-04 0.0 0.0 ! 0.7943 0.8143 0.9504E-04 0.0 ! 0.8017 0.6123 0.7165 0.7123E-04 ! ! Properties: ! ! A is lower triangular. ! ! LAMBDA = ( 0.9143E-04, 0.7156E-04, 0.9504E-04, 0.7123E-04 ). ! ! Discussion: ! ! Since the matrix is already in lower triangular form, errors can ! occur only in the backsubstitution. However, even a double ! precision calculation will show a significant degradation in the ! solution. It is also instructive to compare the actual error in ! the solution to the residual error, A*x-b. ! ! Licensing: ! ! This code is distributed under the MIT license. ! ! Modified: ! ! 17 June 2011 ! ! Author: ! ! John Burkardt ! ! Reference: ! ! James Wilkinson, ! Rounding Errors in Algebraic Processes, ! Prentice Hall, 1963, page 105. ! ! Output: ! ! real ( kind = rk ) A(4,4), the matrix. ! implicit none integer, parameter :: rk = kind ( 1.0D+00 ) real ( kind = rk ) a(4,4) ! ! Note that the matrix entries are listed by column. ! real ( kind = rk ), dimension ( 4, 4 ), save :: a_save = reshape ( (/ & 0.9143D-04, 0.8762D+00, 0.7943D+00, 0.8017D+00, & 0.0000D+00, 0.7156D-04, 0.8143D+00, 0.6123D+00, & 0.0000D+00, 0.0000D+00, 0.9504D-04, 0.7165D+00, & 0.0000D+00, 0.0000D+00, 0.0000D+00, 0.7123D-04 /), (/ 4, 4 /) ) call r8mat_copy ( 4, 4, a_save, a ) return end subroutine wilk04_condition ( cond ) !*****************************************************************************80 ! !! wilk04_condition() returns the L1 condition of the WILK04 matrix. ! ! Licensing: ! ! This code is distributed under the MIT license. ! ! Modified: ! ! 07 February 2015 ! ! Author: ! ! John Burkardt ! ! Reference: ! ! James Wilkinson, ! Error Analysis of Direct Methods of Matrix Inversion, ! Journal of the Association for Computing Machinery, ! Volume 8, 1961, pages 281-330. ! ! Output: ! ! real ( kind = rk ) COND, the L1 condition. ! implicit none integer, parameter :: rk = kind ( 1.0D+00 ) real ( kind = rk ) a_norm real ( kind = rk ) b_norm real ( kind = rk ) cond a_norm = 2.1306D+00 b_norm = 1.154098458240528D+16 cond = a_norm * b_norm return end subroutine wilk04_determinant ( determ ) !*****************************************************************************80 ! !! wilk04_determinant() returns the determinant of the WILK04 matrix. ! ! Licensing: ! ! This code is distributed under the MIT license. ! ! Modified: ! ! 13 October 2007 ! ! Author: ! ! John Burkardt ! ! Output: ! ! real ( kind = rk ) DETERM, the determinant. ! implicit none integer, parameter :: rk = kind ( 1.0D+00 ) real ( kind = rk ) determ determ = 0.9143D-04 * 0.7156D-04 * 0.9504D-04 * 0.7123D-04 return end subroutine wilk04_eigenvalues ( lambda ) !*****************************************************************************80 ! !! wilk04_eigenvalues() returns the eigenvalues of the WILK04 matrix. ! ! Licensing: ! ! This code is distributed under the MIT license. ! ! Modified: ! ! 24 November 2007 ! ! Author: ! ! John Burkardt ! ! Output: ! ! real ( kind = rk ) LAMBDA(4), the eigenvalues. ! implicit none integer, parameter :: rk = kind ( 1.0D+00 ) real ( kind = rk ) lambda(4) real ( kind = rk ), dimension ( 4 ), save :: 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 ) !*****************************************************************************80 ! !! wilk04_inverse() returns the inverse of the WILK04 matrix. ! ! Licensing: ! ! This code is distributed under the MIT license. ! ! Modified: ! ! 03 November 2007 ! ! Author: ! ! John Burkardt ! ! Output: ! ! real ( kind = rk ) A(4,4), the matrix. ! implicit none integer, parameter :: rk = kind ( 1.0D+00 ) real ( kind = rk ) a(4,4) ! ! Note that the matrix entries are listed by column. ! real ( kind = rk ), dimension (4,4), save :: a_save = reshape ( (/ & 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 /), (/ 4, 4 /) ) call r8mat_copy ( 4, 4, a_save, a ) return end subroutine wilk04_rhs ( b ) !*****************************************************************************80 ! !! wilk04_rhs() returns the right hand side of the WILK04 linear system. ! ! Example: ! ! 0.6524 ! 0.3127 ! 0.4186 ! 0.7853 ! ! Licensing: ! ! This code is distributed under the MIT license. ! ! Modified: ! ! 21 May 2002 ! ! Author: ! ! John Burkardt ! ! Output: ! ! real ( kind = rk ) B(4), the right hand side of the system. ! implicit none integer, parameter :: rk = kind ( 1.0D+00 ) real ( kind = rk ) b(4) real ( kind = rk ), dimension ( 4 ), save :: b_save = (/ & 0.6524D+00, 0.3127D+00, 0.4186D+00, 0.7853D+00 /) call r8vec_copy ( 4, b_save, b ) return end subroutine wilk04_solution ( x ) !*****************************************************************************80 ! !! wilk04_solution() returns the solution of the WILK04 linear system. ! ! Licensing: ! ! This code is distributed under the MIT license. ! ! Modified: ! ! 25 November 2007 ! ! Author: ! ! John Burkardt ! ! Output: ! ! real ( kind = rk ) X(4), the solution of the system. ! implicit none integer, parameter :: rk = kind ( 1.0D+00 ) real ( kind = rk ) x(4) real ( kind = rk ), dimension ( 4 ), save :: 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_matrix ( a ) !*****************************************************************************80 ! !! wilk05_matrix() returns the WILK05 matrix. ! ! Formula: ! ! A(I,J) = 1.8144 / ( I + J + 1 ) ! ! Example: ! ! 0.604800 0.453600 0.362880 0.302400 0.259200 ! 0.453600 0.362880 0.302400 0.259200 0.226800 ! 0.362880 0.302400 0.259200 0.226800 0.201600 ! 0.302400 0.259200 0.226800 0.201600 0.181440 ! 0.259200 0.226800 0.201600 0.181440 0.164945 ! ! Properties: ! ! A is symmetric: A' = A. ! ! Because A is symmetric, it is normal. ! ! Because A is normal, it is diagonalizable. ! ! A is essentially a scaled portion of the Hilbert matrix. ! ! Licensing: ! ! This code is distributed under the MIT license. ! ! Modified: ! ! 15 April 1999 ! ! Author: ! ! John Burkardt ! ! Reference: ! ! James Wilkinson, ! The Algebraic Eigenvalue Problem, ! Oxford University Press, 1965, ! page 234. ! ! Output: ! ! real ( kind = rk ) A(5,5), the matrix. ! implicit none integer, parameter :: rk = kind ( 1.0D+00 ) integer, parameter :: n = 5 real ( kind = rk ) a(n,n) integer i integer j do j = 1, n do i = 1, n a(i,j) = 1.8144D+00 / real ( i + j + 1, kind = rk ) end do end do return end subroutine wilk05_condition ( cond ) !*****************************************************************************80 ! !! wilk05_condition() returns the L1 condition of the WILK05 matrix. ! ! Licensing: ! ! This code is distributed under the MIT license. ! ! Modified: ! ! 07 February 2015 ! ! Author: ! ! John Burkardt ! ! Reference: ! ! James Wilkinson, ! Error Analysis of Direct Methods of Matrix Inversion, ! Journal of the Association for Computing Machinery, ! Volume 8, 1961, pages 281-330. ! ! Output: ! ! real ( kind = rk ) COND, the L1 condition. ! implicit none integer, parameter :: rk = kind ( 1.0D+00 ) real ( kind = rk ) a_norm real ( kind = rk ) b_norm real ( kind = rk ) cond a_norm = 1.98288D+00 b_norm = 4.002777777857721D+06 cond = a_norm * b_norm return end subroutine wilk05_determinant ( determ ) !*****************************************************************************80 ! !! wilk05_determinant() returns the determinant of the WILK05 matrix. ! ! Licensing: ! ! This code is distributed under the MIT license. ! ! Modified: ! ! 22 October 2007 ! ! Author: ! ! John Burkardt ! ! Output: ! ! real ( kind = rk ) DETERM, the determinant. ! implicit none integer, parameter :: rk = kind ( 1.0D+00 ) real ( kind = rk ) determ determ = 3.7995D-15 return end subroutine wilk05_inverse ( a ) !*****************************************************************************80 ! !! wilk05_inverse() returns the inverse of the WILK05 matrix. ! ! Licensing: ! ! This code is distributed under the MIT license. ! ! Modified: ! ! 03 November 2007 ! ! Author: ! ! John Burkardt ! ! Output: ! ! real ( kind = rk ) A(5,5), the matrix. ! implicit none integer, parameter :: rk = kind ( 1.0D+00 ) real ( kind = rk ) a(5,5) ! ! Note that the matrix entries are listed by column. ! real ( kind = rk ), dimension ( 5, 5 ), save :: a_save = reshape ( (/ & 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 /), (/ 5, 5 /) ) call r8mat_copy ( 5, 5, a_save, a ) return end subroutine wilk12_matrix ( a ) !*****************************************************************************80 ! !! wilk12_matrix() returns the WILK12 matrix. ! ! Example: ! ! 12 11 0 0 0 0 0 0 0 0 0 0 ! 11 11 10 0 0 0 0 0 0 0 0 0 ! 10 10 10 9 0 0 0 0 0 0 0 0 ! 9 9 9 9 8 0 0 0 0 0 0 0 ! 8 8 8 8 8 7 0 0 0 0 0 0 ! 7 7 7 7 7 7 6 0 0 0 0 0 ! 6 6 6 6 6 6 6 5 0 0 0 0 ! 5 5 5 5 5 5 5 5 4 0 0 0 ! 4 4 4 4 4 4 4 4 4 3 0 0 ! 3 3 3 3 3 3 3 3 3 3 2 0 ! 2 2 2 2 2 2 2 2 2 2 2 1 ! 1 1 1 1 1 1 1 1 1 1 1 1 ! ! Properties: ! ! A is generally not symmetric: A' /= A. ! ! A is integral, therefore det ( A ) is integral, and ! det ( A ) * inverse ( A ) is integral. ! ! det ( A ) = 1. ! ! A is lower Hessenberg. ! ! The smaller eigenvalues are very ill conditioned. ! ! Licensing: ! ! This code is distributed under the MIT license. ! ! Modified: ! ! 28 May 2002 ! ! Author: ! ! John Burkardt ! ! Reference: ! ! James Wilkinson, ! Rounding Errors in Algebraic Processes, ! Prentice Hall, 1963, ! page 151. ! ! Output: ! ! real ( kind = rk ) A(12,12), the matrix. ! implicit none integer, parameter :: rk = kind ( 1.0D+00 ) integer, parameter :: n = 12 real ( kind = rk ) a(n,n) integer i integer j do j = 1, n do i = 1, n if ( j <= i + 1 ) then a(i,j) = real ( n + 1 - max ( i, j ), kind = rk ) else a(i,j) = 0.0D+00 end if end do end do return end subroutine wilk12_condition ( value ) !*****************************************************************************80 ! !! wilk12_condition() returns the L1 condition of the WILK12 matrix. ! ! Licensing: ! ! This code is distributed under the MIT license. ! ! Modified: ! ! 18 April 2015 ! ! Author: ! ! John Burkardt ! ! Output: ! ! real ( kind = rk ) VALUE, the L1 condition. ! implicit none integer, parameter :: rk = kind ( 1.0D+00 ) real ( kind = rk ) a_norm real ( kind = rk ) b_norm real ( kind = rk ) value a_norm = 78.0D+00 b_norm = 87909427.13689443D+00 value = a_norm * b_norm return end subroutine wilk12_determinant ( value ) !*****************************************************************************80 ! !! wilk12_determinant() returns the determinant of the WILK12 matrix. ! ! Licensing: ! ! This code is distributed under the MIT license. ! ! Modified: ! ! 17 October 2007 ! ! Author: ! ! John Burkardt ! ! Output: ! ! real ( kind = rk ) VALUE, the determinant. ! implicit none integer, parameter :: rk = kind ( 1.0D+00 ) real ( kind = rk ) value value = 1.0D+00 return end subroutine wilk12_eigen_right ( a ) !*****************************************************************************80 ! !! wilk12_eigen_right() returns the right eigenvectors of the WILK12 matrix. ! ! Licensing: ! ! This code is distributed under the MIT license. ! ! Modified: ! ! 15 June 2011 ! ! Author: ! ! John Burkardt ! ! Output: ! ! real ( kind = rk ) A(12,12), the right eigenvector matrix. ! implicit none integer, parameter :: rk = kind ( 1.0D+00 ) real ( kind = rk ) a(12,12) ! ! Note that the matrix entries are listed by column. ! real ( kind = rk ), dimension ( 12, 12 ), save :: a_save = reshape ( (/ & 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 /), & (/ 12, 12 /) ) call r8mat_copy ( 12, 12, a_save, a ) return end subroutine wilk12_eigenvalues ( lambda ) !*****************************************************************************80 ! !! wilk12_eigenvalues() returns the eigenvalues of the WILK12 matrix. ! ! Example: ! ! 32.2288915 ! 20.1989886 ! 12.3110774 ! 6.96153309 ! 3.51185595 ! 1.55398871 ! 0.643505319 ! 0.284749721 ! 0.143646520 ! 0.081227659240405 ! 0.049507429185278 ! 0.031028060644010 ! ! Licensing: ! ! This code is distributed under the MIT license. ! ! Modified: ! ! 15 June 2011 ! ! Author: ! ! John Burkardt ! ! Output: ! ! real ( kind = rk ) LAMBDA(12), the eigenvalues. ! implicit none integer, parameter :: rk = kind ( 1.0D+00 ) real ( kind = rk ) lambda(12) real ( kind = rk ), dimension ( 12 ), save :: lambda_save = (/ & 32.228891501572150D+00, & 20.198988645877105D+00, & 12.311077400868518D+00, & 6.961533085567122D+00, & 3.511855948580745D+00, & 1.553988709132093D+00, & 0.643505318981149D+00, & 0.284749720568806D+00, & 0.143646526818415D+00, & 0.081227617477438D+00, & 0.049507500324902D+00, & 0.031028024231570D+00 /) call r8vec_copy ( 12, lambda_save, lambda ) return end subroutine wilk20_matrix ( alpha, a ) !*****************************************************************************80 ! !! wilk20_matrix() returns the WILK20 matrix. ! ! Formula: ! ! if ( I = J ) ! A(I,J) = I ! else if ( I = J-1 ) ! A(I,J) = 20 ! else if ( I = N, J = 1 ) then ! A(I,J) = ALPHA ! else ! A(I,J) = 0 ! ! Example: ! ! 1 20 . . . . . . . . . . . . . . . . . . ! . 2 20 . . . . . . . . . . . . . . . . . ! . . 3 20 . . . . . . . . . . . . . . . . ! . . . 4 20 . . . . . . . . . . . . . . . ! . . . . 5 20 . . . . . . . . . . . . . . ! . . . . . 6 20 . . . . . . . . . . . . . ! . . . . . . 7 20 . . . . . . . . . . . . ! . . . . . . . 8 20 . . . . . . . . . . . ! . . . . . . . . 9 20 . . . . . . . . . . ! . . . . . . . . . 10 20 . . . . . . . . . ! . . . . . . . . . . 11 20 . . . . . . . . ! . . . . . . . . . . . 12 20 . . . . . . . ! . . . . . . . . . . . . 13 20 . . . . . . ! . . . . . . . . . . . . . 14 20 . . . . . ! . . . . . . . . . . . . . . 15 20 . . . . ! . . . . . . . . . . . . . . . 16 20 . . . ! . . . . . . . . . . . . . . . . 17 20 . . ! . . . . . . . . . . . . . . . . . 18 20 . ! . . . . . . . . . . . . . . . . . . 19 20 ! ALPHA. . . . . . . . . . . . . . . . . . 20 ! ! Properties: ! ! A is generally not symmetric: A' /= A. ! ! If ALPHA = 0, then ! ! LAMBDA(I) = i ! ! and the characteristic equation is ! ! product ( 1 <= I <= 20 ) ( I - LAMBDA ) = 0 ! ! and the condition number of eigenvalue I is ! ! COND(LAMBDA(I)) = (20-I)! * (I-1)! / 20**19. ! ! If ALPHA is nonzero, the characteristic equation is ! ! product ( 1 <= I <= 20 ) ( I - LAMBDA ) = 20**19 * ALPHA. ! ! If ALPHA = 1.0D-10, there are 6 real eigenvalues, and 14 complex ! eigenvalues with considerable imaginary parts. ! ! Licensing: ! ! This code is distributed under the MIT license. ! ! Modified: ! ! 15 April 1999 ! ! Author: ! ! John Burkardt ! ! Reference: ! ! Robert Gregory, David Karney, ! A Collection of Matrices for Testing Computational Algorithms, ! Wiley, 1969, ! ISBN: 0882756494, ! LC: QA263.68 ! ! Joan Westlake, ! A Handbook of Numerical Matrix Inversion and Solution of ! Linear Equations, ! John Wiley, 1968, ! ISBN13: 978-0471936756, ! LC: QA263.W47. ! ! James Wilkinson, ! Rounding Errors in Algebraic Processes, ! Prentice Hall, 1963, ! page 138. ! ! Input: ! ! real ( kind = rk ) ALPHA, the perturbation. ! ! Output: ! ! real ( kind = rk ) A(20,20), the matrix. ! implicit none integer, parameter :: rk = kind ( 1.0D+00 ) integer, parameter :: n = 20 real ( kind = rk ) a(n,n) real ( kind = rk ) alpha integer i integer j do i = 1, n do j = 1, n if ( i == j ) then a(i,j) = real ( i, kind = rk ) else if ( j == i + 1 ) then a(i,j) = real ( n, kind = rk ) else a(i,j) = 0.0D+00 end if end do end do a(n,1) = alpha return end subroutine wilk21_matrix ( n, a ) !*****************************************************************************80 ! !! wilk21_matrix() returns the WILK21 matrix. ! ! Discussion: ! ! By using values of N not equal to 21, WILK21 can return a variety ! of related matrices. ! ! Formula: ! ! if ( I = J ) ! A(I,J) = nint ( abs ( i - real ( n+1 ) / 2.0D+00 ) ) ! else if ( I = J - 1 or I = J + 1 ) ! A(I,J) = 1 ! else ! A(I,J) = 0 ! ! Example: ! ! N = 21 ! ! 10 1 . . . . . . . . . . . . . . . . . . . ! 1 9 1 . . . . . . . . . . . . . . . . . . ! . 1 8 1 . . . . . . . . . . . . . . . . . ! . . 1 7 1 . . . . . . . . . . . . . . . . ! . . . 1 6 1 . . . . . . . . . . . . . . . ! . . . . 1 5 1 . . . . . . . . . . . . . . ! . . . . . 1 4 1 . . . . . . . . . . . . . ! . . . . . . 1 3 1 . . . . . . . . . . . . ! . . . . . . . 1 2 1 . . . . . . . . . . . ! . . . . . . . . 1 1 1 . . . . . . . . . . ! . . . . . . . . . 1 0 1 . . . . . . . . . ! . . . . . . . . . . 1 1 1 . . . . . . . . ! . . . . . . . . . . . 1 2 1 . . . . . . . ! . . . . . . . . . . . . 1 3 1 . . . . . . ! . . . . . . . . . . . . . 1 4 1 . . . . . ! . . . . . . . . . . . . . . 1 5 1 . . . . ! . . . . . . . . . . . . . . . 1 6 1 . . . ! . . . . . . . . . . . . . . . . 1 7 1 . . ! . . . . . . . . . . . . . . . . . 1 8 1 . ! . . . . . . . . . . . . . . . . . . 1 9 1 ! . . . . . . . . . . . . . . . . . . . 1 10 ! ! Properties: ! ! A is tridiagonal. ! ! Because A is tridiagonal, it has property A (bipartite). ! ! A is integral, therefore det ( A ) is integral, and ! det ( A ) * inverse ( A ) is integral. ! ! A is symmetric: A' = A. ! ! Because A is symmetric, it is normal. ! ! Because A is normal, it is diagonalizable. ! ! A is persymmetric: A(I,J) = A(N+1-J,N+1-I). ! ! Licensing: ! ! This code is distributed under the MIT license. ! ! Modified: ! ! 15 April 1999 ! ! Author: ! ! John Burkardt ! ! Reference: ! ! James Wilkinson, ! The Algebraic Eigenvalue Problem, ! Oxford University Press, 1965, ! page 308. ! ! Input: ! ! integer N, the order of the matrix. ! ! Output: ! ! real ( kind = rk ) A(N,N), the matrix. ! implicit none integer, parameter :: rk = kind ( 1.0D+00 ) integer n real ( kind = rk ) a(n,n) integer i integer j do i = 1, n do j = 1, n if ( i == j ) then a(i,j) = anint ( abs ( real ( i, kind = rk ) & - real ( n + 1, kind = rk ) / 2.0D+00 ) ) else if ( j == i + 1 ) then a(i,j) = 1.0D+00 else if ( j == 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 ) !*****************************************************************************80 ! !! wilk21_determinant() returns the determinant of the WILK21 matrix. ! ! Licensing: ! ! This code is distributed under the MIT license. ! ! Modified: ! ! 21 November 2007 ! ! Author: ! ! John Burkardt ! ! Input: ! ! integer N, the order of the matrix. ! ! Output: ! ! real ( kind = rk ) DETERM, the determinant. ! implicit none integer, parameter :: rk = kind ( 1.0D+00 ) integer n real ( kind = rk ) d(n) real ( kind = rk ) determ real ( kind = rk ) determ_nm1 real ( kind = rk ) determ_nm2 integer i do i = 1, n d(i) = anint ( abs ( real ( i, kind = rk ) & - real ( n + 1, kind = rk ) / 2.0D+00 ) ) end do determ_nm1 = d(n) if ( n == 1 ) then determ = determ_nm1 return end if determ_nm2 = determ_nm1 determ_nm1 = d(n-1) * d(n) - 1.0D+00 if ( n == 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 ) !*****************************************************************************80 ! !! wilk21_inverse() returns the inverse of the WILK21 matrix. ! ! Licensing: ! ! This code is distributed under the MIT license. ! ! Modified: ! ! 22 November 2007 ! ! Author: ! ! John Burkardt ! ! Reference: ! ! CM daFonseca, J Petronilho, ! Explicit Inverses of Some Tridiagonal Matrices, ! Linear Algebra and Its Applications, ! Volume 325, 2001, pages 7-21. ! ! Input: ! ! integer N, the order of the matrix. ! ! Output: ! ! real ( kind = rk ) A(N,N), the inverse of the matrix. ! implicit none integer, parameter :: rk = kind ( 1.0D+00 ) integer n real ( kind = rk ) a(n,n) real ( kind = rk ) d(n) real ( kind = rk ) e(n) integer i integer j real ( kind = rk ) r8_mop real ( kind = rk ) y(n) do i = 1, n y(i) = anint ( abs ( real ( i, kind = rk ) & - real ( n + 1, kind = rk ) / 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 ) * product ( d(i+1:n) ) / product ( e(j:n) ) end do do j = i + 1, n a(i,j) = r8_mop ( i + j ) * product ( d(j+1:n) ) / product ( e(i:n) ) end do end do return end subroutine wilson_matrix ( a ) !*****************************************************************************80 ! !! wilson_matrix() returns the WILSON matrix. ! ! Example: ! ! 5 7 6 5 ! 7 10 8 7 ! 6 8 10 9 ! 5 7 9 10 ! ! Properties: ! ! The Higham/MATLAB version of this matrix has rows and columns ! 1 and 2 interchanged. ! ! A is symmetric: A' = A. ! ! Because A is symmetric, it is normal. ! ! Because A is normal, it is diagonalizable. ! ! A is positive definite. ! ! det ( A ) = 1. ! ! A is ill-conditioned. ! ! A * X = B, where X is the Wilson solution vector, and B is the ! Wilson right hand side. ! ! A is integral, therefore det ( A ) is integral, and ! det ( A ) * inverse ( A ) is integral. ! ! Licensing: ! ! This code is distributed under the MIT license. ! ! Modified: ! ! 22 July 2008 ! ! Author: ! ! John Burkardt ! ! Reference: ! ! Joan Westlake, ! A Handbook of Numerical Matrix Inversion and Solution of ! Linear Equations, ! John Wiley, 1968, ! ISBN13: 978-0471936756, ! LC: QA263.W47. ! ! Output: ! ! real ( kind = rk ) A(4,4), the matrix. ! implicit none integer, parameter :: rk = kind ( 1.0D+00 ) real ( kind = rk ) a(4,4) ! ! Note that the matrix entries are listed by column. ! real ( kind = rk ), dimension ( 4, 4 ), save :: a_save = reshape ( (/ & 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 /), (/ 4, 4 /) ) call r8mat_copy ( 4, 4, a_save, a ) return end subroutine wilson_condition ( cond ) !*****************************************************************************80 ! !! wilson_condition() returns the L1 condition of the WILSON matrix. ! ! Licensing: ! ! This code is distributed under the MIT license. ! ! Modified: ! ! 08 April 2012 ! ! Author: ! ! John Burkardt ! ! Input: ! ! integer N, the order of the matrix. ! ! Output: ! ! real ( kind = rk ) COND, the L1 condition. ! implicit none integer, parameter :: rk = kind ( 1.0D+00 ) real ( kind = rk ) cond cond = 4488.0D+00 return end subroutine wilson_determinant ( n, determ ) !*****************************************************************************80 ! !! wilson_determinant() returns the determinant of the WILSON matrix. ! ! Licensing: ! ! This code is distributed under the MIT license. ! ! Modified: ! ! 09 October 2007 ! ! Author: ! ! John Burkardt ! ! Input: ! ! integer N, the order of the matrix. ! ! Output: ! ! real ( kind = rk ) DETERM, the determinant. ! implicit none integer, parameter :: rk = kind ( 1.0D+00 ) real ( kind = rk ) determ integer n call i4_fake_use ( n ) determ = 1.0D+00 return end subroutine wilson_eigen_right ( a ) !*****************************************************************************80 ! !! wilson_eigen_right() returns the right eigenvectors of the WILSON matrix. ! ! Licensing: ! ! This code is distributed under the MIT license. ! ! Modified: ! ! 15 June 2011 ! ! Author: ! ! John Burkardt ! ! Output: ! ! real ( kind = rk ) A(4,4), the right eigenvector matrix. ! implicit none integer, parameter :: rk = kind ( 1.0D+00 ) real ( kind = rk ) a(4,4) ! ! Note that the matrix entries are listed by column. ! real ( kind = rk ), dimension ( 4, 4 ), save :: a_save = reshape ( (/ & 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 /), (/ 4, 4 /) ) call r8mat_copy ( 4, 4, a_save, a ) return end subroutine wilson_eigenvalues ( lambda ) !*****************************************************************************80 ! !! wilson_eigenvalues() returns the eigenvalues of the WILSON matrix. ! ! Licensing: ! ! This code is distributed under the MIT license. ! ! Modified: ! ! 10 October 2007 ! ! Author: ! ! John Burkardt ! ! Output: ! ! real ( kind = rk ) X(4), the eigenvalues. ! implicit none integer, parameter :: rk = kind ( 1.0D+00 ) real ( kind = rk ) lambda(4) real ( kind = rk ), dimension ( 4 ), save :: 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 ) !*****************************************************************************80 ! !! wilson_inverse() returns the inverse of the WILSON matrix. ! ! Example: ! ! 68 -41 -17 10 ! -41 25 10 -6 ! -17 10 5 -3 ! 10 -6 -3 2 ! ! Properties: ! ! A is symmetric: A' = A. ! ! Because A is symmetric, it is normal. ! ! Because A is normal, it is diagonalizable. ! ! A is integral, therefore det ( A ) is integral, and ! det ( A ) * inverse ( A ) is integral. ! ! Licensing: ! ! This code is distributed under the MIT license. ! ! Modified: ! ! 22 July 2008 ! ! Author: ! ! John Burkardt ! ! Reference: ! ! Joan Westlake, ! A Handbook of Numerical Matrix Inversion and Solution of ! Linear Equations, ! John Wiley, 1968, ! ISBN13: 978-0471936756, ! LC: QA263.W47. ! ! Output: ! ! real ( kind = rk ) A(4,4), the matrix. ! implicit none integer, parameter :: rk = kind ( 1.0D+00 ) real ( kind = rk ) a(4,4) ! ! Note that the matrix entries are listed by column. ! real ( kind = rk ), dimension ( 4, 4 ), save :: a_save = reshape ( (/ & 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 /), (/ 4, 4 /) ) call r8mat_copy ( 4, 4, a_save, a ) return end subroutine wilson_llt ( a ) !*****************************************************************************80 ! !! wilson_llt() returns the lower Cholesky factor of the WILSON matrix. ! ! Licensing: ! ! This code is distributed under the MIT license. ! ! Modified: ! ! 15 March 2015 ! ! Author: ! ! John Burkardt ! ! Output: ! ! real ( kind = rk ) A(4,4), the matrix. ! implicit none integer, parameter :: rk = kind ( 1.0D+00 ) real ( kind = rk ) a(4,4) ! ! Note that the matrix entries are listed by column. ! real ( kind = rk ), dimension ( 4, 4 ), save :: a_save = reshape ( (/ & 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 /), (/ 4, 4 /) ) call r8mat_copy ( 4, 4, a_save, a ) return end subroutine wilson_plu ( p, l, u ) !*****************************************************************************80 ! !! wilson_plu() returns the PLU factors of the WILSON matrix. ! ! Licensing: ! ! This code is distributed under the MIT license. ! ! Modified: ! ! 27 June 2011 ! ! Author: ! ! John Burkardt ! ! Output: ! ! real ( kind = rk ) P(4,4), L(4,4), U(4,4), the PLU factors. ! implicit none integer, parameter :: rk = kind ( 1.0D+00 ) real ( kind = rk ) l(4,4) real ( kind = rk ), dimension ( 4, 4 ), save :: l_save = reshape ( (/ & 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 /), & (/ 4, 4 /) ) real ( kind = rk ) p(4,4) real ( kind = rk ), dimension ( 4, 4 ), save :: p_save = reshape ( (/ & 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 /), (/ 4, 4 /) ) real ( kind = rk ) u(4,4) real ( kind = rk ), dimension ( 4, 4 ), save :: u_save = reshape ( (/ & 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 /), & (/ 4, 4 /) ) 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 ) !*****************************************************************************80 ! !! wilson_rhs() returns the WILSON right hand side. ! ! Licensing: ! ! This code is distributed under the MIT license. ! ! Modified: ! ! 21 May 2002 ! ! Author: ! ! John Burkardt ! ! Output: ! ! real ( kind = rk ) B(4), the right hand side vector. ! implicit none integer, parameter :: rk = kind ( 1.0D+00 ) real ( kind = rk ) b(4) real ( kind = rk ), dimension ( 4 ), save :: 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 ) !*****************************************************************************80 ! !! wilson_solution() returns the WILSON solution. ! ! Licensing: ! ! This code is distributed under the MIT license. ! ! Modified: ! ! 21 May 2002 ! ! Author: ! ! John Burkardt ! ! Output: ! ! real ( kind = rk ) X(4), the solution vector. ! implicit none integer, parameter :: rk = kind ( 1.0D+00 ) real ( kind = rk ) x(4) real ( kind = rk ), dimension ( 4 ), save :: 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_matrix ( m, n, a ) !*****************************************************************************80 ! !! zero_matrix() returns the ZERO matrix. ! ! Formula: ! ! A(I,J) = 0 ! ! Example: ! ! M = 4, N = 5 ! ! 0 0 0 0 0 ! 0 0 0 0 0 ! 0 0 0 0 0 ! 0 0 0 0 0 ! ! Properties: ! ! A is integral. ! ! A is Toeplitz: constant along diagonals. ! ! A is a Hankel matrix: constant along anti-diagonals. ! ! A is a circulant matrix: each row is shifted once to get the next row. ! ! A is an anticirculant matrix. ! ! A is singular. ! ! A is symmetric: A' = A. ! ! Because A is symmetric, it is normal. ! ! Because A is normal, it is diagonalizable. ! ! LAMBDA(1:N) = 0. ! ! The matrix of eigenvectors of A is I. ! ! det ( A ) = 0. ! ! For any vector v, A*v = 0. ! ! For any matrix B, A*B = B*A = 0. ! ! A is persymmetric: A(I,J) = A(N+1-J,N+1-I). ! ! The family of matrices is nested as a function of N. ! ! Licensing: ! ! This code is distributed under the MIT license. ! ! Modified: ! ! 01 April 2000 ! ! Author: ! ! John Burkardt ! ! Input: ! ! integer M, N, the order of the matrix. ! ! Output: ! ! real ( kind = rk ) A(M,N), the matrix. ! implicit none integer, parameter :: rk = kind ( 1.0D+00 ) integer m integer n real ( kind = rk ) a(m,n) a(1:m,1:n) = 0.0D+00 return end subroutine zero_determinant ( n, determ ) !*****************************************************************************80 ! !! zero_determinant() returns the determinant of the ZERO matrix. ! ! Licensing: ! ! This code is distributed under the MIT license. ! ! Modified: ! ! 21 May 2002 ! ! Author: ! ! John Burkardt ! ! Input: ! ! integer N, the order of the matrix. ! ! Output: ! ! real ( kind = rk ) DETERM, the determinant. ! implicit none integer, parameter :: rk = kind ( 1.0D+00 ) real ( kind = rk ) determ integer n call i4_fake_use ( n ) determ = 0.0D+00 return end subroutine zero_eigen_right ( n, a ) !*****************************************************************************80 ! !! zero_eigen_right() returns the right eigenvectors of the ZERO matrix. ! ! Licensing: ! ! This code is distributed under the MIT license. ! ! Modified: ! ! 26 November 2007 ! ! Author: ! ! John Burkardt ! ! Input: ! ! integer N, the order of the matrix. ! ! Output: ! ! real ( kind = rk ) A(N,N), the matrix. ! implicit none integer, parameter :: rk = kind ( 1.0D+00 ) integer n real ( kind = rk ) a(n,n) integer i integer j do i = 1, n do j = 1, n if ( i == 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 ) !*****************************************************************************80 ! !! zero_eigenvalues() returns the eigenvalues of the ZERO matrix. ! ! Licensing: ! ! This code is distributed under the MIT license. ! ! Modified: ! ! 28 October 2007 ! ! Author: ! ! John Burkardt ! ! Input: ! ! integer N, the order of the matrix. ! ! Output: ! ! real ( kind = rk ) LAMBDA(N), the eigenvalues. ! implicit none integer, parameter :: rk = kind ( 1.0D+00 ) integer n real ( kind = rk ) lambda(n) lambda(1:n) = 0.0D+00 return end subroutine zero_null_left ( m, n, x ) !*****************************************************************************80 ! !! zero_null_left() returns a left null vector of the ZERO matrix. ! ! Licensing: ! ! This code is distributed under the MIT license. ! ! Modified: ! ! 06 March 2015 ! ! Author: ! ! John Burkardt ! ! Input: ! ! integer M, N, the order of the matrix. ! ! Output: ! ! real ( kind = rk ) X(M), a left null vector. ! implicit none integer, parameter :: rk = kind ( 1.0D+00 ) integer m integer n real ( kind = rk ) x(m) call i4_fake_use ( n ) x(1:m) = 1.0D+00 return end subroutine zero_null_right ( m, n, x ) !*****************************************************************************80 ! !! zero_null_right() returns a right null vector of the ZERO matrix. ! ! Licensing: ! ! This code is distributed under the MIT license. ! ! Modified: ! ! 28 October 2007 ! ! Author: ! ! John Burkardt ! ! Input: ! ! integer M, N, the order of the matrix. ! ! Output: ! ! real ( kind = rk ) X(N), a null vector. ! implicit none integer, parameter :: rk = kind ( 1.0D+00 ) integer m integer n real ( kind = rk ) x(n) call i4_fake_use ( m ) x(1:n) = 1.0D+00 return end subroutine zielke_matrix ( n, x, y, z, a ) !*****************************************************************************80 ! !! zielke_matrix() returns the ZIELKE matrix. ! ! Formula: ! ! if ( I == J ) then ! if ( I + J <= N ) ! A(I,J) = X+Y+Z ! else if ( I + J ) < 2*N ) ! A(I,J) = X +Z ! else ! A(I,J) = X-Y+Z ! else ! if ( I + J <= N ) ! A(I,J) = X+Y ! else ! A(I,J) = X ! ! Example: ! ! N = 5, X = 1, Y = 2, Z = 5 ! ! 8 3 3 3 1 ! 3 8 3 1 1 ! 3 3 6 1 1 ! 3 1 1 6 1 ! 1 1 1 1 4 ! ! Properties: ! ! A is symmetric: A' = A. ! ! Because A is symmetric, it is normal. ! ! Because A is normal, it is diagonalizable. ! ! There are clusters of eigenvalues. ! ! Licensing: ! ! This code is distributed under the MIT license. ! ! Modified: ! ! 15 April 1999 ! ! Author: ! ! John Burkardt ! ! Reference: ! ! Gerhard Zielke, ! Testmatrizen mit maximaler Konditionszahl, ! (Test matrices with maximal condition number), ! Computing, ! Volume 13, Number 1, March 1974, pages 33-54. ! ! Input: ! ! integer N, the order of the matrix. ! ! real ( kind = rk ) X, Y, Z, parameters that define the matrix. ! ! Output: ! ! real ( kind = rk ) A(N,N), the matrix. ! implicit none integer, parameter :: rk = kind ( 1.0D+00 ) integer n real ( kind = rk ) a(n,n) integer i integer j real ( kind = rk ) x real ( kind = rk ) y real ( kind = rk ) z do i = 1, n do j = 1, n if ( i == j ) then if ( i + j <= n ) then a(i,j) = x + y + z else if ( i + j < 2 * n ) then a(i,j) = x + z else a(i,j) = x - y + z end if else if ( i + j <= n ) then a(i,j) = x + y else a(i,j) = x end if end if end do end do return end