lapack_diag.F90 2.89 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 `````` 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 `````` Gregor Michalicek committed Aug 14, 2019 26 `````` REAL :: eigTemp(hmat%matsize1) `````` Daniel Wortmann committed Feb 26, 2018 27 `````` `````` Daniel Wortmann committed Aug 09, 2018 28 `````` `````` Daniel Wortmann committed Feb 26, 2018 29 30 31 32 33 34 `````` 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),& `````` Gregor Michalicek committed Aug 14, 2019 35 `````` 0.0,0.0,1,ne,abstol,m,eigTemp,zmat%data_r,SIZE(zmat%data_r,1),dumrwork,-1, iwork, ifail, info) `````` Daniel Wortmann committed Feb 26, 2018 36 37 `````` lwork=dumrwork(1) ALLOCATE(rwork(lwork)) `````` Daniel Wortmann committed Aug 09, 2018 38 `````` IF (info.NE.0) CALL judft_error("Diagonalization via LAPACK failed (Workspace)",no=info) `````` Daniel Wortmann committed Feb 26, 2018 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),& `````` Gregor Michalicek committed Aug 14, 2019 40 `````` 0.0,0.0,1,ne,abstol,m,eigTemp,zmat%data_r,SIZE(zmat%data_r,1),rwork, lwork, iwork, ifail, info) `````` Daniel Wortmann committed Feb 26, 2018 41 42 43 44 `````` 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),& `````` Gregor Michalicek committed Aug 14, 2019 45 `````` 0.0,0.0,1,ne,abstol,m,eigTemp,zmat%data_c,SIZE(zmat%data_c,1),dumwork,-1,rwork,iwork,ifail,info) `````` Daniel Wortmann committed Feb 26, 2018 46 47 `````` lwork=dumwork(1) ALLOCATE(work(lwork)) `````` Daniel Wortmann committed Aug 09, 2018 48 `````` IF (info.NE.0) CALL judft_error("Diagonalization via LAPACK failed (Workspace)",no=info) `````` Daniel Wortmann committed Feb 26, 2018 49 50 `````` !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),& `````` Gregor Michalicek committed Aug 14, 2019 51 `````` 0.0,0.0,1,ne,abstol,m,eigTemp,zmat%data_c,SIZE(zmat%data_c,1),work,lwork,rwork,iwork,ifail,info) `````` Daniel Wortmann committed Feb 26, 2018 52 `````` ENDIF `````` Gregor Michalicek committed Aug 14, 2019 53 `````` eig(:SIZE(eig)) = eigTemp(:SIZE(eig)) `````` Daniel Wortmann committed Aug 09, 2018 54 `````` IF (info.NE.0) CALL judft_error("Diagonalization via LAPACK failed(zhegvx/dsygvx)",no=info) `````` Daniel Wortmann committed Feb 26, 2018 55 56 57 `````` IF (m.NE.ne) CALL judft_error("Diagonalization via LAPACK failed failed without explicit errorcode.") END SUBROUTINE lapack_diag END MODULE m_lapack_diag``````