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