Commit 10a7d4db authored by Stefan Rost's avatar Stefan Rost

Merge branch 'develop' of iffgit.fz-juelich.de:fleur/fleur into develop

parents 9ed3bc96 f72baf97
......@@ -49,24 +49,24 @@ CONTAINS
! ..
! .. Allocatable Arrays ..
REAL, ALLOCATABLE :: f(:,:,:,:),g(:,:,:,:)
COMPLEX, ALLOCATABLE :: rho21(:,:,:)
COMPLEX :: rho21
!
CALL timestart("cdnmt")
IF (noco%l_mperp) THEN
IF (denCoeffsOffdiag%l_fmpl) THEN
ALLOCATE ( rho21(atoms%jmtd,0:sphhar%nlhd,atoms%ntype) )
rho21(:,:,:) = cmplx(0.0,0.0)
!ALLOCATE ( rho21(atoms%jmtd,0:sphhar%nlhd,atoms%ntype) )
rho(:,:,:,3:4) = CMPLX(0.0,0.0)
ENDIF
ENDIF
!$OMP PARALLEL DEFAULT(none) &
!$OMP SHARED(usdus,rho,moments,rho21,qmtl) &
!$OMP SHARED(usdus,rho,moments,qmtl) &
!$OMP SHARED(atoms,jsp_start,jsp_end,enpara,vr,denCoeffs,sphhar)&
!$OMP SHARED(orb,noco,denCoeffsOffdiag,jspd)&
!$OMP PRIVATE(itype,na,ispin,l,f,g,nodeu,noded,wronk,i,j,s,qmtllo,qmtt,nd,lh,lp,llp,cs)
!$OMP PRIVATE(itype,na,ispin,l,rho21,f,g,nodeu,noded,wronk,i,j,s,qmtllo,qmtt,nd,lh,lp,llp,cs)
IF (noco%l_mperp) THEN
ALLOCATE ( f(atoms%jmtd,2,0:atoms%lmaxd,jspd),g(atoms%jmtd,2,0:atoms%lmaxd,jspd) )
ELSE
......@@ -187,7 +187,10 @@ CONTAINS
+ denCoeffsOffdiag%ud21(l,itype)*( f(j,1,l,2)*g(j,1,l,1) +f(j,2,l,2)*g(j,2,l,1) )&
+ denCoeffsOffdiag%du21(l,itype)*( g(j,1,l,2)*f(j,1,l,1) +g(j,2,l,2)*f(j,2,l,1) )&
+ denCoeffsOffdiag%dd21(l,itype)*( g(j,1,l,2)*g(j,1,l,1) +g(j,2,l,2)*g(j,2,l,1) )
rho21(j,0,itype) = rho21(j,0,itype)+ conjg(cs)/(atoms%neq(itype)*sfp_const)
!rho21(j,0,itype) = rho21(j,0,itype)+ conjg(cs)/(atoms%neq(itype)*sfp_const)
rho21=CONJG(cs)/(atoms%neq(itype)*sfp_const)
rho(j,0,itype,3)=rho(j,0,itype,3)+REAL(rho21)
rho(j,0,itype,4)=rho(j,0,itype,4)+imag(rho21)
ENDDO
ENDDO
......@@ -203,7 +206,10 @@ CONTAINS
+ f(j,2,lp,2)*g(j,2,l,1) )+ denCoeffsOffdiag%dunmt21(llp,lh,itype)*(g(j,1,lp,2)*f(j,1,l,1)&
+ g(j,2,lp,2)*f(j,2,l,1) )+ denCoeffsOffdiag%ddnmt21(llp,lh,itype)*(g(j,1,lp,2)*g(j,1,l,1)&
+ g(j,2,lp,2)*g(j,2,l,1) )
rho21(j,lh,itype)= rho21(j,lh,itype)+ conjg(cs)/atoms%neq(itype)
!rho21(j,lh,itype)= rho21(j,lh,itype)+ CONJG(cs)/atoms%neq(itype)
rho21=CONJG(cs)/atoms%neq(itype)
rho(j,lh,itype,3)=rho(j,lh,itype,3)+REAL(rho21)
rho(j,lh,itype,4)=rho(j,lh,itype,4)+imag(rho21)
ENDDO
ENDDO
ENDDO
......@@ -241,15 +247,6 @@ CONTAINS
CALL timestop("cdnmt")
!---> for testing: to plot the offdiag. part of the density matrix it
!---> is written to the file rhomt21. This file can read in pldngen.
IF (denCoeffsOffdiag%l_fmpl) THEN
OPEN (26,file='rhomt21',form='unformatted',status='unknown')
WRITE (26) rho21
CLOSE (26)
DEALLOCATE ( rho21 )
ENDIF
!---> end of test output
END SUBROUTINE cdnmt
END MODULE m_cdnmt
......@@ -12,14 +12,17 @@
export FC=$MPIFC
export CC=$MPICC
fi
#ELPA
if [ $ELPA_MODULES ]
then
CLI_ELPA_OPENMP=1
FLEUR_LIBDIR="$FLEUR_LIBDIR $ELPA_LIB"
FLEUR_INCLUDEDIR="$FLEUR_INCLUDEDIR $ELPA_MODULES"
fi
elif module list 2>&1 | grep -q pgi
then
echo "found PGI compiler"
fi
fi
#ELPA
if [ $ELPA_MODULES ]
then
CLI_ELPA_OPENMP=1
FLEUR_LIBDIR="$FLEUR_LIBDIR $ELPA_LIB"
FLEUR_INCLUDEDIR="$FLEUR_INCLUDEDIR $ELPA_MODULES"
fi
......@@ -4,9 +4,12 @@ LINK_LIBRARIES ${FLEUR_LIBRARIES})
if (NOT FLEUR_USE_ELPA_ONENODE)
if (DEFINED CLI_ELPA_OPENMP)
message ("FLEUR_USE_GPU: ${FLEUR_USES_GPU}")
if (FLEUR_USE_GPU)
set(TEST_LIBRARIES "-lelpa_onenode;${FLEUR_LIBRARIES}")
else()
set(TEST_LIBRARIES "-lelpa_onenode_openmp;${FLEUR_LIBRARIES}")
#else()
# set(TEST_LIBRARIES "-lelpa;${FLEUR_LIBRARIES}")
endif()
endif()
try_compile(FLEUR_USE_ELPA_ONENODE ${CMAKE_BINARY_DIR} ${CMAKE_SOURCE_DIR}/cmake/tests/test_ELPA.f90
LINK_LIBRARIES ${TEST_LIBRARIES})
......
......@@ -11,9 +11,11 @@ if (CLI_FLEUR_USE_GPU)
elseif(${CLI_FLEUR_USE_GPU} MATCHES "cuda9.1")
set(CMAKE_Fortran_FLAGS "${CMAKE_Fortran_FLAGS} -Mcuda=cuda9.1,cc60 -Mcuda=rdc -Mcudalib=cublas")
elseif(${CLI_FLEUR_USE_GPU} MATCHES "nvtx")
set(CMAKE_Fortran_FLAGS "${CMAKE_Fortran_FLAGS} -Mcuda=cuda9.1,cc60 -Mcuda=rdc -Mcudalib=cublas -lnvToolsExt ")
#set(CMAKE_Fortran_FLAGS "${CMAKE_Fortran_FLAGS} -Mcuda=cuda9.1,cc60,ptxinfo,lineinfo -Mcuda=rdc -Mcudalib=cublas -lnvToolsExt ")
set(CMAKE_Fortran_FLAGS "${CMAKE_Fortran_FLAGS} -Mcuda=cuda9.1,cc60 -Mcuda=rdc -Mcudalib=cublas -lnvToolsExt ")
elseif(${CLI_FLEUR_USE_GPU} MATCHES "emu")
set(CMAKE_Fortran_FLAGS "${CMAKE_Fortran_FLAGS} -Mcuda=emu -Mcudalib=cublas -Minfo=accel ")
#set(CMAKE_Fortran_FLAGS "${CMAKE_Fortran_FLAGS} -Mcuda=emu -Mcudalib=cublas -Minfo=accel ")
set(CMAKE_Fortran_FLAGS "${CMAKE_Fortran_FLAGS} -Mcuda=emu -Mcudalib=cublas ")
endif()
set(FLEUR_MPI_DEFINITIONS ${FLEUR_MPI_DEFINITIONS} "CPP_GPU" "CPP_MANAGED=,MANAGED")
set(FLEUR_DEFINITIONS ${FLEUR_DEFINITIONS} "CPP_GPU" "CPP_MANAGED=,MANAGED")
......
......@@ -45,6 +45,7 @@ CONTAINS
INTEGER :: kernel
CLASS(elpa_t),pointer :: elpa_obj
print*, "ELPA 20180525 started"
err = elpa_init(20180525)
elpa_obj => elpa_allocate()
......@@ -60,6 +61,9 @@ CONTAINS
CALL elpa_obj%set("local_ncols", hmat%matsize2, err)
CALL elpa_obj%set("nblk",hmat%matsize1, err)
CALL elpa_obj%set("blacs_context", -1, err)
#ifdef CPP_GPU
CALL elpa_obj%set("gpu",1,err)
#endif
err = elpa_obj%setup()
CALL hmat%add_transpose(hmat)
......
set(fleur_F77 ${fleur_F77}
)
set(fleur_F90 ${fleur_F90}
eigen/hsmt_mtNocoPot_offdiag.F90
eigen/eigen.F90
eigen/hlomat.F90
eigen/hs_int.F90
......
......@@ -70,15 +70,15 @@ CONTAINS
!$OMP MASTER
IF ((atoms%invsat(na).EQ.0) .OR. (atoms%invsat(na).EQ.1)) THEN
IF ((atoms%invsat(na) == 0) .OR. (atoms%invsat(na) == 1)) THEN
!---> if this atom is the first of two atoms related by inversion,
!---> the contributions to the overlap matrix of both atoms are added
!---> at once. where it is made use of the fact, that the sum of
!---> these contributions is twice the real part of the contribution
!---> of each atom. note, that in this case there are twice as many
!---> (2*(2*l+1)) k-vectors (compare abccoflo and comments there).
IF (atoms%invsat(na).EQ.0) invsfct = 1
IF (atoms%invsat(na).EQ.1) invsfct = 2
IF (atoms%invsat(na) == 0) invsfct = 1
IF (atoms%invsat(na) == 1) invsfct = 2
!
DO lo = 1,atoms%nlo(ntyp)
......@@ -127,7 +127,7 @@ CONTAINS
!+t3e
DO nkvec = 1,invsfct* (2*l+1)
locol= lapw%nv(jintsp)+lapw%index_lo(lo,na)+nkvec !this is the column of the matrix
IF (MOD(locol-1,mpi%n_size).EQ.mpi%n_rank) THEN
IF (MOD(locol-1,mpi%n_size) == mpi%n_rank) THEN
locol=(locol-1)/mpi%n_size+1 !this is the column in local storage
!-t3e
IF (hmat%l_real) THEN
......@@ -174,7 +174,7 @@ CONTAINS
!---> local orbitals at the same atom and with itself
DO nkvec = 1,invsfct* (2*l+1)
locol = lapw%nv(jintsp)+lapw%index_lo(lo,na)+nkvec !this is the column of the matrix
IF (MOD(locol-1,mpi%n_size).EQ.mpi%n_rank) THEN
IF (MOD(locol-1,mpi%n_size) == mpi%n_rank) THEN
locol=(locol-1)/mpi%n_size+1 !this is the column in local storage
!-t3e
!---> calculate the hamiltonian matrix elements with other
......
!--------------------------------------------------------------------------------
! 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_hsmt
USE m_juDFT
IMPLICIT NONE
......@@ -25,6 +30,7 @@ CONTAINS
USE m_hsmt_fjgj
USE m_hsmt_spinor
USE m_hsmt_soc_offdiag
USE m_hsmt_mtNocoPot_offdiag
USE m_hsmt_offdiag
IMPLICIT NONE
TYPE(t_mpi),INTENT(IN) :: mpi
......@@ -84,15 +90,18 @@ CONTAINS
!global spin-matrices.
CALL hmat_tmp%clear();CALL smat_tmp%clear()
CALL hsmt_sph(n,atoms,mpi,ispin,input,noco,1,1,chi_one,lapw,enpara%el0,td%e_shift(n,ispin),&
usdus,fj(:,0:,ispin,:),gj(:,0:,ispin,:),smat_tmp,hmat_tmp)
usdus,fj(:,0:,ispin,:),gj(:,0:,ispin,:),smat_tmp,hmat_tmp)
CALL hsmt_nonsph(n,mpi,sym,atoms,ispin,1,1,chi_one,noco,cell,lapw,td,&
fj(:,0:,ispin,:),gj(:,0:,ispin,:),hmat_tmp)
fj(:,0:,ispin,:),gj(:,0:,ispin,:),hmat_tmp)
CALL hsmt_lo(input,atoms,sym,cell,mpi,noco,lapw,usdus,td,fj(:,0:,ispin,:),gj(:,0:,ispin,:),&
n,chi_one,ispin,iintsp,jintsp,hmat_tmp,smat_tmp)
n,chi_one,ispin,iintsp,jintsp,hmat_tmp,smat_tmp)
CALL hsmt_spinor(ispin,n,noco,chi)
CALL hsmt_distspins(chi,smat_tmp,smat)
CALL hsmt_distspins(chi,hmat_tmp,hmat)
!Add off-diagonal contributions to Hamiltonian if needed
IF (ispin==1.AND.noco%l_mtNocoPot) THEN
CALL hsmt_mtNocoPot_offdiag(n,mpi,sym,atoms,noco,cell,lapw,td,fj,gj,hmat_tmp,hmat)
ENDIF
IF (ispin==1.and.noco%l_soc) &
CALL hsmt_soc_offdiag(n,atoms,mpi,noco,lapw,usdus,td,fj(:,0:,:,iintsp),gj(:,0:,:,iintsp),hmat)
IF (noco%l_constr) &
......
!--------------------------------------------------------------------------------
! 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_hsmt_mtNocoPot_offdiag
USE m_juDFT
IMPLICIT NONE
CONTAINS
SUBROUTINE hsmt_mtNocoPot_offdiag(n,mpi,sym,atoms,noco,cell,lapw,td,fj,gj,hmat_tmp,hmat)
!Calculate the contribution from the local-spin-offdiagonal potential
!The following idea is used:
!Calculate the matrix by using non-spherical algorithm. This is done only once, since
!this sets up both the local spin-up-down and the spin-down-up part (it calculates the
!full matrix). So both can be updated from this matrix. But since the off-diagonal
!local potential is real we have to call the routine twice and use the chi_one factor
!to get the imaginary contribution
USE m_types
USE m_hsmt_nonsph
USE m_hsmt_distspins
USE m_hsmt_spinor
IMPLICIT NONE
TYPE(t_mpi),INTENT(IN) :: mpi
TYPE(t_sym),INTENT(IN) :: sym
TYPE(t_noco),INTENT(IN) :: noco
TYPE(t_cell),INTENT(IN) :: cell
TYPE(t_atoms),INTENT(IN) :: atoms
TYPE(t_lapw),INTENT(IN) :: lapw
TYPE(t_tlmplm),INTENT(IN) :: td
REAL,INTENT(IN) :: fj(:,0:,:,:),gj(:,0:,:,:)
! .. Scalar Arguments ..
INTEGER, INTENT (IN) :: n
COMPLEX :: chi_one,chi(2,2)
CLASS(t_mat),INTENT(INOUT) :: hmat(:,:),hmat_tmp
chi_one=1.0
CALL hmat_tmp%clear()
!The spin1,2 matrix is calculated(real part of potential)
CALL hsmt_nonsph(n,mpi,sym,atoms,3,1,1,chi_one,noco,cell,lapw,td,&
fj(:,0:,1,:),gj(:,0:,2,:),hmat_tmp)
CALL hsmt_spinor(3,n,noco,chi) !spinor for off-diagonal part
CALL hsmt_distspins(chi,hmat_tmp,hmat)
CALL hmat_tmp%TRANSPOSE()
hmat_tmp%data_c=CONJG(hmat_tmp%data_c)
CALL hsmt_spinor(4,n,noco,chi) !spinor for off-diagonal part
CALL hsmt_distspins(chi,hmat_tmp,hmat)
CALL hmat_tmp%clear()
!The spin1,2 matrix is calculated(imag part of potential)
chi_one=CMPLX(0.,1.)
CALL hsmt_nonsph(n,mpi,sym,atoms,4,1,1,chi_one,noco,cell,lapw,td,&
fj(:,0:,1,:),gj(:,0:,2,:),hmat_tmp)
CALL hsmt_spinor(3,n,noco,chi)
CALL hsmt_distspins(chi,hmat_tmp,hmat)
CALL hmat_tmp%TRANSPOSE()
hmat_tmp%data_c=CONJG(hmat_tmp%data_c)
CALL hsmt_spinor(4,n,noco,chi)
CALL hsmt_distspins(chi,hmat_tmp,hmat)
END SUBROUTINE hsmt_mtNocoPot_offdiag
END MODULE m_hsmt_mtNocoPot_offdiag
......@@ -197,7 +197,13 @@ CONTAINS
td%h_loc(0:,0:,n,isp),SIZE(td%h_loc,1),CMPLX(0.,0.),ab1,SIZE(ab1,1))
!ab1=MATMUL(ab(:lapw%nv(iintsp),:ab_size),td%h_loc(:ab_size,:ab_size,n,isp))
IF (iintsp==jintsp) THEN
CALL ZHERK("U","N",lapw%nv(iintsp),ab_size,Rchi,CONJG(ab1),SIZE(ab1,1),1.0,hmat%data_c,SIZE(hmat%data_c,1))
IF (isp<3) THEN
CALL ZHERK("U","N",lapw%nv(iintsp),ab_size,Rchi,CONJG(ab1),SIZE(ab1,1),1.0,hmat%data_c,SIZE(hmat%data_c,1))
ELSE !This is the case of a local off-diagonal contribution.
!It is not Hermitian, so we need to USE zgemm CALL
CALL zgemm("N","T",lapw%nv(iintsp),lapw%nv(jintsp),ab_size,chi,CONJG(ab),SIZE(ab,1),&
ab1,SIZE(ab1,1),CMPLX(1.0,0.0),hmat%data_c,SIZE(hmat%data_c,1))
ENDIF
ELSE !here the l_ss off-diagonal part starts
!Second set of ab is needed
CALL hsmt_ab(sym,atoms,noco,isp,iintsp,n,na,cell,lapw,fj,gj,ab,ab_size,.TRUE.)
......
This diff is collapsed.
......@@ -30,10 +30,21 @@ CONTAINS
chi(2,2) = exp(ImagUnit*noco%alph(n)/2)*cos(noco%beta(n)/2)
!---> and determine the prefactors for the Hamitonian- and
!---> overlapp-matrix elements
chi_mat(1,1) = chi(1,isp)*CONJG(chi(1,isp))
chi_mat(2,1) = chi(2,isp)*CONJG(chi(1,isp))
chi_mat(2,2) = chi(2,isp)*CONJG(chi(2,isp))
chi_mat(1,2) = chi(1,isp)*CONJG(chi(2,isp))
IF (isp<3) THEN
isp1=isp
isp2=isp
ELSEIF(isp==3) THEN
isp1=1
isp2=2
ELSE
isp1=2
isp2=1
ENDIF
chi_mat(1,1) = chi(1,isp1)*CONJG(chi(1,isp2))
chi_mat(2,1) = chi(2,isp1)*CONJG(chi(1,isp2))
chi_mat(2,2) = chi(2,isp1)*CONJG(chi(2,isp2))
chi_mat(1,2) = chi(1,isp1)*CONJG(chi(2,isp2))
......
......@@ -36,10 +36,10 @@ CONTAINS
CALL timestart("tlmplm")
CALL td%init(DIMENSION%lmplmd,DIMENSION%lmd,atoms%ntype,atoms%lmaxd,atoms%llod,SUM(atoms%nlo),&
DOT_PRODUCT(atoms%nlo,atoms%nlo+1)/2,input%jspins,&
DOT_PRODUCT(atoms%nlo,atoms%nlo+1)/2,MERGE(4,input%jspins,noco%l_mtNocoPot),&
(noco%l_noco.AND.noco%l_soc.AND..NOT.noco%l_ss).OR.noco%l_constr)!l_offdiag
DO jsp=1,input%jspins
DO jsp=1,MERGE(4,input%jspins,noco%l_mtNocoPot)
!CALL tlmplm_cholesky(sphhar,atoms,DIMENSION,enpara, jsp,1,mpi,vTot%mt(:,0,1,jsp),input,vTot%mmpMat, td,ud)
CALL tlmplm_cholesky(sphhar,atoms,noco,enpara,jsp,jsp,mpi,vTot,input,td,ud)
IF (input%l_f) CALL write_tlmplm(td,vTot%mmpMat,atoms%n_u>0,jsp,jsp,input%jspins)
......
......@@ -58,15 +58,15 @@ CONTAINS
CALL lapw%phase_factors(i,atoms%taual(:,na),noco%qss,cph(:,i))
ENDDO
IF ((atoms%invsat(na).EQ.0) .OR. (atoms%invsat(na).EQ.1)) THEN
IF ((atoms%invsat(na) == 0) .OR. (atoms%invsat(na) == 1)) THEN
!---> if this atom is the first of two atoms related by inversion,
!---> the contributions to the overlap matrix of both atoms are added
!---> at once. where it is made use of the fact, that the sum of
!---> these contributions is twice the real part of the contribution
!---> of each atom. note, that in this case there are twice as many
!---> (2*(2*l+1)) k-vectors (compare abccoflo and comments there).
IF (atoms%invsat(na).EQ.0) invsfct = 1
IF (atoms%invsat(na).EQ.1) invsfct = 2
IF (atoms%invsat(na) == 0) invsfct = 1
IF (atoms%invsat(na) == 1) invsfct = 2
con = fpi_const/SQRT(cell%omtil)* ((atoms%rmt(ntyp))**2)/2.0
......@@ -82,7 +82,7 @@ CONTAINS
DO nkvec = 1,invsfct* (2*l+1) !Each LO can have several functions
!+t3e
locol = lapw%nv(jintsp)+lapw%index_lo(lo,na)+nkvec !this is the column of the matrix
IF (MOD(locol-1,mpi%n_size).EQ.mpi%n_rank) THEN
IF (MOD(locol-1,mpi%n_size) == mpi%n_rank) THEN
locol=(locol-1)/mpi%n_size+1 !this is the column in local storage
!-t3e
k = lapw%kvec(nkvec,lo,na)
......@@ -107,7 +107,7 @@ CONTAINS
!---> orbitals at the same atom, if they have the same l
DO lop = 1, (lo-1)
lp = atoms%llo(lop,ntyp)
IF (l.EQ.lp) THEN
IF (l == lp) THEN
fact3 = con**2 * fl2p1 * (&
alo1(lop)*(alo1(lo) + &
clo1(lo)*ud%uulon(lo,ntyp,isp))+&
......
......@@ -48,7 +48,7 @@ SUBROUTINE hsfock(nk,atoms,hybrid,lapw,dimension,kpts,jsp,input,hybdat,eig_irr,s
results,it,mnobd,xcpot,mpi,irank2,isize2,comm)
USE m_types
USE m_symm_hf ,ONLY: symm_hf
USE m_symm_hf
USE m_util ,ONLY: intgrf,intgrf_init
USE m_exchange_valence_hf
USE m_exchange_core
......@@ -98,12 +98,12 @@ SUBROUTINE hsfock(nk,atoms,hybrid,lapw,dimension,kpts,jsp,input,hybdat,eig_irr,s
REAL :: a_ex
! local arrays
INTEGER :: gpt(3,lapw%nv(jsp))
INTEGER :: degenerat(hybrid%ne_eig(nk))
INTEGER :: nsest(hybrid%nbands(nk)),indx_sest(hybrid%nbands(nk),hybrid%nbands(nk))
INTEGER :: rrot(3,3,sym%nsym)
INTEGER :: psym(sym%nsym) ! Note: psym is only filled up to index nsymop
INTEGER,ALLOCATABLE :: parent(:),symop(:)
INTEGER,ALLOCATABLE :: psym(:)
INTEGER,ALLOCATABLE :: pointer_EIBZ(:)
INTEGER,ALLOCATABLE :: n_q(:)
......@@ -115,7 +115,6 @@ SUBROUTINE hsfock(nk,atoms,hybrid,lapw,dimension,kpts,jsp,input,hybdat,eig_irr,s
COMPLEX,ALLOCATABLE :: rep_c(:,:,:,:,:)
CALL timestart("total time hsfock")
CALL timestart("symm_hf")
! preparations
......@@ -125,11 +124,6 @@ SUBROUTINE hsfock(nk,atoms,hybrid,lapw,dimension,kpts,jsp,input,hybdat,eig_irr,s
! initialize weighting factor for HF exchange part
a_ex=xcpot%get_exchange_weight()
! write k1,k2,k3 in gpt
DO i=1,lapw%nv(jsp)
gpt(:,i) = (/lapw%k1(i,jsp),lapw%k2(i,jsp),lapw%k3(i,jsp)/)
END DO
! read in lower triangle part of overlap matrix from direct acces file olap
nbasfcn = MERGE(lapw%nv(1)+lapw%nv(2)+2*atoms%nlotot,lapw%nv(1)+atoms%nlotot,noco%l_noco)
call olap%alloc(sym%invs,nbasfcn)
......@@ -159,10 +153,16 @@ SUBROUTINE hsfock(nk,atoms,hybrid,lapw,dimension,kpts,jsp,input,hybdat,eig_irr,s
IF( ok .ne. 0 ) STOP 'mhsfock: failure allocation parent/symop'
parent = 0 ; symop = 0
CALL symm_hf(kpts,nk,sym,dimension,hybdat,eig_irr,atoms,hybrid,cell,lapw,jsp,gpt,mpi,irank2,&
nsymop,psym,nkpt_EIBZ,n_q,parent,symop,degenerat,pointer_EIBZ,maxndb,nddb,nsest,indx_sest,rep_c)
CALL timestart("symm_hf")
CALL symm_hf_init(sym,kpts,nk,irank2,nsymop,rrot,psym)
ALLOCATE(rep_c(-hybdat%lmaxcd:hybdat%lmaxcd,-hybdat%lmaxcd:hybdat%lmaxcd,0:hybdat%lmaxcd,nsymop,atoms%nat), stat=ok)
IF(ok.NE.0) STOP 'hsfock: failure allocation rep_c'
CALL symm_hf(kpts,nk,sym,dimension,hybdat,eig_irr,atoms,hybrid,cell,lapw,jsp,mpi,irank2,&
rrot,nsymop,psym,nkpt_EIBZ,n_q,parent,symop,degenerat,pointer_EIBZ,maxndb,nddb,nsest,indx_sest,rep_c)
CALL timestop("symm_hf")
! remove weights(wtkpt) in w_iks
DO ikpt=1,kpts%nkptf
DO iband=1,dimension%neigd
......@@ -174,15 +174,24 @@ SUBROUTINE hsfock(nk,atoms,hybrid,lapw,dimension,kpts,jsp,input,hybdat,eig_irr,s
! calculate contribution from valence electrons to the
! HF exchange
CALL timestart("valence exchange calculation")
ex%l_real=sym%invs
CALL exchange_valence_hf(nk,kpts,nkpt_EIBZ, sym,atoms,hybrid,cell,dimension,input,jsp,hybdat,mnobd,lapw,&
eig_irr,results,parent,pointer_EIBZ,n_q,wl_iks,it,xcpot,noco,nsest,indx_sest,&
mpi,irank2,isize2,comm,ex)
DEALLOCATE (rep_c)
CALL timestop("valence exchange calculation")
WRITE(1224,'(a,i7)') 'kpoint: ', nk
DO i = 1, ex%matsize1
DO j = 1, i
IF (ex%l_real) THEN
WRITE(1224,'(2i7,2f15.8)') i, j, ex%data_r(j,i) !ex%data_r(i,j), ex%data_r(j,i)
ELSE
WRITE(1224,'(2i7,4f15.8)') i, j, ex%data_c(j,i) !ex%data_c(i,j), ex%data_c(j,i)
ENDIF
END DO
END DO
CALL timestart("core exchange calculation")
! do the rest of the calculation only on master
IF (irank2 /= 0) RETURN
......@@ -227,12 +236,45 @@ SUBROUTINE hsfock(nk,atoms,hybrid,lapw,dimension,kpts,jsp,input,hybdat,eig_irr,s
ENDDO
ENDDO
WRITE(1225,'(a,i7)') 'kpoint: ', nk
DO i = 1, ex%matsize1
DO j = 1, i
IF (ex%l_real) THEN
WRITE(1225,'(2i7,2f15.8)') i, j, ex%data_r(i,j), ex%data_r(j,i)
ELSE
WRITE(1225,'(2i7,4f15.8)') i, j, ex%data_c(i,j), ex%data_c(j,i)
ENDIF
END DO
END DO
CALL ex%multiply(invtrafo,tmp)
CALL trafo%multiply(tmp,v_x)
CALL timestop("time for performing T^-1*mat_ex*T^-1*")
CALL symmetrizeh(atoms,kpts%bkf(:,nk),dimension,jsp,lapw,gpt,sym,hybdat%kveclo_eig,cell,nsymop,psym,v_x)
WRITE(1231,'(a,i7)') 'kpoint: ', nk
DO i = 1, v_x%matsize1
DO j = 1, i
IF (v_x%l_real) THEN
WRITE(1231,'(2i7,1f15.8)') i, j, v_x%data_r(i,j)
ELSE
WRITE(1231,'(2i7,2f15.8)') i, j, v_x%data_c(i,j)
ENDIF
END DO
END DO
CALL symmetrizeh(atoms,kpts%bkf(:,nk),dimension,jsp,lapw,sym,hybdat%kveclo_eig,cell,nsymop,psym,v_x)
WRITE(1232,'(a,i7)') 'kpoint: ', nk
DO i = 1, v_x%matsize1
DO j = 1, i
IF (v_x%l_real) THEN
WRITE(1232,'(2i7,1f15.8)') i, j, v_x%data_r(j,i) ! Note the different indices in comparison to points above. This is wanted!
ELSE
WRITE(1232,'(2i7,2f15.8)') i, j, v_x%data_c(j,i) ! Note the different indices in comparison to points above. This is wanted!
ENDIF
END DO
END DO
CALL write_v_x(v_x,kpts%nkpt*(jsp-1) + nk)
END IF ! hybrid%l_calhf
......
......@@ -9,28 +9,76 @@
! !
! M.Betzinger (09/07) !
!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!
MODULE m_symm_hf
MODULE m_symm_hf
#define irreps .false.
CONTAINS
CONTAINS
SUBROUTINE symm_hf(kpts,nk,sym,&
& dimension,hybdat,eig_irr,&
& atoms,hybrid,cell,&
& lapw,jsp,&
& gpt,&
& mpi,irank2,&
& nsymop,psym,nkpt_EIBZ,n_q,parent,&
& symop,degenerat,pointer_EIBZ,maxndb,nddb,&
& nsest,indx_sest,rep_c )
SUBROUTINE symm_hf_init(sym,kpts,nk,irank2,nsymop,rrot,psym)
USE m_types
USE m_util ,ONLY: modulo1
IMPLICIT NONE
TYPE(t_sym), INTENT(IN) :: sym
TYPE(t_kpts), INTENT(IN) :: kpts
INTEGER, INTENT(IN) :: nk
INTEGER, INTENT(IN) :: irank2
INTEGER, INTENT(OUT) :: nsymop
INTEGER, INTENT(INOUT) :: rrot(3,3,sym%nsym)
INTEGER, INTENT(INOUT) :: psym(sym%nsym) ! Note: psym is only filled up to index nsymop
INTEGER :: i
REAL :: rotkpt(3)
! calculate rotations in reciprocal space
DO i = 1, sym%nsym
IF(i.LE.sym%nop) THEN
rrot(:,:,i) = transpose(sym%mrot(:,:,sym%invtab(i)))
ELSE
rrot(:,:,i) = -rrot(:,:,i-sym%nop)
END IF
END DO
! determine little group of k., i.e. those symmetry operations
! which keep bk(:,nk) invariant
! nsymop :: number of such symmetry-operations
! psym :: points to the symmetry-operation
psym = 0
nsymop = 0
DO i = 1, sym%nsym
rotkpt = matmul(rrot(:,:,i), kpts%bkf(:,nk))
!transfer rotkpt into BZ
rotkpt = modulo1(rotkpt,kpts%nkpt3)
!check if rotkpt is identical to bk(:,nk)
IF(maxval(abs(rotkpt - kpts%bkf(:,nk))) .LE. 1E-07) THEN
nsymop = nsymop + 1
psym(nsymop) = i
END IF
END DO
IF (irank2 == 0) THEN
WRITE(6,'(A,i3)') ' nk',nk
WRITE(6,'(A,3f10.5)') ' kpts%bkf(:,nk):',kpts%bkf(:,nk)