LCOV - code coverage report
Current view: top level - diagonalization - lapack_diag.F90 (source / functions) Hit Total Coverage
Test: combined.info Lines: 25 25 100.0 %
Date: 2019-09-08 04:53:50 Functions: 1 1 100.0 %

          Line data    Source code
       1             : !--------------------------------------------------------------------------------
       2             : ! Copyright (c) 2016 Peter Grünberg Institut, Forschungszentrum Jülich, Germany
       3             : ! This file is part of FLEUR and available as free software under the conditions
       4             : ! of the MIT license as expressed in the LICENSE file in more detail.
       5             : !--------------------------------------------------------------------------------
       6             : MODULE m_lapack_diag
       7             :   USE m_types_mat
       8             :   USE m_judft
       9             : IMPLICIT NONE
      10             :   CONTAINS
      11         304 :   SUBROUTINE lapack_diag(hmat,smat,ne,eig,zmat)
      12             :     !Simple driver to solve Generalized Eigenvalue Problem using LAPACK routine
      13             :     IMPLICIT NONE
      14             :     TYPE(t_mat),INTENT(INOUT)  :: hmat,smat
      15             :     INTEGER,INTENT(INOUT)      :: ne
      16             :     CLASS(t_mat),ALLOCATABLE,INTENT(OUT)    :: zmat
      17             :     REAL,INTENT(OUT)           :: eig(:)
      18             : 
      19             :     INTEGER            :: lwork,info,m
      20         304 :     INTEGER,ALLOCATABLE:: ifail(:),iwork(:)
      21         304 :     COMPLEX,ALLOCATABLE:: work(:)
      22         304 :     REAL,ALLOCATABLE   :: rwork(:)
      23             :     REAL               :: dumrwork(1),abstol
      24             :     COMPLEX            :: dumwork(1)
      25             :     REAL,external      :: dlamch
      26         608 :     REAL               :: eigTemp(hmat%matsize1)
      27             : 
      28             :     
      29         304 :     ALLOCATE(t_mat::zmat)
      30         304 :     CALL zmat%alloc(hmat%l_real,hmat%matsize1,ne)
      31         304 :     abstol=2*dlamch('S')
      32         304 :     IF (hmat%l_real) THEN
      33         154 :        ALLOCATE(iwork(5*hmat%matsize1),ifail(hmat%matsize1))
      34             :        CALL dsygvx(1,'V','I','U', hmat%matsize1,hmat%data_r,SIZE(hmat%data_r,1),smat%data_r,SIZE(smat%data_r,1),&
      35         154 :             0.0,0.0,1,ne,abstol,m,eigTemp,zmat%data_r,SIZE(zmat%data_r,1),dumrwork,-1, iwork, ifail, info)
      36         154 :        lwork=dumrwork(1)
      37         154 :        ALLOCATE(rwork(lwork))
      38         154 :        IF (info.NE.0) CALL judft_error("Diagonalization via LAPACK failed (Workspace)",no=info)
      39             :        CALL dsygvx(1,'V','I','U', hmat%matsize1,hmat%data_r,SIZE(hmat%data_r,1),smat%data_r,SIZE(smat%data_r,1),&
      40         154 :             0.0,0.0,1,ne,abstol,m,eigTemp,zmat%data_r,SIZE(zmat%data_r,1),rwork, lwork, iwork, ifail, info)
      41             :     ELSE
      42         150 :        ALLOCATE(rwork(7*hmat%matsize1),iwork(5*hmat%matsize1),ifail(hmat%matsize1))
      43             :        !Do a workspace query
      44             :        CALL zhegvx(1,'V','I','U',hmat%matsize1,hmat%data_c,SIZE(hmat%data_c,1),smat%data_c,SIZE(smat%data_c,1),&
      45         150 :             0.0,0.0,1,ne,abstol,m,eigTemp,zmat%data_c,SIZE(zmat%data_c,1),dumwork,-1,rwork,iwork,ifail,info)
      46         150 :        lwork=dumwork(1)
      47         150 :        ALLOCATE(work(lwork))
      48         150 :        IF (info.NE.0) CALL judft_error("Diagonalization via LAPACK failed (Workspace)",no=info)
      49             :        !Perform diagonalization
      50             :        CALL zhegvx(1,'V','I','U',hmat%matsize1,hmat%data_c,SIZE(hmat%data_c,1),smat%data_c,SIZE(smat%data_c,1),&
      51         150 :             0.0,0.0,1,ne,abstol,m,eigTemp,zmat%data_c,SIZE(zmat%data_c,1),work,lwork,rwork,iwork,ifail,info)
      52             :     ENDIF
      53         304 :     eig(:MIN(SIZE(eig),SIZE(eigTemp))) = eigTemp(:MIN(SIZE(eig),SIZE(eigTemp)))
      54         304 :     IF (info.NE.0) CALL judft_error("Diagonalization via LAPACK failed(zhegvx/dsygvx)",no=info)
      55         304 :     IF (m.NE.ne) CALL judft_error("Diagonalization via LAPACK failed failed without explicit errorcode.")
      56         608 :   END SUBROUTINE lapack_diag
      57             : END MODULE m_lapack_diag

Generated by: LCOV version 1.13