Skip to content

HTTPS clone URL

Subversion checkout URL

You can clone with HTTPS or Subversion.

Download ZIP
Browse files

Implement eigh() and a test

  • Loading branch information...
commit 9a0b34e22ffee3822da7747ce62efbcaf3e7d8a4 1 parent 67df0d1
@certik authored
View
2  src/CMakeLists.txt
@@ -5,7 +5,7 @@ set(SRC
)
if(WITH_LAPACK)
- set(SRC ${SRC} lapack.f90 splines.f90)
+ set(SRC ${SRC} lapack.f90 splines.f90 linalg.f90)
endif()
if(WITH_HDF5)
View
50 src/linalg.f90
@@ -0,0 +1,50 @@
+module linalg
+use types, only: dp
+use lapack, only: dsygvd
+use utils, only: stop_error
+implicit none
+private
+public eigh
+
+contains
+
+subroutine eigh(Am, Bm, lam, c)
+! solves generalized eigen value problem for all eigenvalues and eigenvectors
+! Am must by symmetric, Bm symmetric positive definite.
+! Only the lower triangular part of Am and Bm is used.
+real(dp), intent(in) :: Am(:,:) ! LHS matrix: Am c = lam Bm c
+real(dp), intent(in) :: Bm(:,:) ! RHS matrix: Am c = lam Bm c
+real(dp), intent(out) :: lam(:) ! eigenvalues: Am c = lam Bm c
+real(dp), intent(out) :: c(:,:) ! eigenvectors: Am c = lam Bm c; c(i,j) = ith component of jth vec.
+integer n
+! lapack variables
+integer lwork, liwork, info
+integer, allocatable:: iwork(:)
+real(dp), allocatable:: Amt(:,:), Bmt(:,:), work(:)
+
+! solve
+n = size(Am,1)
+lwork = 1 + 6*n + 2*n**2
+liwork = 3 + 5*n
+allocate(Amt(n,n), Bmt(n,n), work(lwork), iwork(liwork))
+Amt = Am; Bmt = Bm ! Amt,Bmt temporaries overwritten by dsygvd
+call dsygvd(1,'V','L',n,Amt,n,Bmt,n,lam,work,lwork,iwork,liwork,info)
+if (info /= 0) then
+ print *, "dsygvd returned info =", info
+ if (info < 0) then
+ print *, "the", -info, "-th argument had an illegal value"
+ else if (info <= n) then
+ print *, "the algorithm failed to compute an eigenvalue while working"
+ print *, "on the submatrix lying in rows and columns", 1.0_dp*info/(n+1)
+ print *, "through", mod(info, n+1)
+ else
+ print *, "The leading minor of order ", info-n, &
+ "of B is not positive definite. The factorization of B could ", &
+ "not be completed and no eigenvalues or eigenvectors were computed."
+ end if
+ call stop_error('eigh: dsygvd error')
+end if
+c = Amt
+end subroutine
+
+end module
View
1  tests/CMakeLists.txt
@@ -6,6 +6,7 @@ add_subdirectory(strings)
add_subdirectory(mesh)
if(WITH_LAPACK)
add_subdirectory(splines)
+ add_subdirectory(linalg)
endif()
if(WITH_HDF5)
add_subdirectory(hdf5)
View
12 tests/linalg/CMakeLists.txt
@@ -0,0 +1,12 @@
+include_directories(${PROJECT_BINARY_DIR}/src)
+
+project(linalg)
+
+add_executable(test_eig test_eig.f90)
+set(LAPACK_LIBS
+ lapack
+ blas
+ )
+target_link_libraries(test_eig fortran_utils ${LAPACK_LIBS})
+
+add_test(test_eig ${PROJECT_BINARY_DIR}/test_eig)
View
38 tests/linalg/test_eig.f90
@@ -0,0 +1,38 @@
+program test_mesh
+use types, only: dp
+use utils, only: assert
+use linalg, only: eigh
+implicit none
+
+real(dp), parameter :: eps = 1e-9_dp
+real(dp) :: A(2, 2), B(2, 2), lam(2), c(2, 2), r(2), n
+integer :: i
+A = reshape([1, 0, 0, -1], [2, 2])
+B = reshape([1, 0, 0, 1], [2, 2])
+call eigh(A, B, lam, c)
+! Test eigenvalues:
+call assert(all(abs(lam - [-1, 1]) < eps))
+do i = 1, 2
+ ! Test that c(:, i) are eigenvectors:
+ r = matmul(A-lam(i)*B, c(:, i))
+ call assert(sqrt(dot_product(r, r)) < eps)
+ ! Test that eigenvectors are properly normalized:
+ n = dot_product(c(:, i), matmul(B, c(:, i)))
+ call assert(abs(n - 1) < eps)
+end do
+
+A = reshape([2, -4, -4, 2], [2, 2])
+B = reshape([2, 1, 1, 2], [2, 2])
+call eigh(A, B, lam, c)
+! Test eigenvalues:
+call assert(all(abs(lam - [-2._dp/3, 6._dp]) < eps))
+do i = 1, 2
+ ! Test that c(:, i) are eigenvectors:
+ r = matmul(A-lam(i)*B, c(:, i))
+ call assert(sqrt(dot_product(r, r)) < eps)
+ ! Test that eigenvectors are properly normalized:
+ n = dot_product(c(:, i), matmul(B, c(:, i)))
+ call assert(abs(n - 1) < eps)
+end do
+
+end program
Please sign in to comment.
Something went wrong with that request. Please try again.