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        2470 :   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        2470 :     INTEGER,ALLOCATABLE:: ifail(:),iwork(:)
      21        2470 :     COMPLEX,ALLOCATABLE:: work(:)
      22        2470 :     REAL,ALLOCATABLE   :: rwork(:)
      23             :     REAL               :: dumrwork(1),abstol
      24             :     COMPLEX            :: dumwork(1)
      25             :     REAL,external      :: dlamch
      26        2470 :     REAL               :: eigTemp(hmat%matsize1)
      27             : 
      28             :     
      29        2470 :     ALLOCATE(t_mat::zmat)
      30        2470 :     CALL zmat%alloc(hmat%l_real,hmat%matsize1,ne)
      31        2470 :     abstol=2*dlamch('S')
      32        2470 :     IF (hmat%l_real) THEN
      33        1570 :        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         314 :             0.0,0.0,1,ne,abstol,m,eigTemp,zmat%data_r,SIZE(zmat%data_r,1),dumrwork,-1, iwork, ifail, info)
      36         314 :        lwork=dumrwork(1)
      37         942 :        ALLOCATE(rwork(lwork))
      38         314 :        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         314 :             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       15092 :        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        2156 :             0.0,0.0,1,ne,abstol,m,eigTemp,zmat%data_c,SIZE(zmat%data_c,1),dumwork,-1,rwork,iwork,ifail,info)
      46        2156 :        lwork=dumwork(1)
      47        6468 :        ALLOCATE(work(lwork))
      48        2156 :        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        2156 :             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       50090 :     eig(:MIN(SIZE(eig),SIZE(eigTemp))) = eigTemp(:MIN(SIZE(eig),SIZE(eigTemp)))
      54        2470 :     IF (info.NE.0) CALL judft_error("Diagonalization via LAPACK failed(zhegvx/dsygvx)",no=info)
      55        2470 :     IF (m.NE.ne) CALL judft_error("Diagonalization via LAPACK failed failed without explicit errorcode.")
      56        2470 :   END SUBROUTINE lapack_diag
      57             : END MODULE m_lapack_diag