Commit 2aa07066 authored by Matthias Redies's avatar Matthias Redies

Merge branch 'develop' into MetaGGA

parents 59280e06 d8afa3fa
......@@ -7,267 +7,266 @@
!<The eigen routine sets up and solves the generalized eigenvalue problem
!More description at end of file
MODULE m_eigen
USE m_juDFT
IMPLICIT NONE
USE m_juDFT
IMPLICIT NONE
CONTAINS
!>The eigenvalue problem is constructed and solved in this routine. The following steps are performed:
!> 1. Preparation: generate energy parameters, open eig-file
!> 2. CALL to mt_setup() : this constructs the local Hamiltonian (i.e. the Hamiltonian in the \f$ u,\dot u, u_{lo} \f$ basis) LDA+U is also added here
!> 3. within the (collinear)spin and k-point loop: CALL to eigen_hssetup() to generate the matrices, CALL to eigen_diag() to perform diagonalization
!> 4. writing (saving) of eigenvectors
!>
!> The matrices generated and diagonalized here are of type m_mat as defined in m_types_mat.
!>@author D. Wortmann
SUBROUTINE eigen(mpi,stars,sphhar,atoms,obsolete,xcpot,sym,kpts,DIMENSION,vacuum,input,&
cell,enpara,banddos,noco,oneD,hybrid,iter,eig_id,results,inden,v,vx)
!>The eigenvalue problem is constructed and solved in this routine. The following steps are performed:
!> 1. Preparation: generate energy parameters, open eig-file
!> 2. CALL to mt_setup() : this constructs the local Hamiltonian (i.e. the Hamiltonian in the \f$ u,\dot u, u_{lo} \f$ basis) LDA+U is also added here
!> 3. within the (collinear)spin and k-point loop: CALL to eigen_hssetup() to generate the matrices, CALL to eigen_diag() to perform diagonalization
!> 4. writing (saving) of eigenvectors
!>
!> The matrices generated and diagonalized here are of type m_mat as defined in m_types_mat.
!>@author D. Wortmann
SUBROUTINE eigen(mpi,stars,sphhar,atoms,obsolete,xcpot,sym,kpts,DIMENSION,vacuum,input,&
cell,enpara,banddos,noco,oneD,hybrid,iter,eig_id,results,inden,v,vx)
#include"cpp_double.h"
USE m_constants, ONLY : pi_const,sfp_const
USE m_types
USE m_apws
USE m_eigen_hssetup
USE m_pot_io
USE m_eigen_diag
USE m_add_vnonlocal
USE m_subvxc
!USE m_hsefunctional
USE m_mt_setup
USE m_util
USE m_io_hybrid
!USE m_icorrkeys
USE m_eig66_io, ONLY : open_eig, write_eig, close_eig,read_eig
USE m_xmlOutput
USE m_constants, ONLY : pi_const,sfp_const
USE m_types
USE m_apws
USE m_eigen_hssetup
USE m_pot_io
USE m_eigen_diag
USE m_add_vnonlocal
USE m_subvxc
!USE m_hsefunctional
USE m_mt_setup
USE m_util
USE m_io_hybrid
!USE m_icorrkeys
USE m_eig66_io, ONLY : open_eig, write_eig, close_eig,read_eig
USE m_xmlOutput
#ifdef CPP_MPI
USE m_mpi_bc_potden
USE m_mpi_bc_potden
#endif
USE m_symmetrize_matrix
USE m_unfold_band_kpts !used for unfolding bands
USE m_types_mpimat
IMPLICIT NONE
TYPE(t_results),INTENT(INOUT):: results
CLASS(t_xcpot),INTENT(IN) :: xcpot
TYPE(t_mpi),INTENT(IN) :: mpi
TYPE(t_dimension),INTENT(IN) :: DIMENSION
TYPE(t_oneD),INTENT(IN) :: oneD
TYPE(t_hybrid),INTENT(INOUT) :: hybrid
TYPE(t_enpara),INTENT(INOUT) :: enpara
TYPE(t_obsolete),INTENT(IN) :: obsolete
TYPE(t_input),INTENT(IN) :: input
TYPE(t_vacuum),INTENT(IN) :: vacuum
TYPE(t_noco),INTENT(IN) :: noco
TYPE(t_banddos),INTENT(IN) :: banddos
TYPE(t_sym),INTENT(IN) :: sym
TYPE(t_stars),INTENT(IN) :: stars
TYPE(t_cell),INTENT(IN) :: cell
TYPE(t_kpts),INTENT(INOUT) :: kpts
TYPE(t_sphhar),INTENT(IN) :: sphhar
TYPE(t_atoms),INTENT(IN) :: atoms
TYPE(t_potden),INTENT(IN) :: inden,vx
TYPE(t_potden),INTENT(INOUT) :: v !u_setup will modify the potential matrix
USE m_symmetrize_matrix
USE m_unfold_band_kpts !used for unfolding bands
USE m_types_mpimat
IMPLICIT NONE
TYPE(t_results),INTENT(INOUT):: results
CLASS(t_xcpot),INTENT(IN) :: xcpot
TYPE(t_mpi),INTENT(IN) :: mpi
TYPE(t_dimension),INTENT(IN) :: DIMENSION
TYPE(t_oneD),INTENT(IN) :: oneD
TYPE(t_hybrid),INTENT(INOUT) :: hybrid
TYPE(t_enpara),INTENT(INOUT) :: enpara
TYPE(t_obsolete),INTENT(IN) :: obsolete
TYPE(t_input),INTENT(IN) :: input
TYPE(t_vacuum),INTENT(IN) :: vacuum
TYPE(t_noco),INTENT(IN) :: noco
TYPE(t_banddos),INTENT(IN) :: banddos
TYPE(t_sym),INTENT(IN) :: sym
TYPE(t_stars),INTENT(IN) :: stars
TYPE(t_cell),INTENT(IN) :: cell
TYPE(t_kpts),INTENT(INOUT) :: kpts
TYPE(t_sphhar),INTENT(IN) :: sphhar
TYPE(t_atoms),INTENT(IN) :: atoms
TYPE(t_potden),INTENT(IN) :: inden,vx
TYPE(t_potden),INTENT(INOUT) :: v !u_setup will modify the potential matrix
#ifdef CPP_MPI
INCLUDE 'mpif.h'
INCLUDE 'mpif.h'
#endif
! EXTERNAL MPI_BCAST !only used by band_unfolding to broadcast the gvec
! Scalar Arguments
INTEGER,INTENT(IN) :: iter
INTEGER,INTENT(IN) :: eig_id
! Local Scalars
INTEGER jsp,nk,nred,ne_all,ne_found
INTEGER ne,lh0
INTEGER isp,i,j,err
LOGICAL l_wu,l_file,l_real,l_zref
! Local Arrays
INTEGER :: ierr(3)
INTEGER :: neigBuffer(kpts%nkpt,input%jspins)
COMPLEX :: unfoldingBuffer(SIZE(results%unfolding_weights,1),kpts%nkpt,input%jspins) ! needed for unfolding bandstructure mpi case
INTEGER, PARAMETER :: lmaxb = 3
REAL, ALLOCATABLE :: bkpt(:)
REAL, ALLOCATABLE :: eig(:)
COMPLEX, ALLOCATABLE :: vs_mmp(:,:,:,:)
INTEGER :: jsp_m, i_kpt_m, i_m
TYPE(t_tlmplm) :: td
TYPE(t_usdus) :: ud
TYPE(t_lapw) :: lapw
CLASS(t_mat), ALLOCATABLE :: zMat
CLASS(t_mat), ALLOCATABLE :: hmat,smat
CLASS(t_mat), ALLOCATABLE :: smat_unfold !used for unfolding bandstructure
! Variables for HF or hybrid functional calculation
INTEGER :: comm(kpts%nkpt),irank2(kpts%nkpt),isize2(kpts%nkpt), dealloc_stat
character(len=300) :: errmsg
call ud%init(atoms,DIMENSION%jspd)
ALLOCATE (eig(DIMENSION%neigd),bkpt(3))
l_real=sym%invs.AND..NOT.noco%l_noco
! check if z-reflection trick can be used
l_zref=(sym%zrfs.AND.(SUM(ABS(kpts%bk(3,:kpts%nkpt))).LT.1e-9).AND..NOT.noco%l_noco)
IF (mpi%n_size > 1) l_zref = .FALSE.
! Scalar Arguments
INTEGER,INTENT(IN) :: iter
INTEGER,INTENT(IN) :: eig_id
! Local Scalars
INTEGER jsp,nk,nred,ne_all,ne_found
INTEGER ne,lh0
INTEGER isp,i,j,err
LOGICAL l_wu,l_file,l_real,l_zref
! Local Arrays
INTEGER :: ierr(3)
INTEGER :: neigBuffer(kpts%nkpt,input%jspins)
COMPLEX :: unfoldingBuffer(SIZE(results%unfolding_weights,1),kpts%nkpt,input%jspins) ! needed for unfolding bandstructure mpi case
INTEGER, PARAMETER :: lmaxb = 3
REAL, ALLOCATABLE :: bkpt(:)
REAL, ALLOCATABLE :: eig(:)
COMPLEX, ALLOCATABLE :: vs_mmp(:,:,:,:)
INTEGER :: jsp_m, i_kpt_m, i_m
TYPE(t_tlmplm) :: td
TYPE(t_usdus) :: ud
TYPE(t_lapw) :: lapw
CLASS(t_mat), ALLOCATABLE :: zMat
CLASS(t_mat), ALLOCATABLE :: hmat,smat
CLASS(t_mat), ALLOCATABLE :: smat_unfold !used for unfolding bandstructure
! Variables for HF or hybrid functional calculation
INTEGER :: comm(kpts%nkpt),irank2(kpts%nkpt),isize2(kpts%nkpt), dealloc_stat
character(len=300) :: errmsg
call ud%init(atoms,DIMENSION%jspd)
ALLOCATE (eig(DIMENSION%neigd),bkpt(3))
l_real=sym%invs.AND..NOT.noco%l_noco
! check if z-reflection trick can be used
l_zref=(sym%zrfs.AND.(SUM(ABS(kpts%bk(3,:kpts%nkpt))).LT.1e-9).AND..NOT.noco%l_noco)
IF (mpi%n_size > 1) l_zref = .FALSE.
#ifdef CPP_MPI
CALL mpi_bc_potden(mpi,stars,sphhar,atoms,input,vacuum,oneD,noco,v)
CALL mpi_bc_potden(mpi,stars,sphhar,atoms,input,vacuum,oneD,noco,v)
#endif
!IF (mpi%irank.EQ.0) CALL openXMLElementFormPoly('iteration',(/'numberForCurrentRun','overallNumber '/),(/iter,v%iter/),&
! RESHAPE((/19,13,5,5/),(/2,2/)))
! Set up and solve the eigenvalue problem
! loop over spins
! set up k-point independent t(l'm',lm) matrices
CALL mt_setup(atoms,sym,sphhar,input,noco,enpara,inden,v,mpi,results,DIMENSION,td,ud)
neigBuffer = 0
results%neig = 0
results%eig = 1.0e300
unfoldingBuffer = CMPLX(0.0,0.0)
DO jsp = 1,MERGE(1,input%jspins,noco%l_noco)
k_loop:DO nk = mpi%n_start,kpts%nkpt,mpi%n_stride
! Set up lapw list
CALL lapw%init(input,noco, kpts,atoms,sym,nk,cell,l_zref, mpi)
call timestart("Setup of H&S matrices")
CALL eigen_hssetup(jsp,mpi,DIMENSION,hybrid,enpara,input,vacuum,noco,sym,&
stars,cell,sphhar,atoms,ud,td,v,lapw,l_real,smat,hmat)
CALL timestop("Setup of H&S matrices")
IF(hybrid%l_hybrid) THEN
DO i = 1, hmat%matsize1
DO j = 1, i
IF (hmat%l_real) THEN
IF ((i.LE.5).AND.(j.LE.5)) THEN
WRITE(1233,'(2i7,2f15.8)') i, j, hmat%data_r(i,j), hmat%data_r(j,i)
END IF
ELSE
ENDIF
END DO
END DO
!IF (mpi%irank.EQ.0) CALL openXMLElementFormPoly('iteration',(/'numberForCurrentRun','overallNumber '/),(/iter,v%iter/),&
! RESHAPE((/19,13,5,5/),(/2,2/)))
! Set up and solve the eigenvalue problem
! loop over spins
! set up k-point independent t(l'm',lm) matrices
CALL mt_setup(atoms,sym,sphhar,input,noco,enpara,inden,v,mpi,results,DIMENSION,td,ud)
! Write overlap matrix smat to direct access file olap
print *,"Wrong overlap matrix used, fix this later"
CALL write_olap(smat,(jsp-1)*kpts%nkpt+nk) ! Note: At this moment this only works without MPI parallelization
PRINT *,"TODO"
neigBuffer = 0
results%neig = 0
results%eig = 1.0e300
unfoldingBuffer = CMPLX(0.0,0.0)
DO jsp = 1,MERGE(1,input%jspins,noco%l_noco)
k_loop:DO nk = mpi%n_start,kpts%nkpt,mpi%n_stride
! Set up lapw list
CALL lapw%init(input,noco, kpts,atoms,sym,nk,cell,l_zref, mpi)
call timestart("Setup of H&S matrices")
CALL eigen_hssetup(jsp,mpi,DIMENSION,hybrid,enpara,input,vacuum,noco,sym,&
stars,cell,sphhar,atoms,ud,td,v,lapw,l_real,smat,hmat)
CALL timestop("Setup of H&S matrices")
IF(hybrid%l_hybrid) THEN
DO i = 1, hmat%matsize1
DO j = 1, i
IF (hmat%l_real) THEN
IF ((i.LE.5).AND.(j.LE.5)) THEN
WRITE(1233,'(2i7,2f15.8)') i, j, hmat%data_r(i,j), hmat%data_r(j,i)
END IF
ELSE
ENDIF
END DO
END DO
! Write overlap matrix smat to direct access file olap
print *,"Wrong overlap matrix used, fix this later"
CALL write_olap(smat,(jsp-1)*kpts%nkpt+nk) ! Note: At this moment this only works without MPI parallelization
PRINT *,"TODO"
! STOP "TODO"
PRINT *,"BASIS:", lapw%nv(jsp), atoms%nlotot
IF (hybrid%l_addhf) CALL add_Vnonlocal(nk,lapw,atoms,hybrid,dimension,kpts,jsp,results,xcpot,noco,hmat)
IF(hybrid%l_subvxc) THEN
CALL subvxc(lapw,kpts%bk(:,nk),DIMENSION,input,jsp,v%mt(:,0,:,:),atoms,ud,hybrid,enpara%el0,enpara%ello0,&
sym,cell,sphhar,stars,xcpot,mpi,oneD,hmat,vx)
END IF
END IF ! hybrid%l_hybrid
l_wu=.FALSE.
ne_all=DIMENSION%neigd
if (allocated(zmat)) then
deallocate(zmat, stat=dealloc_stat, errmsg=errmsg)
if(dealloc_stat /= 0) call juDFT_error("deallocate failed for zmat",&
hint=errmsg, calledby="eigen.F90")
endif
!Try to symmetrize matrix
CALL symmetrize_matrix(mpi,noco,kpts,nk,hmat,smat)
IF (banddos%unfoldband) THEN
select type(smat)
type is (t_mat)
allocate(t_mat::smat_unfold)
select type(smat_unfold)
type is (t_mat)
smat_unfold=smat
end select
type is (t_mpimat)
allocate(t_mpimat::smat_unfold)
select type(smat_unfold)
type is (t_mpimat)
smat_unfold=smat
end select
end select
END IF
CALL eigen_diag(mpi,hmat,smat,nk,jsp,iter,ne_all,eig,zMat)
CALL smat%free()
DEALLOCATE(hmat,smat, stat=dealloc_stat, errmsg=errmsg)
if(dealloc_stat /= 0) call juDFT_error("deallocate failed for hmat or smat",&
hint=errmsg, calledby="eigen.F90")
! Output results
CALL timestart("EV output")
PRINT *,"BASIS:", lapw%nv(jsp), atoms%nlotot
IF (hybrid%l_addhf) CALL add_Vnonlocal(nk,lapw,atoms,hybrid,dimension,kpts,jsp,results,xcpot,noco,hmat)
IF(hybrid%l_subvxc) THEN
CALL subvxc(lapw,kpts%bk(:,nk),DIMENSION,input,jsp,v%mt(:,0,:,:),atoms,ud,hybrid,enpara%el0,enpara%ello0,&
sym,cell,sphhar,stars,xcpot,mpi,oneD,hmat,vx)
END IF
END IF ! hybrid%l_hybrid
l_wu=.FALSE.
ne_all=DIMENSION%neigd
!Try to symmetrize matrix
CALL symmetrize_matrix(mpi,noco,kpts,nk,hmat,smat)
IF (banddos%unfoldband) THEN
select type(smat)
type is (t_mat)
allocate(t_mat::smat_unfold)
select type(smat_unfold)
type is (t_mat)
smat_unfold=smat
end select
type is (t_mpimat)
allocate(t_mpimat::smat_unfold)
select type(smat_unfold)
type is (t_mpimat)
smat_unfold=smat
end select
end select
END IF
CALL eigen_diag(mpi,hmat,smat,nk,jsp,iter,ne_all,eig,zMat)
CALL smat%free()
CALL hmat%free()
DEALLOCATE(hmat,smat, stat=dealloc_stat, errmsg=errmsg)
if(dealloc_stat /= 0) call juDFT_error("deallocate failed for hmat or smat",&
hint=errmsg, calledby="eigen.F90")
! Output results
CALL timestart("EV output")
#if defined(CPP_MPI)
! Collect number of all eigenvalues
ne_found=ne_all
CALL MPI_ALLREDUCE(ne_found,ne_all,1,MPI_INTEGER,MPI_SUM, mpi%sub_comm,ierr)
ne_all=MIN(DIMENSION%neigd,ne_all)
! Collect number of all eigenvalues
ne_found=ne_all
CALL MPI_ALLREDUCE(ne_found,ne_all,1,MPI_INTEGER,MPI_SUM, mpi%sub_comm,ierr)
ne_all=MIN(DIMENSION%neigd,ne_all)
#else
ne_found=ne_all
#endif
IF (.NOT.zmat%l_real) THEN
zMat%data_c(:lapw%nmat,:ne_found) = CONJG(zMat%data_c(:lapw%nmat,:ne_found))
END IF
CALL write_eig(eig_id, nk,jsp,ne_found,ne_all,&
eig(:ne_found),n_start=mpi%n_size,n_end=mpi%n_rank,zmat=zMat)
neigBuffer(nk,jsp) = ne_found
ne_found=ne_all
#endif
IF (.NOT.zMat%l_real) THEN
zMat%data_c(:lapw%nmat,:ne_found) = CONJG(zMat%data_c(:lapw%nmat,:ne_found))
END IF
CALL write_eig(eig_id, nk,jsp,ne_found,ne_all,&
eig(:ne_found),n_start=mpi%n_size,n_end=mpi%n_rank,zMat=zMat)
neigBuffer(nk,jsp) = ne_found
#if defined(CPP_MPI)
! RMA synchronization
CALL MPI_BARRIER(mpi%MPI_COMM,ierr)
! RMA synchronization
CALL MPI_BARRIER(mpi%MPI_COMM,ierr)
#endif
CALL timestop("EV output")
CALL timestop("EV output")
IF (banddos%unfoldband) THEN
IF (banddos%unfoldband) THEN
CALL calculate_plot_w_n(banddos,cell,kpts,smat_unfold,zMat,lapw,nk,jsp,eig,results,input,atoms,unfoldingBuffer,mpi)
DEALLOCATE(smat_unfold, stat=dealloc_stat, errmsg=errmsg)
if(dealloc_stat /= 0) call juDFT_error("deallocate failed for smat_unfold",&
hint=errmsg, calledby="eigen.F90")
END IF
CALL smat_unfold%free()
DEALLOCATE(smat_unfold, stat=dealloc_stat, errmsg=errmsg)
if(dealloc_stat /= 0) call juDFT_error("deallocate failed for smat_unfold",&
hint=errmsg, calledby="eigen.F90")
END IF
END DO k_loop
END DO ! spin loop ends
call zMat%free()
deallocate(zMat)
END DO k_loop
END DO ! spin loop ends
#ifdef CPP_MPI
IF (banddos%unfoldband) THEN
results%unfolding_weights = CMPLX(0.0,0.0)
IF (banddos%unfoldband) THEN
results%unfolding_weights = CMPLX(0.0,0.0)
CALL MPI_ALLREDUCE(unfoldingBuffer,results%unfolding_weights,SIZE(results%unfolding_weights,1)*SIZE(results%unfolding_weights,2)*SIZE(results%unfolding_weights,3),CPP_MPI_COMPLEX,MPI_SUM,mpi%mpi_comm,ierr)
END IF
CALL MPI_ALLREDUCE(neigBuffer,results%neig,kpts%nkpt*input%jspins,MPI_INTEGER,MPI_SUM,mpi%sub_comm,ierr)
CALL MPI_BARRIER(mpi%MPI_COMM,ierr)
END IF
CALL MPI_ALLREDUCE(neigBuffer,results%neig,kpts%nkpt*input%jspins,MPI_INTEGER,MPI_SUM,mpi%mpi_comm,ierr)
CALL MPI_BARRIER(mpi%MPI_COMM,ierr)
#else
results%neig(:,:) = neigBuffer(:,:)
results%unfolding_weights(:,:,:) = unfoldingBuffer(:,:,:)
results%neig(:,:) = neigBuffer(:,:)
results%unfolding_weights(:,:,:) = unfoldingBuffer(:,:,:)
#endif
! Sorry for the following strange workaround to fill the results%eig array.
! At some point someone should have a closer look at how the eigenvalues are
! distributed and fill the array without using the eigenvalue-IO.
DO jsp = 1,MERGE(1,input%jspins,noco%l_noco)
DO nk = 1,kpts%nkpt
CALL read_eig(eig_id,nk,jsp,results%neig(nk,jsp),results%eig(:,nk,jsp))
! Sorry for the following strange workaround to fill the results%eig array.
! At some point someone should have a closer look at how the eigenvalues are
! distributed and fill the array without using the eigenvalue-IO.
DO jsp = 1,MERGE(1,input%jspins,noco%l_noco)
DO nk = 1,kpts%nkpt
CALL read_eig(eig_id,nk,jsp,results%neig(nk,jsp),results%eig(:,nk,jsp))
#ifdef CPP_MPI
CALL MPI_BARRIER(mpi%MPI_COMM,ierr)
CALL MPI_BARRIER(mpi%MPI_COMM,ierr)
#endif
END DO
END DO
!IF (hybrid%l_hybrid.OR.hybrid%l_calhf) CALL close_eig(eig_id)
IF( input%jspins .EQ. 1 .AND. hybrid%l_hybrid ) THEN
results%te_hfex%valence = 2*results%te_hfex%valence
IF(hybrid%l_calhf) results%te_hfex%core = 2*results%te_hfex%core
END IF
enpara%epara_min = MINVAL(enpara%el0)
enpara%epara_min = MIN(MINVAL(enpara%ello0),enpara%epara_min)
END SUBROUTINE eigen
END DO
END DO
!IF (hybrid%l_hybrid.OR.hybrid%l_calhf) CALL close_eig(eig_id)
IF( input%jspins .EQ. 1 .AND. hybrid%l_hybrid ) THEN
results%te_hfex%valence = 2*results%te_hfex%valence
IF(hybrid%l_calhf) results%te_hfex%core = 2*results%te_hfex%core
END IF
enpara%epara_min = MINVAL(enpara%el0)
enpara%epara_min = MIN(MINVAL(enpara%ello0),enpara%epara_min)
END SUBROUTINE eigen
END MODULE m_eigen
......@@ -97,7 +97,7 @@ CONTAINS
ALLOCATE(hmat_final,mold=smat(1,1))
CALL eigen_redist_matrix(mpi,lapw,atoms,smat,smat_final)
CALL eigen_redist_matrix(mpi,lapw,atoms,hmat,hmat_final,smat_final)
END SUBROUTINE eigen_hssetup
END MODULE m_eigen_hssetup
......@@ -27,16 +27,17 @@ MODULE m_banddos_io
CONTAINS
SUBROUTINE openBandDOSFile(fileID, input, atoms, cell, kpts)
SUBROUTINE openBandDOSFile(fileID, input, atoms, cell, kpts, banddos)
USE m_types
USE hdf5
USE m_cdn_io
TYPE(t_input), INTENT(IN) :: input
TYPE(t_atoms), INTENT(IN) :: atoms
TYPE(t_cell), INTENT(IN) :: cell
TYPE(t_kpts), INTENT(IN) :: kpts
TYPE(t_input), INTENT(IN) :: input
TYPE(t_atoms), INTENT(IN) :: atoms
TYPE(t_cell), INTENT(IN) :: cell
TYPE(t_kpts), INTENT(IN) :: kpts
TYPE(t_banddos), INTENT(IN) :: banddos
INTEGER(HID_T), INTENT(OUT) :: fileID
......@@ -67,6 +68,7 @@ MODULE m_banddos_io
INTEGER :: hdfError, dimsInt(7)
INTEGER :: version
INTEGER :: fakeLogical
REAL :: eFermiPrev
LOGICAL :: l_error
......@@ -98,6 +100,9 @@ MODULE m_banddos_io
CALL h5gcreate_f(fileID, '/general', generalGroupID, hdfError)
CALL io_write_attint0(generalGroupID,'spins',input%jspins)
CALL io_write_attreal0(generalGroupID,'lastFermiEnergy',eFermiPrev)
fakeLogical = 0
IF (banddos%unfoldband) fakeLogical = 1
CALL io_write_attint0(generalGroupID,'bandUnfolding',fakeLogical)
CALL h5gclose_f(generalGroupID, hdfError)
CALL h5gcreate_f(fileID, '/cell', cellGroupID, hdfError)
......@@ -236,12 +241,14 @@ MODULE m_banddos_io
INTEGER(HID_T), INTENT(IN) :: fileID
INTEGER(HID_T) :: eigenvaluesGroupID
INTEGER(HID_T) :: bandUnfoldingGroupID
INTEGER(HID_T) :: eigenvaluesSpaceID, eigenvaluesSetID
INTEGER(HID_T) :: numFoundEigsSpaceID, numFoundEigsSetID
INTEGER(HID_T) :: lLikeChargeSpaceID, lLikeChargeSetID
INTEGER(HID_T) :: jsymSpaceID, jsymSetID
INTEGER(HID_T) :: ksymSpaceID, ksymSetID
INTEGER(HID_T) :: bUWeightsSpaceID, bUWeightsSetID
INTEGER :: hdfError, dimsInt(7)
......@@ -296,6 +303,20 @@ MODULE m_banddos_io
CALL h5gclose_f(eigenvaluesGroupID, hdfError)
IF (banddos%unfoldband) THEN
CALL h5gcreate_f(fileID, '/bandUnfolding', bandUnfoldingGroupID, hdfError)
dims(:3)=(/neigd,kpts%nkpt,input%jspins/)
dimsInt = dims
CALL h5screate_simple_f(3,dims(:3),bUWeightsSpaceID,hdfError)
CALL h5dcreate_f(bandUnfoldingGroupID, "weights", H5T_NATIVE_DOUBLE, bUWeightsSpaceID, buWeightsSetID, hdfError)
CALL h5sclose_f(bUWeightsSpaceID,hdfError)
CALL io_write_real3(bUWeightsSetID,(/1,1,1/),dimsInt(:3), REAL(results%unfolding_weights(:neigd,:,:)))
CALL h5dclose_f(bUWeightsSetID, hdfError)
CALL h5gclose_f(bandUnfoldingGroupID, hdfError)
END IF
END SUBROUTINE
SUBROUTINE io_write_string1(datasetID,dims,stringLength,dataArray)
......
......@@ -209,17 +209,20 @@ CONTAINS
LOGICAL :: write_to_file=.false.
CLASS(t_mat), ALLOCATABLE :: zMat_s
CALL build_primitive_cell(banddos,p_cell,cell)
! method_rubel=.true. !this switch is to switch between overlap matrix and rubel method (without overlap matrix)
DO j = 1, lapw%nv(jsp)
DO i = 1, j-1
IF(smat_unfold%l_real) THEN
smat_unfold%data_r(j,i) = smat_unfold%data_r(i,j)
ELSE
smat_unfold%data_c(j,i) = CONJG(smat_unfold%data_c(i,j))
END IF
END DO
END DO
CALL build_primitive_cell(banddos,p_cell,cell)
IF (.not. method_rubel) THEN
DO j = 1, lapw%nv(jsp)
DO i = 1, j-1
IF(smat_unfold%l_real) THEN
smat_unfold%data_r(j,i) = smat_unfold%data_r(i,j)
ELSE
smat_unfold%data_c(j,i) = CONJG(smat_unfold%data_c(i,j))
END IF
END DO
END DO
END IF
! write_to_file=.true.
IF (write_to_file) THEN
IF (i_kpt==1) THEN
......@@ -233,7 +236,6 @@ CONTAINS
! write(222,'(234f15.8)') zMat%data_r
! write(223,'(234f15.8)') smat_unfold%data_r
! method_rubel=.true. !this switch is to switch between overlap matrix and rubel method (without overlap matrix)
IF (zmat%l_real) THEN
ALLOCATE(w_n(zMat%matsize2))
......
......@@ -127,7 +127,7 @@ SUBROUTINE cdngen(eig_id,mpi,input,banddos,sliceplot,vacuum,&
CALL write_band_sc(kpts,results,eFermiPrev)
END IF
#ifdef CPP_HDF
CALL openBandDOSFile(banddosFile_id,input,atoms,cell,kpts)
CALL openBandDOSFile(banddosFile_id,input,atoms,cell,kpts,banddos)
CALL writeBandDOSData(banddosFile_id,input,atoms,cell,kpts,results,banddos,dos,vacuum)
CALL closeBandDOSFile(banddosFile_id)
#endif
......
<
......@@ -46,7 +46,7 @@ MODULE m_types_mpimat
PROCEDURE,PASS :: generate_full_matrix ! construct full matrix if only upper triangle of hermitian matrix is given
PROCEDURE,PASS :: print_matrix
PROCEDURE,PASS :: from_non_dist
FINAL :: finalize
FINAL :: finalize, finalize_1d, finalize_2d, finalize_3d
END TYPE t_mpimat
PUBLIC t_mpimat
......@@ -295,6 +295,44 @@ CONTAINS
CALL mpimat_free(mat)
END SUBROUTINE finalize
SUBROUTINE finalize_1d(mat)
IMPLICIT NONE
TYPE(t_mpimat),INTENT(INOUT) :: mat(:)
INTEGER :: i
DO i = 1,size(mat)
CALL mpimat_free(mat(i))
ENDDO
END SUBROUTINE finalize_1d
SUBROUTINE finalize_2d(mat)
IMPLICIT NONE
TYPE(t_mpimat),INTENT(INOUT) :: mat(:,:)
INTEGER :: i,j
DO i = 1,size(mat, dim=1)
DO j = 1,size(mat, dim=2)
CALL mpimat_free(mat(i,j))
ENDDO
ENDDO
END SUBROUTINE finalize_2d
SUBROUTINE finalize_3d(mat)
IMPLICIT NONE
TYPE(t_mpimat),INTENT(INOUT) :: mat(:,:,:)
INTEGER :: i,j,k
DO i = 1,size(mat, dim=1)
DO j = 1,size(mat, dim=2)
DO k = 1,size(mat, dim=3)
CALL mpimat_free(mat(i,j,k))
ENDDO
ENDDO
ENDDO
END SUBROUTINE finalize_3d
SUBROUTINE mpimat_free(mat)
IMPLICIT NONE
CLASS(t_mpimat),INTENT(INOUT) :: mat
......@@ -370,8 +408,10 @@ CONTAINS