diff --git a/hybrid/HF_init.F90 b/hybrid/HF_init.F90 index 69b2d4879a22c7c137563cf9ab43d0cbee854368..8f23fdc60695f45ca8a743a07bc7bc744d73926b 100644 --- a/hybrid/HF_init.F90 +++ b/hybrid/HF_init.F90 @@ -1,86 +1,80 @@ MODULE m_hf_init - ! - ! preparations for HF and hybrid functional calculation - ! + ! + ! preparations for HF and hybrid functional calculation + ! CONTAINS - SUBROUTINE hf_init(hybrid,kpts,atoms,input,DIMENSION,hybdat,l_real) - USE m_types - USE m_read_core - USE m_util - USE m_io_hybrid - IMPLICIT NONE - TYPE(t_hybrid),INTENT(INOUT) :: hybrid - TYPE(t_kpts),INTENT(IN) :: kpts - TYPE(t_atoms),INTENT(IN) :: atoms - TYPE(t_input),INTENT(IN) :: input - TYPE(t_dimension),INTENT(IN) :: DIMENSION - TYPE(t_hybdat),INTENT(OUT) :: hybdat - LOGICAL,INTENT(IN) :: l_real - - - - INTEGER:: itype,ieq,l,m,i,nk,l1,l2,m1,m2,ok - - + SUBROUTINE hf_init(hybrid, kpts, atoms, input, DIMENSION, hybdat, l_real) + USE m_types + USE m_read_core + USE m_util + USE m_io_hybrid + IMPLICIT NONE + TYPE(t_hybrid), INTENT(INOUT) :: hybrid + TYPE(t_kpts), INTENT(IN) :: kpts + TYPE(t_atoms), INTENT(IN) :: atoms + TYPE(t_input), INTENT(IN) :: input + TYPE(t_dimension), INTENT(IN) :: DIMENSION + TYPE(t_hybdat), INTENT(OUT) :: hybdat + LOGICAL, INTENT(IN) :: l_real - - !initialize hybdat%gridf for radial integration - CALL intgrf_init(atoms%ntype,atoms%jmtd,atoms%jri,atoms%dx,atoms%rmsh,hybdat%gridf) - - !Alloc variables - ALLOCATE(hybdat%lmaxc(atoms%ntype)) - ALLOCATE(hybdat%bas1(atoms%jmtd,hybrid%maxindx,0:atoms%lmaxd,atoms%ntype)) - ALLOCATE(hybdat%bas2(atoms%jmtd,hybrid%maxindx,0:atoms%lmaxd,atoms%ntype)) - ALLOCATE(hybdat%bas1_MT(hybrid%maxindx,0:atoms%lmaxd,atoms%ntype)) - ALLOCATE(hybdat%drbas1_MT(hybrid%maxindx,0:atoms%lmaxd,atoms%ntype)) - - !sym%tau = oneD%ods%tau + INTEGER:: itype, ieq, l, m, i, nk, l1, l2, m1, m2, ok - ! preparations for core states - CALL core_init(dimension,input,atoms, hybdat%lmaxcd,hybdat%maxindxc) - ALLOCATE( hybdat%nindxc(0:hybdat%lmaxcd,atoms%ntype), stat = ok ) - IF( ok .ne. 0 ) STOP 'eigen_hf: failure allocation hybdat%nindxc' - ALLOCATE( hybdat%core1(atoms%jmtd,hybdat%maxindxc,0:hybdat%lmaxcd,atoms%ntype), stat=ok ) - IF( ok .ne. 0 ) STOP 'eigen_hf: failure allocation core1' - ALLOCATE( hybdat%core2(atoms%jmtd,hybdat%maxindxc,0:hybdat%lmaxcd,atoms%ntype), stat=ok ) - IF( ok .ne. 0 ) STOP 'eigen_hf: failure allocation core2' - ALLOCATE( hybdat%eig_c(hybdat%maxindxc,0:hybdat%lmaxcd,atoms%ntype), stat=ok ) - IF( ok .ne. 0 ) STOP 'eigen_hf: failure allocation hybdat%eig_c' - hybdat%nindxc = 0 ; hybdat%core1 = 0 ; hybdat%core2 = 0 ; hybdat%eig_c = 0 + !initialize hybdat%gridf for radial integration + CALL intgrf_init(atoms%ntype, atoms%jmtd, atoms%jri, atoms%dx, atoms%rmsh, hybdat%gridf) - ! pre-calculate gaunt coefficients + !Alloc variables + ALLOCATE (hybdat%lmaxc(atoms%ntype)) + ALLOCATE (hybdat%bas1(atoms%jmtd, hybrid%maxindx, 0:atoms%lmaxd, atoms%ntype)) + ALLOCATE (hybdat%bas2(atoms%jmtd, hybrid%maxindx, 0:atoms%lmaxd, atoms%ntype)) + ALLOCATE (hybdat%bas1_MT(hybrid%maxindx, 0:atoms%lmaxd, atoms%ntype)) + ALLOCATE (hybdat%drbas1_MT(hybrid%maxindx, 0:atoms%lmaxd, atoms%ntype)) - hybdat%maxfac = max(2*atoms%lmaxd+hybrid%maxlcutm1+1,2*hybdat%lmaxcd+2*atoms%lmaxd+1) - ALLOCATE ( hybdat%fac( 0:hybdat%maxfac),hybdat%sfac( 0:hybdat%maxfac),stat=ok) - IF( ok .ne. 0 ) STOP 'eigen_hf: failure allocation fac,hybdat%sfac' - hybdat%fac(0) = 1 - hybdat%sfac(0) = 1 - DO i=1,hybdat%maxfac - hybdat%fac(i) = hybdat%fac(i-1)*i ! hybdat%fac(i) = i! - hybdat%sfac(i) = hybdat%sfac(i-1)*sqrt(i*1.0) ! hybdat%sfac(i) = sqrt(i!) - END DO + !sym%tau = oneD%ods%tau + ! preparations for core states + CALL core_init(dimension, input, atoms, hybdat%lmaxcd, hybdat%maxindxc) + ALLOCATE (hybdat%nindxc(0:hybdat%lmaxcd, atoms%ntype), stat=ok) + IF (ok /= 0) STOP 'eigen_hf: failure allocation hybdat%nindxc' + ALLOCATE (hybdat%core1(atoms%jmtd, hybdat%maxindxc, 0:hybdat%lmaxcd, atoms%ntype), stat=ok) + IF (ok /= 0) STOP 'eigen_hf: failure allocation core1' + ALLOCATE (hybdat%core2(atoms%jmtd, hybdat%maxindxc, 0:hybdat%lmaxcd, atoms%ntype), stat=ok) + IF (ok /= 0) STOP 'eigen_hf: failure allocation core2' + ALLOCATE (hybdat%eig_c(hybdat%maxindxc, 0:hybdat%lmaxcd, atoms%ntype), stat=ok) + IF (ok /= 0) STOP 'eigen_hf: failure allocation hybdat%eig_c' + hybdat%nindxc = 0; hybdat%core1 = 0; hybdat%core2 = 0; hybdat%eig_c = 0 - ALLOCATE ( hybdat%gauntarr( 2, 0:atoms%lmaxd, 0:atoms%lmaxd, 0:hybrid%maxlcutm1, -atoms%lmaxd:atoms%lmaxd ,-hybrid%maxlcutm1:hybrid%maxlcutm1 ),stat=ok) - IF( ok .ne. 0 ) STOP 'eigen: failure allocation hybdat%gauntarr' - hybdat%gauntarr = 0 - DO l2 = 0,atoms%lmaxd - DO l1 = 0,atoms%lmaxd - DO l = abs(l1-l2),min(l1+l2,hybrid%maxlcutm1) - DO m = -l,l - DO m1 = -l1,l1 - m2 = m1 + m ! Gaunt condition -m1+m2-m = 0 - IF(abs(m2).le.l2) hybdat%gauntarr(1,l1,l2,l,m1,m) = gaunt(l1,l2,l,m1,m2,m,hybdat%maxfac,hybdat%fac,hybdat%sfac) - m2 = m1 - m ! switch role of l2-index - IF(abs(m2).le.l2) hybdat%gauntarr(2,l1,l2,l,m1,m) = gaunt(l2,l1,l,m2,m1,m,hybdat%maxfac,hybdat%fac,hybdat%sfac) - END DO - END DO - END DO - END DO - END DO + ! pre-calculate gaunt coefficients - !skip_kpt = .false. + hybdat%maxfac = max(2*atoms%lmaxd + hybrid%maxlcutm1 + 1, 2*hybdat%lmaxcd + 2*atoms%lmaxd + 1) + ALLOCATE (hybdat%fac(0:hybdat%maxfac), hybdat%sfac(0:hybdat%maxfac), stat=ok) + IF (ok /= 0) STOP 'eigen_hf: failure allocation fac,hybdat%sfac' + hybdat%fac(0) = 1 + hybdat%sfac(0) = 1 + DO i = 1, hybdat%maxfac + hybdat%fac(i) = hybdat%fac(i - 1)*i ! hybdat%fac(i) = i! + hybdat%sfac(i) = hybdat%sfac(i - 1)*sqrt(i*1.0) ! hybdat%sfac(i) = sqrt(i!) + END DO - END SUBROUTINE hf_init + ALLOCATE (hybdat%gauntarr(2, 0:atoms%lmaxd, 0:atoms%lmaxd, 0:hybrid%maxlcutm1, -atoms%lmaxd:atoms%lmaxd, -hybrid%maxlcutm1:hybrid%maxlcutm1), stat=ok) + IF (ok /= 0) STOP 'eigen: failure allocation hybdat%gauntarr' + hybdat%gauntarr = 0 + DO l2 = 0, atoms%lmaxd + DO l1 = 0, atoms%lmaxd + DO l = abs(l1 - l2), min(l1 + l2, hybrid%maxlcutm1) + DO m = -l, l + DO m1 = -l1, l1 + m2 = m1 + m ! Gaunt condition -m1+m2-m = 0 + IF (abs(m2) <= l2) hybdat%gauntarr(1, l1, l2, l, m1, m) = gaunt(l1, l2, l, m1, m2, m, hybdat%maxfac, hybdat%fac, hybdat%sfac) + m2 = m1 - m ! switch role of l2-index + IF (abs(m2) <= l2) hybdat%gauntarr(2, l1, l2, l, m1, m) = gaunt(l2, l1, l, m2, m1, m, hybdat%maxfac, hybdat%fac, hybdat%sfac) + END DO + END DO + END DO + END DO + END DO + + !skip_kpt = .false. + + END SUBROUTINE hf_init END MODULE m_hf_init diff --git a/hybrid/add_Vnonlocal.F90 b/hybrid/add_Vnonlocal.F90 index f87ea98d0a9c9d2018ab4938dadea2caf82f3fe1..b3d737104cbc58f8910036de679a36decc51f71e 100644 --- a/hybrid/add_Vnonlocal.F90 +++ b/hybrid/add_Vnonlocal.F90 @@ -40,95 +40,95 @@ MODULE m_add_vnonlocal ! c ! M.Betzinger (09/07) c ! c c c c c c c c c c c c c c c c c c c c c c c c c c c c c c c c c c c c c c c - CONTAINS +CONTAINS - SUBROUTINE add_vnonlocal(nk,lapw,atoms,hybrid,dimension,kpts,jsp,results,xcpot,noco,hmat) + SUBROUTINE add_vnonlocal(nk, lapw, atoms, hybrid, dimension, kpts, jsp, results, xcpot, noco, hmat) - USE m_symm_hf, ONLY: symm_hf - USE m_util, ONLY: intgrf,intgrf_init + USE m_symm_hf, ONLY: symm_hf + USE m_util, ONLY: intgrf, intgrf_init USE m_exchange_valence_hf USE m_exchange_core USE m_symmetrizeh USE m_wrapper - USE m_hsefunctional, ONLY: exchange_vccvHSE,exchange_ccccHSE + USE m_hsefunctional, ONLY: exchange_vccvHSE, exchange_ccccHSE USE m_types USE m_io_hybrid IMPLICIT NONE - TYPE(t_results), INTENT(INOUT) :: results - CLASS(t_xcpot), INTENT(IN) :: xcpot - TYPE(t_dimension), INTENT(IN) :: dimension - TYPE(t_hybrid), INTENT(INOUT) :: hybrid - TYPE(t_kpts), INTENT(IN) :: kpts - TYPE(t_lapw), INTENT(IN) :: lapw - TYPE(t_atoms), INTENT(IN) :: atoms - TYPE(t_noco), INTENT(IN) :: noco - TYPE(t_mat), INTENT(INOUT) :: hmat - - INTEGER, INTENT(IN) :: jsp - INTEGER, INTENT(IN) :: nk + TYPE(t_results), INTENT(INOUT) :: results + CLASS(t_xcpot), INTENT(IN) :: xcpot + TYPE(t_dimension), INTENT(IN) :: dimension + TYPE(t_hybrid), INTENT(INOUT) :: hybrid + TYPE(t_kpts), INTENT(IN) :: kpts + TYPE(t_lapw), INTENT(IN) :: lapw + TYPE(t_atoms), INTENT(IN) :: atoms + TYPE(t_noco), INTENT(IN) :: noco + TYPE(t_mat), INTENT(INOUT) :: hmat + + INTEGER, INTENT(IN) :: jsp + INTEGER, INTENT(IN) :: nk ! local scalars - INTEGER :: n,nn,iband,nbasfcn + INTEGER :: n, nn, iband, nbasfcn REAL :: a_ex - TYPE(t_mat) :: olap,tmp,v_x,z - COMPLEX :: exch(dimension%neigd,dimension%neigd) + TYPE(t_mat) :: olap, tmp, v_x, z + COMPLEX :: exch(dimension%neigd, dimension%neigd) ! initialize weighting factor for HF exchange part - a_ex=xcpot%get_exchange_weight() + a_ex = xcpot%get_exchange_weight() - nbasfcn = MERGE(lapw%nv(1)+lapw%nv(2)+2*atoms%nlotot,lapw%nv(1)+atoms%nlotot,noco%l_noco) - CALL v_x%init(hmat%l_real,nbasfcn,nbasfcn) + nbasfcn = MERGE(lapw%nv(1) + lapw%nv(2) + 2*atoms%nlotot, lapw%nv(1) + atoms%nlotot, noco%l_noco) + CALL v_x%init(hmat%l_real, nbasfcn, nbasfcn) - CALL read_v_x(v_x,kpts%nkpt*(jsp-1)+nk) + CALL read_v_x(v_x, kpts%nkpt*(jsp - 1) + nk) ! add non-local x-potential to the hamiltonian hmat DO n = 1, v_x%matsize1 - DO nn = 1, n + DO nn = 1, n IF (hmat%l_real) THEN - hmat%data_r(nn,n) = hmat%data_r(nn,n) - a_ex*v_x%data_r(nn,n) + hmat%data_r(nn, n) = hmat%data_r(nn, n) - a_ex*v_x%data_r(nn, n) ELSE - hmat%data_c(nn,n) = hmat%data_c(nn,n) - a_ex*v_x%data_c(nn,n) + hmat%data_c(nn, n) = hmat%data_c(nn, n) - a_ex*v_x%data_c(nn, n) ENDIF END DO END DO ! calculate HF energy - IF(hybrid%l_calhf) THEN - WRITE(6,'(A)') new_line('n')//new_line('n')//' ### '// ' diagonal HF exchange elements (eV) ###' - - WRITE(6,'(A)') new_line('n') // ' k-point '// 'band tail pole total(valence+core)' + IF (hybrid%l_calhf) THEN + WRITE (6, '(A)') new_line('n')//new_line('n')//' ### '//' diagonal HF exchange elements (eV) ###' + + WRITE (6, '(A)') new_line('n')//' k-point '//'band tail pole total(valence+core)' END IF ! read in lower triangle part of overlap matrix from direct acces file olap - CALL olap%init(hmat%l_real,nbasfcn,nbasfcn) - CALL read_olap(olap,kpts%nkpt*(jsp-1)+nk) - IF (.NOT.olap%l_real) olap%data_c=conjg(olap%data_c) + CALL olap%init(hmat%l_real, nbasfcn, nbasfcn) + CALL read_olap(olap, kpts%nkpt*(jsp - 1) + nk) + IF (.NOT. olap%l_real) olap%data_c = conjg(olap%data_c) + + CALL z%init(olap%l_real, nbasfcn, dimension%neigd) - CALL z%init(olap%l_real,nbasfcn,dimension%neigd) + CALL read_z(z, kpts%nkpt*(jsp - 1) + nk) - CALL read_z(z,kpts%nkpt*(jsp-1)+nk) - ! calculate exchange contribution of current k-point nk to total energy (te_hfex) - ! in the case of a spin-unpolarized calculation the factor 2 is added in eigen.F90 - IF (.NOT.v_x%l_real) v_x%data_c=conjg(v_x%data_c) + ! in the case of a spin-unpolarized calculation the factor 2 is added in eigen.F90 + IF (.NOT. v_x%l_real) v_x%data_c = conjg(v_x%data_c) exch = 0 - z%matsize1=MIN(z%matsize1,v_x%matsize2) + z%matsize1 = MIN(z%matsize1, v_x%matsize2) - CALL v_x%multiply(z,tmp) + CALL v_x%multiply(z, tmp) DO iband = 1, hybrid%nbands(nk) IF (z%l_real) THEN - exch(iband,iband) = dot_product(z%data_r(:z%matsize1,iband),tmp%data_r(:,iband)) + exch(iband, iband) = dot_product(z%data_r(:z%matsize1, iband), tmp%data_r(:, iband)) ELSE - exch(iband,iband) = dot_product(z%data_c(:z%matsize1,iband),tmp%data_c(:,iband)) + exch(iband, iband) = dot_product(z%data_c(:z%matsize1, iband), tmp%data_c(:, iband)) END IF - IF(iband.LE.hybrid%nobd(nk)) THEN - results%te_hfex%valence = results%te_hfex%valence -a_ex*results%w_iks(iband,nk,jsp)*exch(iband,iband) + IF (iband <= hybrid%nobd(nk)) THEN + results%te_hfex%valence = results%te_hfex%valence - a_ex*results%w_iks(iband, nk, jsp)*exch(iband, iband) END IF - IF(hybrid%l_calhf) THEN - WRITE(6, '( '' ('',F5.3,'','',F5.3,'','',F5.3,'')'',I4,4X,3F15.5)')& - kpts%bkf(:,nk),iband, (REAL(exch(iband,iband))-hybrid%div_vv(iband,nk,jsp))*(-27.211608),& - hybrid%div_vv(iband,nk,jsp)*(-27.211608),REAL(exch(iband,iband))*(-27.211608) + IF (hybrid%l_calhf) THEN + WRITE (6, '( '' ('',F5.3,'','',F5.3,'','',F5.3,'')'',I4,4X,3F15.5)') & + kpts%bkf(:, nk), iband, (REAL(exch(iband, iband)) - hybrid%div_vv(iband, nk, jsp))*(-27.211608), & + hybrid%div_vv(iband, nk, jsp)*(-27.211608), REAL(exch(iband, iband))*(-27.211608) END IF END DO END SUBROUTINE add_vnonlocal diff --git a/hybrid/checkolap.F90 b/hybrid/checkolap.F90 index b31650067a1a47fef058b54fecb7cdd0a22a41ed..47af636006dc676f63dfaff16c9345e202cf691b 100644 --- a/hybrid/checkolap.F90 +++ b/hybrid/checkolap.F90 @@ -2,321 +2,320 @@ CONTAINS - SUBROUTINE checkolap(atoms,hybdat,& - & hybrid,& - & nkpti,kpts,& - & dimension,mpi,skip_kpt,& - & input,sym,noco,& - & cell,lapw,jsp) - USE m_util , ONLY: intgrf,intgrf_init,chr,sphbessel,harmonicsr - USE m_constants - USE m_types - USE m_io_hybrid - IMPLICIT NONE - - TYPE(t_hybdat),INTENT(IN) :: hybdat - - TYPE(t_mpi),INTENT(IN) :: mpi - TYPE(t_dimension),INTENT(IN) :: dimension - TYPE(t_hybrid),INTENT(IN) :: hybrid - TYPE(t_input),INTENT(IN) :: input - TYPE(t_noco),INTENT(IN) :: noco - TYPE(t_sym),INTENT(IN) :: sym - TYPE(t_cell),INTENT(IN) :: cell - TYPE(t_kpts),INTENT(IN) :: kpts - TYPE(t_atoms),INTENT(IN) :: atoms - TYPE(t_lapw),INTENT(INOUT) :: lapw - - ! - scalars - - INTEGER, INTENT(IN) :: jsp - INTEGER, INTENT(IN) :: nkpti - - - ! - arrays - - LOGICAL, INTENT(IN) :: skip_kpt(nkpti) - - ! - local scalars - - INTEGER :: i,itype,iatom,ikpt,ineq,igpt,iband - INTEGER :: irecl_cmt - INTEGER :: j,m - INTEGER :: l - INTEGER :: lm,lm1 - INTEGER :: n,nred, nbasfcn - - REAL :: rdum,rdum1 - REAL :: qnorm - - COMPLEX :: cexp,cdum - COMPLEX , PARAMETER :: img = (0.0,1.0) - - ! -local arrays - - INTEGER :: iarr(2),gpt(3) - INTEGER , ALLOCATABLE :: olapcv_loc(:,:,:,:,:) - - REAL :: sphbes(0:atoms%lmaxd) - REAL :: q(3) - REAL :: integrand(atoms%jmtd) - REAL :: bkpt(3) - REAL :: rarr(maxval(hybrid%nbands)) - REAL :: rtaual(3) - REAL , ALLOCATABLE :: olapcb(:) - REAL , ALLOCATABLE :: olapcv_avg(:,:,:,:),olapcv_max(:,:,:,:) - TYPE(t_mat),ALLOCATABLE :: z(:) - - COMPLEX :: cmt(dimension%neigd,hybrid%maxlmindx,atoms%nat,nkpti) - COMPLEX :: y((atoms%lmaxd+1)**2) - COMPLEX , ALLOCATABLE :: olapcv(:,:),olapww(:,:) - COMPLEX , ALLOCATABLE :: carr1(:,:),carr2(:,:),carr3(:,:) - - CHARACTER, PARAMETER :: lchar(0:38) =& - & (/'s','p','d','f','g','h','i','j','k','l','m','n','o',& - & 'x','x','x','x','x','x','x','x','x','x','x','x','x',& - & 'x','x','x','x','x','x','x','x','x','x','x','x','x' /) - LOGICAL :: l_mism = .true. - - ALLOCATE(z(nkpti)) - DO ikpt=1,nkpti - CALL lapw%init(input,noco,kpts,atoms,sym,ikpt,cell,sym%zrfs) - nbasfcn = MERGE(lapw%nv(1)+lapw%nv(2)+2*atoms%nlotot,lapw%nv(1)+atoms%nlotot,noco%l_noco) - call z(ikpt)%alloc(sym%invs,nbasfcn,dimension%neigd) - ENDDO - - IF ( mpi%irank == 0 ) WRITE(6,'(//A)') '### checkolap ###' - - cmt = 0 - - ! initialize gridf -> was done in eigen_HF_init - !CALL intgrf_init(atoms%ntype,atoms%jmtd,atoms%jri,atoms%dx,atoms%rmsh,hybdat%gridf) - - ! read in cmt - DO ikpt = 1,nkpti + SUBROUTINE checkolap(atoms, hybdat,& + & hybrid,& + & nkpti, kpts,& + & dimension, mpi, skip_kpt,& + & input, sym, noco,& + & cell, lapw, jsp) + USE m_util, ONLY: intgrf, intgrf_init, chr, sphbessel, harmonicsr + USE m_constants + USE m_types + USE m_io_hybrid + IMPLICIT NONE + + TYPE(t_hybdat), INTENT(IN) :: hybdat + + TYPE(t_mpi), INTENT(IN) :: mpi + TYPE(t_dimension), INTENT(IN) :: dimension + TYPE(t_hybrid), INTENT(IN) :: hybrid + TYPE(t_input), INTENT(IN) :: input + TYPE(t_noco), INTENT(IN) :: noco + TYPE(t_sym), INTENT(IN) :: sym + TYPE(t_cell), INTENT(IN) :: cell + TYPE(t_kpts), INTENT(IN) :: kpts + TYPE(t_atoms), INTENT(IN) :: atoms + TYPE(t_lapw), INTENT(INOUT) :: lapw + + ! - scalars - + INTEGER, INTENT(IN) :: jsp + INTEGER, INTENT(IN) :: nkpti + + ! - arrays - + LOGICAL, INTENT(IN) :: skip_kpt(nkpti) + + ! - local scalars - + INTEGER :: i, itype, iatom, ikpt, ineq, igpt, iband + INTEGER :: irecl_cmt + INTEGER :: j, m + INTEGER :: l + INTEGER :: lm, lm1 + INTEGER :: n, nred, nbasfcn + + REAL :: rdum, rdum1 + REAL :: qnorm + + COMPLEX :: cexp, cdum + COMPLEX, PARAMETER :: img = (0.0, 1.0) + + ! -local arrays - + INTEGER :: iarr(2), gpt(3) + INTEGER, ALLOCATABLE :: olapcv_loc(:, :, :, :, :) + + REAL :: sphbes(0:atoms%lmaxd) + REAL :: q(3) + REAL :: integrand(atoms%jmtd) + REAL :: bkpt(3) + REAL :: rarr(maxval(hybrid%nbands)) + REAL :: rtaual(3) + REAL, ALLOCATABLE :: olapcb(:) + REAL, ALLOCATABLE :: olapcv_avg(:, :, :, :), olapcv_max(:, :, :, :) + TYPE(t_mat), ALLOCATABLE :: z(:) + + COMPLEX :: cmt(dimension%neigd, hybrid%maxlmindx, atoms%nat, nkpti) + COMPLEX :: y((atoms%lmaxd + 1)**2) + COMPLEX, ALLOCATABLE :: olapcv(:, :), olapww(:, :) + COMPLEX, ALLOCATABLE :: carr1(:, :), carr2(:, :), carr3(:, :) + + CHARACTER, PARAMETER :: lchar(0:38) =& + & (/'s', 'p', 'd', 'f', 'g', 'h', 'i', 'j', 'k', 'l', 'm', 'n', 'o',& + & 'x', 'x', 'x', 'x', 'x', 'x', 'x', 'x', 'x', 'x', 'x', 'x', 'x',& + & 'x', 'x', 'x', 'x', 'x', 'x', 'x', 'x', 'x', 'x', 'x', 'x', 'x'/) + LOGICAL :: l_mism = .true. + + ALLOCATE (z(nkpti)) + DO ikpt = 1, nkpti + CALL lapw%init(input, noco, kpts, atoms, sym, ikpt, cell, sym%zrfs) + nbasfcn = MERGE(lapw%nv(1) + lapw%nv(2) + 2*atoms%nlotot, lapw%nv(1) + atoms%nlotot, noco%l_noco) + call z(ikpt)%alloc(sym%invs, nbasfcn, dimension%neigd) + ENDDO + + IF (mpi%irank == 0) WRITE (6, '(//A)') '### checkolap ###' + + cmt = 0 + + ! initialize gridf -> was done in eigen_HF_init + !CALL intgrf_init(atoms%ntype,atoms%jmtd,atoms%jri,atoms%dx,atoms%rmsh,hybdat%gridf) + + ! read in cmt + DO ikpt = 1, nkpti #ifdef CPP_MPI - IF ( skip_kpt(ikpt) ) CYCLE + IF (skip_kpt(ikpt)) CYCLE #endif - call read_cmt(cmt(:,:,:,ikpt),ikpt) - END DO - - IF ( mpi%irank == 0 ) WRITE(6,'(/A)') ' Overlap ' - DO itype=1,atoms%ntype - IF(atoms%ntype.gt.1 .AND. mpi%irank==0) & - & WRITE(6,'(A,I3)') ' Atom type',itype - DO l=0,hybdat%lmaxc(itype) - DO i=1,hybdat%nindxc(l,itype) - IF ( mpi%irank == 0 )& - & WRITE(6,'(1x,I1,A,2X)',advance='no') i+l,lchar(l) - DO j=1,i - integrand = hybdat%core1(:,i,l,itype)*hybdat%core1(:,j,l,itype)& - & + hybdat%core2(:,i,l,itype)*hybdat%core2(:,j,l,itype) - IF ( mpi%irank == 0 ) WRITE(6,'(F10.6)', advance='no')& - & intgrf(integrand,atoms%jri,atoms%jmtd,atoms%rmsh,atoms%dx,atoms%ntype,itype,hybdat%gridf) - END DO - IF ( mpi%irank == 0 ) WRITE(6,*) - END DO - END DO - END DO - - IF ( mpi%irank == 0 ) WRITE(6,'(/A)') ' Overlap ' - ALLOCATE( olapcb(hybrid%maxindx),olapcv(maxval(hybrid%nbands),nkpti),& - & olapcv_avg( -hybdat%lmaxcd:hybdat%lmaxcd,hybdat%maxindxc,0:hybdat%lmaxcd,atoms%ntype),& - & olapcv_max( -hybdat%lmaxcd:hybdat%lmaxcd,hybdat%maxindxc,0:hybdat%lmaxcd,atoms%ntype),& - & olapcv_loc(2,-hybdat%lmaxcd:hybdat%lmaxcd,hybdat%maxindxc,0:hybdat%lmaxcd,atoms%ntype) ) - - DO itype=1,atoms%ntype - IF(atoms%ntype.gt.1 .AND. mpi%irank==0) & - & WRITE(6,'(A,I3)') ' Atom type',itype - DO l=0,hybdat%lmaxc(itype) - IF(l.gt.atoms%lmax(itype)) EXIT ! very improbable case - IF ( mpi%irank == 0 ) & - & WRITE(6,"(9X,'u(',A,')',4X,'udot(',A,')',:,3X,'ulo(',A,"//& - & "') ...')") (lchar(l),i=1,min(3,hybrid%nindx(l,itype))) - DO i=1,hybdat%nindxc(l,itype) - IF ( mpi%irank == 0 )& - & WRITE(6,'(1x,I1,A,2X)',advance='no') i+l,lchar(l) - DO j=1,hybrid%nindx(l,itype) - - integrand = hybdat%core1(:,i,l,itype)*hybdat%bas1(:,j,l,itype)& - & + hybdat%core2(:,i,l,itype)*hybdat%bas2(:,j,l,itype) - - olapcb(j) = & - & intgrf(integrand,atoms%jri,atoms%jmtd,atoms%rmsh,atoms%dx,atoms%ntype,itype,hybdat%gridf) - - IF ( mpi%irank == 0 )& - & WRITE(6,'(F10.6)',advance='no') olapcb(j) + call read_cmt(cmt(:, :, :, ikpt), ikpt) END DO - lm = sum ( (/ (hybrid%nindx(j,itype)*(2*j+1),j=0,l-1) /) ) - iatom = sum(atoms%neq(1:itype-1))+1 ! take first of group of equivalent atoms - DO m=-l,l - olapcv = 0 - DO j=1,hybrid%nindx(l,itype) - lm = lm + 1 - olapcv(:,:) = olapcv(:,:) + & - & olapcb(j)*cmt(:maxval(hybrid%nbands),lm,iatom,:nkpti) - END DO - rdum = sum ( abs(olapcv(:,:))**2 ) - rdum1 = maxval ( abs(olapcv(:,:)) ) - iarr = maxloc ( abs(olapcv(:,:)) ) - olapcv_avg( m,i,l,itype) = & - & sqrt( rdum / nkpti / sum(hybrid%nbands(:nkpti)) * nkpti ) - olapcv_max( m,i,l,itype) = rdum1 - olapcv_loc(:,m,i,l,itype) = iarr - END DO - IF ( mpi%irank == 0 ) WRITE(6,*) - - END DO - END DO - END DO - - IF( mpi%irank == 0 ) THEN - WRITE(6,'(/A)') ' Average overlap ' - DO itype=1,atoms%ntype - IF(atoms%ntype.gt.1) write(6,'(A,I3)') ' Atom type',itype - DO l=0,hybdat%lmaxc(itype) - DO i=1,hybdat%nindxc(l,itype) - WRITE(6,'(1x,I1,A,2X)',advance='no') i+l,lchar(l) - WRITE(6,'('//chr(2*l+1)//'F10.6)') & - & olapcv_avg(-l:l,i,l,itype) - END DO - END DO - END DO - - WRITE(6,'(/A)') ' Maximum overlap at (band/kpoint)' - DO itype=1,atoms%ntype - IF(atoms%ntype.gt.1) write(6,'(A,I3)') ' Atom type',itype - DO l=0,hybdat%lmaxc(itype) - DO i=1,hybdat%nindxc(l,itype) - WRITE(6,'(1x,I1,A,2X)',advance='no') i+l,lchar(l) - WRITE(6,'('//chr(2*l+1)//& - & '(F10.6,'' ('',I3.3,''/'',I4.3,'')''))')& - & (olapcv_max( m,i,l,itype),& - & olapcv_loc(:,m,i,l,itype),m=-l,l) - END DO - END DO - END DO - END IF ! mpi%irank == 0 - - DEALLOCATE (olapcb,olapcv,olapcv_avg,olapcv_max,olapcv_loc) - - IF ( mpi%irank == 0 ) WRITE(6,'(/A)') ' Overlap ' - - DO itype=1,atoms%ntype - IF(atoms%ntype.gt.1 .AND. mpi%irank==0) & - & WRITE(6,'(A,I3)') ' Atom type',itype - DO l=0,atoms%lmax(itype) - DO i=1,hybrid%nindx(l,itype) - IF ( mpi%irank == 0 ) THEN - SELECT CASE(i) - CASE(1) - WRITE(6,'(1x,'' u('',A,'')'')',advance='no') lchar(l) - CASE(2) - WRITE(6,'(1x,''udot('',A,'')'')',advance='no') lchar(l) - CASE DEFAULT - WRITE(6,'(1x,'' ulo('',A,'')'')',advance='no') lchar(l) - END SELECT - END IF - DO j=1,i - integrand = hybdat%bas1(:,i,l,itype)*hybdat%bas1(:,j,l,itype)& - & + hybdat%bas2(:,i,l,itype)*hybdat%bas2(:,j,l,itype) - - IF ( mpi%irank == 0 ) WRITE(6,'(F10.6)',advance='no')& - & intgrf(integrand,atoms%jri,atoms%jmtd,atoms%rmsh,atoms%dx,atoms%ntype,itype,hybdat%gridf) + IF (mpi%irank == 0) WRITE (6, '(/A)') ' Overlap ' + DO itype = 1, atoms%ntype + IF (atoms%ntype > 1 .AND. mpi%irank == 0) & + & WRITE (6, '(A,I3)') ' Atom type', itype + DO l = 0, hybdat%lmaxc(itype) + DO i = 1, hybdat%nindxc(l, itype) + IF (mpi%irank == 0)& + & WRITE (6, '(1x,I1,A,2X)', advance='no') i + l, lchar(l) + DO j = 1, i + integrand = hybdat%core1(:, i, l, itype)*hybdat%core1(:, j, l, itype)& + & + hybdat%core2(:, i, l, itype)*hybdat%core2(:, j, l, itype) + IF (mpi%irank == 0) WRITE (6, '(F10.6)', advance='no')& + & intgrf(integrand, atoms%jri, atoms%jmtd, atoms%rmsh, atoms%dx, atoms%ntype, itype, hybdat%gridf) + END DO + IF (mpi%irank == 0) WRITE (6, *) + END DO + END DO END DO - IF ( mpi%irank == 0 ) WRITE(6,*) - END DO - END DO - END DO - - IF( .not. l_mism ) RETURN - - IF ( mpi%irank == 0 ) WRITE(6,'(/A)') & - & 'Mismatch of wave functions at the MT-sphere boundaries' - ALLOCATE (carr1(maxval(hybrid%nbands),(atoms%lmaxd+1)**2)) - ALLOCATE (carr2(maxval(hybrid%nbands),(atoms%lmaxd+1)**2)) - ALLOCATE (carr3(maxval(hybrid%nbands),(atoms%lmaxd+1)**2)) - DO ikpt = 1,nkpti - call read_z(z(ikpt),ikpt) - END DO - - iatom = 0 - DO itype = 1,atoms%ntype - DO ineq = 1,atoms%neq(itype) - iatom = iatom + 1 - IF ( mpi%irank == 0 ) THEN - if(atoms%nat.gt.1) WRITE(6,'(2X,A,I3)') 'Atom',iatom - WRITE(6,'(2X,A)') 'k-point average ( maximum )' - END IF - - DO ikpt = 1,nkpti -#ifdef CPP_MPI - IF ( skip_kpt(ikpt) ) CYCLE -#endif - carr1 = 0; carr2 = 0; carr3 = 0 - - ! calculate k1,k2,k3 - CALL lapw%init(input,noco,kpts,atoms,sym,ikpt,cell,sym%zrfs) - - ! PW part - DO igpt = 1,lapw%nv(jsp) - gpt(1) = lapw%k1(igpt,jsp) - gpt(2) = lapw%k2(igpt,jsp) - gpt(3) = lapw%k3(igpt,jsp) - - cexp = exp(img * 2*pi_const * & - & dot_product(kpts%bkf(:,ikpt)+gpt,atoms%taual(:,iatom)) ) - q = matmul(kpts%bkf(:,ikpt)+gpt,cell%bmat) - - qnorm = sqrt(sum(q**2)) - call sphbessel(sphbes,atoms%rmt(itype)*qnorm,atoms%lmax(itype)) - call harmonicsr(y,q,atoms%lmax(itype)) - y = conjg(y) - lm = 0 - DO l = 0,atoms%lmax(itype) - cdum = 4*pi_const*img**l/sqrt(cell%omtil) * sphbes(l) * cexp - DO m = -l,l - lm = lm + 1 - DO iband = 1,hybrid%nbands(ikpt) - if (z(1)%l_real) THEN - carr2(iband,lm) = carr2(iband,lm) + cdum * z(ikpt)%data_r(igpt,iband) * y(lm) - Else - carr2(iband,lm) = carr2(iband,lm) + cdum * z(ikpt)%data_c(igpt,iband) * y(lm) - END if - end DO - END DO - END DO + + IF (mpi%irank == 0) WRITE (6, '(/A)') ' Overlap ' + ALLOCATE (olapcb(hybrid%maxindx), olapcv(maxval(hybrid%nbands), nkpti),& + & olapcv_avg(-hybdat%lmaxcd:hybdat%lmaxcd, hybdat%maxindxc, 0:hybdat%lmaxcd, atoms%ntype),& + & olapcv_max(-hybdat%lmaxcd:hybdat%lmaxcd, hybdat%maxindxc, 0:hybdat%lmaxcd, atoms%ntype),& + & olapcv_loc(2, -hybdat%lmaxcd:hybdat%lmaxcd, hybdat%maxindxc, 0:hybdat%lmaxcd, atoms%ntype)) + + DO itype = 1, atoms%ntype + IF (atoms%ntype > 1 .AND. mpi%irank == 0) & + & WRITE (6, '(A,I3)') ' Atom type', itype + DO l = 0, hybdat%lmaxc(itype) + IF (l > atoms%lmax(itype)) EXIT ! very improbable case + IF (mpi%irank == 0) & + & WRITE (6, "(9X,'u(',A,')',4X,'udot(',A,')',:,3X,'ulo(',A,"//& + & "') ...')") (lchar(l), i=1, min(3, hybrid%nindx(l, itype))) + DO i = 1, hybdat%nindxc(l, itype) + IF (mpi%irank == 0)& + & WRITE (6, '(1x,I1,A,2X)', advance='no') i + l, lchar(l) + DO j = 1, hybrid%nindx(l, itype) + + integrand = hybdat%core1(:, i, l, itype)*hybdat%bas1(:, j, l, itype)& + & + hybdat%core2(:, i, l, itype)*hybdat%bas2(:, j, l, itype) + + olapcb(j) = & + & intgrf(integrand, atoms%jri, atoms%jmtd, atoms%rmsh, atoms%dx, atoms%ntype, itype, hybdat%gridf) + + IF (mpi%irank == 0)& + & WRITE (6, '(F10.6)', advance='no') olapcb(j) + END DO + + lm = sum((/(hybrid%nindx(j, itype)*(2*j + 1), j=0, l - 1)/)) + iatom = sum(atoms%neq(1:itype - 1)) + 1 ! take first of group of equivalent atoms + DO m = -l, l + olapcv = 0 + DO j = 1, hybrid%nindx(l, itype) + lm = lm + 1 + olapcv(:, :) = olapcv(:, :) + & + & olapcb(j)*cmt(:maxval(hybrid%nbands), lm, iatom, :nkpti) + END DO + rdum = sum(abs(olapcv(:, :))**2) + rdum1 = maxval(abs(olapcv(:, :))) + iarr = maxloc(abs(olapcv(:, :))) + olapcv_avg(m, i, l, itype) = & + & sqrt(rdum/nkpti/sum(hybrid%nbands(:nkpti))*nkpti) + olapcv_max(m, i, l, itype) = rdum1 + olapcv_loc(:, m, i, l, itype) = iarr + END DO + IF (mpi%irank == 0) WRITE (6, *) + + END DO + END DO END DO - ! MT - lm = 0 - lm1 = 0 - DO l = 0,atoms%lmax(itype) - DO m = -l,l - lm = lm + 1 - DO n = 1,hybrid%nindx(l,itype) - lm1 = lm1 + 1 - rdum = hybdat%bas1(atoms%jri(itype),n,l,itype) / atoms%rmt(itype) - DO iband = 1,hybrid%nbands(ikpt) - carr3(iband,lm) = carr3(iband,lm) + cmt(iband,lm1,iatom,ikpt) * rdum + IF (mpi%irank == 0) THEN + WRITE (6, '(/A)') ' Average overlap ' + DO itype = 1, atoms%ntype + IF (atoms%ntype > 1) write (6, '(A,I3)') ' Atom type', itype + DO l = 0, hybdat%lmaxc(itype) + DO i = 1, hybdat%nindxc(l, itype) + WRITE (6, '(1x,I1,A,2X)', advance='no') i + l, lchar(l) + WRITE (6, '('//chr(2*l + 1)//'F10.6)') & + & olapcv_avg(-l:l, i, l, itype) + END DO + END DO + END DO + + WRITE (6, '(/A)') ' Maximum overlap at (band/kpoint)' + DO itype = 1, atoms%ntype + IF (atoms%ntype > 1) write (6, '(A,I3)') ' Atom type', itype + DO l = 0, hybdat%lmaxc(itype) + DO i = 1, hybdat%nindxc(l, itype) + WRITE (6, '(1x,I1,A,2X)', advance='no') i + l, lchar(l) + WRITE (6, '('//chr(2*l + 1)//& + & '(F10.6,'' ('',I3.3,''/'',I4.3,'')''))')& + & (olapcv_max(m, i, l, itype),& + & olapcv_loc(:, m, i, l, itype), m=-l, l) + END DO END DO - END DO - END DO + END DO + END IF ! mpi%irank == 0 + + DEALLOCATE (olapcb, olapcv, olapcv_avg, olapcv_max, olapcv_loc) + + IF (mpi%irank == 0) WRITE (6, '(/A)') ' Overlap ' + + DO itype = 1, atoms%ntype + IF (atoms%ntype > 1 .AND. mpi%irank == 0) & + & WRITE (6, '(A,I3)') ' Atom type', itype + DO l = 0, atoms%lmax(itype) + DO i = 1, hybrid%nindx(l, itype) + IF (mpi%irank == 0) THEN + SELECT CASE (i) + CASE (1) + WRITE (6, '(1x,'' u('',A,'')'')', advance='no') lchar(l) + CASE (2) + WRITE (6, '(1x,''udot('',A,'')'')', advance='no') lchar(l) + CASE DEFAULT + WRITE (6, '(1x,'' ulo('',A,'')'')', advance='no') lchar(l) + END SELECT + END IF + DO j = 1, i + integrand = hybdat%bas1(:, i, l, itype)*hybdat%bas1(:, j, l, itype)& + & + hybdat%bas2(:, i, l, itype)*hybdat%bas2(:, j, l, itype) + + IF (mpi%irank == 0) WRITE (6, '(F10.6)', advance='no')& + & intgrf(integrand, atoms%jri, atoms%jmtd, atoms%rmsh, atoms%dx, atoms%ntype, itype, hybdat%gridf) + END DO + IF (mpi%irank == 0) WRITE (6, *) + END DO + END DO END DO - carr1 = carr2 - carr3 - - rarr = 0 - lm = 0 - DO l = 0,atoms%lmax(itype) - DO m = -l,l - lm = lm + 1 - rarr = rarr + abs(carr1(:,lm))**2 - END DO + + IF (.not. l_mism) RETURN + + IF (mpi%irank == 0) WRITE (6, '(/A)') & + & 'Mismatch of wave functions at the MT-sphere boundaries' + ALLOCATE (carr1(maxval(hybrid%nbands), (atoms%lmaxd + 1)**2)) + ALLOCATE (carr2(maxval(hybrid%nbands), (atoms%lmaxd + 1)**2)) + ALLOCATE (carr3(maxval(hybrid%nbands), (atoms%lmaxd + 1)**2)) + DO ikpt = 1, nkpti + call read_z(z(ikpt), ikpt) END DO - rarr = sqrt ( rarr / (4*pi_const) ) - ! WRITE(outtext,'(I6,4X,F14.12,'' ('',F14.12,'')'')') & - ! & ikpt,sum(rarr(:1)**2/nbands(ikpt)),maxval(rarr(:1)) - ! CALL writeout(outtext,mpi%irank) + + iatom = 0 + DO itype = 1, atoms%ntype + DO ineq = 1, atoms%neq(itype) + iatom = iatom + 1 + IF (mpi%irank == 0) THEN + if (atoms%nat > 1) WRITE (6, '(2X,A,I3)') 'Atom', iatom + WRITE (6, '(2X,A)') 'k-point average ( maximum )' + END IF + + DO ikpt = 1, nkpti +#ifdef CPP_MPI + IF (skip_kpt(ikpt)) CYCLE +#endif + carr1 = 0; carr2 = 0; carr3 = 0 + + ! calculate k1,k2,k3 + CALL lapw%init(input, noco, kpts, atoms, sym, ikpt, cell, sym%zrfs) + + ! PW part + DO igpt = 1, lapw%nv(jsp) + gpt(1) = lapw%k1(igpt, jsp) + gpt(2) = lapw%k2(igpt, jsp) + gpt(3) = lapw%k3(igpt, jsp) + + cexp = exp(img*2*pi_const* & + & dot_product(kpts%bkf(:, ikpt) + gpt, atoms%taual(:, iatom))) + q = matmul(kpts%bkf(:, ikpt) + gpt, cell%bmat) + + qnorm = sqrt(sum(q**2)) + call sphbessel(sphbes, atoms%rmt(itype)*qnorm, atoms%lmax(itype)) + call harmonicsr(y, q, atoms%lmax(itype)) + y = conjg(y) + lm = 0 + DO l = 0, atoms%lmax(itype) + cdum = 4*pi_const*img**l/sqrt(cell%omtil)*sphbes(l)*cexp + DO m = -l, l + lm = lm + 1 + DO iband = 1, hybrid%nbands(ikpt) + if (z(1)%l_real) THEN + carr2(iband, lm) = carr2(iband, lm) + cdum*z(ikpt)%data_r(igpt, iband)*y(lm) + Else + carr2(iband, lm) = carr2(iband, lm) + cdum*z(ikpt)%data_c(igpt, iband)*y(lm) + END if + end DO + END DO + END DO + END DO + + ! MT + lm = 0 + lm1 = 0 + DO l = 0, atoms%lmax(itype) + DO m = -l, l + lm = lm + 1 + DO n = 1, hybrid%nindx(l, itype) + lm1 = lm1 + 1 + rdum = hybdat%bas1(atoms%jri(itype), n, l, itype)/atoms%rmt(itype) + DO iband = 1, hybrid%nbands(ikpt) + carr3(iband, lm) = carr3(iband, lm) + cmt(iband, lm1, iatom, ikpt)*rdum + END DO + END DO + END DO + END DO + carr1 = carr2 - carr3 + + rarr = 0 + lm = 0 + DO l = 0, atoms%lmax(itype) + DO m = -l, l + lm = lm + 1 + rarr = rarr + abs(carr1(:, lm))**2 + END DO + END DO + rarr = sqrt(rarr/(4*pi_const)) + ! WRITE(outtext,'(I6,4X,F14.12,'' ('',F14.12,'')'')') & + ! & ikpt,sum(rarr(:1)**2/nbands(ikpt)),maxval(rarr(:1)) + ! CALL writeout(outtext,mpi%irank) ! IF( iatom .eq. 6 ) THEN ! cdum = exp(2*pi*img*dot_product(bkf(:,ikpt),(/0.0,0.0,1.0/) )) -! lm = 0 +! lm = 0 ! DO l = 0,lmax(itype) ! DO m = -l,l ! lm = lm + 1 @@ -328,11 +327,10 @@ ! END DO ! END IF - END DO - END DO - END DO - + END DO + END DO + END DO - END SUBROUTINE checkolap + END SUBROUTINE checkolap END MODULE m_checkolap diff --git a/hybrid/coulombmatrix.F90 b/hybrid/coulombmatrix.F90 index ac5a1a823d66fac21665cdf4b727f5837fbe1e40..396df6df31a589ccab7caef77bc843442f250e31 100644 --- a/hybrid/coulombmatrix.F90 +++ b/hybrid/coulombmatrix.F90 @@ -154,7 +154,6 @@ CONTAINS nbasm1 = hybrid%nbasp + hybrid%ngptm(:) - ! Calculate the structure constant CALL structureconstant(structconst, cell, hybrid, atoms, kpts, mpi) @@ -168,7 +167,7 @@ CONTAINS IF (ALLOCATED(coulomb)) DEALLOCATE (coulomb) ALLOCATE (coulomb(hybrid%maxbasm1*(hybrid%maxbasm1 + 1)/2, kpts%nkpt), stat=ok) - IF (ok .NE. 0) STOP 'coulombmatrix: failure allocation coulomb matrix' + IF (ok /= 0) STOP 'coulombmatrix: failure allocation coulomb matrix' coulomb = 0 call timestop("coulomb allocation") @@ -182,7 +181,7 @@ CONTAINS CALL cpu_TIME(time1) ! calculate rotations in reciprocal space DO isym = 1, sym%nsym - IF (isym .LE. sym%nop) THEN + IF (isym <= sym%nop) THEN inviop = sym%invtab(isym) rrot(:, :, isym) = TRANSPOSE(sym%mrot(:, :, inviop)) DO l = 0, hybrid%maxlcutm1 @@ -223,7 +222,7 @@ CONTAINS END IF IF (ANY(sym%tau(:, isym2) /= 0)) CYCLE - IF (ALL(ABS(MATMUL(rrot(:, :, isym), kpts%bk(:, ikpt)) - kpts%bk(:, ikpt)) .LT. 10.0**-12)) THEN + IF (ALL(ABS(MATMUL(rrot(:, :, isym), kpts%bk(:, ikpt)) - kpts%bk(:, ikpt)) < 10.0**-12)) THEN isym1 = isym1 + 1 sym1(isym1, ikpt) = isym END IF @@ -245,13 +244,13 @@ CONTAINS iarr = 0 j = 0 DO igpt = hybrid%ngptm(ikpt), 1, -1 - IF (iarr(igpt) .EQ. 0) THEN + IF (iarr(igpt) == 0) THEN j = j + 1 hybrid%pgptm1(j, ikpt) = igpt DO isym1 = 1, nsym1(ikpt) g = MATMUL(rrot(:, :, sym1(isym1, ikpt)), hybrid%gptm(:, hybrid%pgptm(igpt, ikpt))) i = POINTER(ikpt, g(1), g(2), g(3)) - IF (i .EQ. 0) STOP 'coulombmatrix: zero pointer (bug?)' + IF (i == 0) STOP 'coulombmatrix: zero pointer (bug?)' iarr(i) = 1 END DO END IF @@ -297,7 +296,7 @@ CONTAINS lp1: DO l2 = 0, l1 DO m2 = -l2, l2 lm2 = lm2 + 1 - IF (lm2 .GT. lm1) EXIT lp1 ! Don't cross the diagonal! + IF (lm2 > lm1) EXIT lp1 ! Don't cross the diagonal! gmat(lm1, lm2) = facB(l1 + l2 + m2 - m1)*facB(l1 + l2 + m1 - m2)/ & (facB(l1 + m1)*facB(l1 - m1)*facB(l2 + m2)*facB(l2 - m2))/ & SQRT(1.0*(2*l1 + 1)*(2*l2 + 1)*(2*(l1 + l2) + 1))*(4*pi_const)**1.5 @@ -348,7 +347,6 @@ CONTAINS iqnrmstep = mpi%isize call timestop("getnorm") - call timestart("Bessel calculation") DO iqnrm = iqnrmstart, nqnrm, iqnrmstep qnorm = qnrm(iqnrm) @@ -357,26 +355,26 @@ CONTAINS rdum = atoms%rmt(itype) sphbes_var = 0 sphbesmoment1 = 0 - IF (qnorm .EQ. 0) THEN + IF (qnorm == 0) THEN sphbesmoment(0, itype, iqnrm) = rdum**3/3 DO i = 1, ng sphbes_var(i, 0) = 1 sphbesmoment1(i, 0) = atoms%rmsh(i, itype)**2/3 + (rdum**2 - atoms%rmsh(i, itype)**2)/2 END DO ELSE - call sphbes(hybrid%lexp+1, qnorm*rdum, rarr) + call sphbes(hybrid%lexp + 1, qnorm*rdum, rarr) DO l = 0, hybrid%lexp sphbesmoment(l, itype, iqnrm) = rdum**(l + 2)*rarr(l + 1)/qnorm END DO DO i = ng, 1, -1 rdum = atoms%rmsh(i, itype) - call sphbes(hybrid%lcutm1(itype)+1, qnorm*rdum, rarr) + call sphbes(hybrid%lcutm1(itype) + 1, qnorm*rdum, rarr) DO l = 0, hybrid%lcutm1(itype) sphbes_var(i, l) = rarr(l) - IF (l .NE. 0) THEN; rdum1 = -rdum**(1 - l)*rarr(l - 1) + IF (l /= 0) THEN; rdum1 = -rdum**(1 - l)*rarr(l - 1) ELSE; rdum1 = -COS(qnorm*rdum)/qnorm ENDIF - IF (i .EQ. ng) rarr1(l) = rdum1 + IF (i == ng) rarr1(l) = rdum1 sphbesmoment1(i, l) = (rdum**(l + 2)*rarr(l + 1)/rdum**(l + 1) & + (rarr1(l) - rdum1)*rdum**l)/qnorm END DO @@ -470,7 +468,7 @@ CONTAINS ! (1b) r,r' in different MT ALLOCATE (coulmat(hybrid%nbasp, hybrid%nbasp), stat=ok) - IF (ok .NE. 0) STOP 'coulombmatrix: failure allocation coulmat' + IF (ok /= 0) STOP 'coulombmatrix: failure allocation coulmat' coulmat = 0 END IF @@ -504,7 +502,7 @@ CONTAINS lm1 = lm1 + 1 DO n1 = 1, hybrid%nindxm1(l1, itype1) iy = iy + 1 - IF (iy .GT. ix) EXIT lp2 ! Don't cross the diagonal! + IF (iy > ix) EXIT lp2 ! Don't cross the diagonal! rdum = (-1)**(l2 + m2)*moment(n1, l1, itype1)*moment(n2, l2, itype2)*gmat(lm1, lm2) l = l1 + l2 lm = l**2 + l + m1 - m2 + 1 @@ -549,7 +547,7 @@ CONTAINS WRITE (6, *) END IF - IF (hybrid%maxgptm .EQ. 0) GOTO 1 ! skip calculation of plane-wave contribution if mixed basis does not contain plane waves + IF (hybrid%maxgptm == 0) GOTO 1 ! skip calculation of plane-wave contribution if mixed basis does not contain plane waves ! ! (2) Case < MT | v | PW > @@ -564,9 +562,8 @@ CONTAINS ! (2c) r,r' in different MT ALLOCATE (coulmat(hybrid%nbasp, hybrid%maxgptm), stat=ok) - IF (ok .NE. 0) STOP 'coulombmatrix: failure allocation coulmat' + IF (ok /= 0) STOP 'coulombmatrix: failure allocation coulmat' coulmat = 0 - call timestart("loop over interst.") DO ikpt = ikptmin, ikptmax !1,kpts%nkpt @@ -580,13 +577,13 @@ CONTAINS q = MATMUL(kpts%bk(:, ikpt) + hybrid%gptm(:, igptp), cell%bmat) qnorm = SQRT(SUM(q**2)) iqnrm = pqnrm(igpt, ikpt) - IF (ABS(qnrm(iqnrm) - qnorm) .GT. 10.0**-12) then + IF (ABS(qnrm(iqnrm) - qnorm) > 10.0**-12) then STOP 'coulombmatrix: qnorm does not equal corresponding & element in qnrm (bug?)' ! We shouldn't stop here! endif call timestart("harmonics") - call ylm4(2, MATMUL(kpts%bk(:, kpts%nkpt), cell%bmat), y1) - call ylm4(2, MATMUL(hybrid%gptm(:, igptp), cell%bmat), y2) + call ylm4(2, MATMUL(kpts%bk(:, kpts%nkpt), cell%bmat), y1) + call ylm4(2, MATMUL(hybrid%gptm(:, igptp), cell%bmat), y2) call ylm4(hybrid%lexp, q, y) call timestop("harmonics") y1 = CONJG(y1); y2 = CONJG(y2); y = CONJG(y) @@ -627,19 +624,19 @@ CONTAINS END DO ! add contribution of (2c) to csum and csumf coming from linear and quadratic orders of Y_lm*(G) / G * j_(l+1)(GS) - IF (ikpt .EQ. 1 .AND. l .LE. 2) THEN + IF (ikpt == 1 .AND. l <= 2) THEN cexp = EXP(CMPLX(0.0, 1.0)*2*pi_const*dot_PRODUCT(hybrid%gptm(:, igptp), atoms%taual(:, ic1))) & *gmat(lm, 1)*4*pi_const/cell%vol csumf(lm) = csumf(lm) - cexp*SQRT(4*pi_const)* & CMPLX(0.0, 1.0)**l*sphbesmoment(0, itype1, iqnrm)/facC(l - 1) - IF (l .EQ. 0) THEN - IF (igpt .NE. 1) THEN + IF (l == 0) THEN + IF (igpt /= 1) THEN csum = csum - cexp*(sphbesmoment(0, itype1, iqnrm)*atoms%rmt(itype1)**2 - & sphbesmoment(2, itype1, iqnrm)*2.0/3)/10 ELSE csum = csum - cexp*atoms%rmt(itype1)**5/30 END IF - ELSE IF (l .EQ. 1) THEN + ELSE IF (l == 1) THEN csum = csum + cexp*CMPLX(0.0, 1.0)*SQRT(4*pi_const) & *sphbesmoment(1, itype1, iqnrm)*y(lm)/3 END IF @@ -649,7 +646,7 @@ CONTAINS END DO ! add contribution of (2a) to csumf - IF (ikpt .EQ. 1 .AND. igpt .EQ. 1 .AND. l .LE. 2) THEN + IF (ikpt == 1 .AND. igpt == 1 .AND. l <= 2) THEN csumf(lm) = csumf(lm) + (4*pi_const)**2*CMPLX(0.0, 1.0)**l/facC(l) END IF @@ -661,8 +658,8 @@ CONTAINS DO n = 1, hybrid%nindxm1(l, itype) iy = iy + 1 - IF (ikpt .EQ. 1 .AND. igpt .EQ. 1) THEN - IF (l .EQ. 0) coulmat(iy, ix - hybrid%nbasp) = & + IF (ikpt == 1 .AND. igpt == 1) THEN + IF (l == 0) coulmat(iy, ix - hybrid%nbasp) = & -cdum*moment2(n, itype)/6/svol ! (2a) coulmat(iy, ix - hybrid%nbasp) = coulmat(iy, ix - hybrid%nbasp) & + (-cdum/(2*l + 1)*integral(n, l, itype, iqnrm) & ! (2b)& @@ -693,7 +690,7 @@ CONTAINS DO i = 1, hybrid%ngptm(ikpt) DO j = 1, hybrid%nbasp + i M = M + 1 - IF (j .LE. hybrid%nbasp) coulomb(M, ikpt) = coulmat(j, i) + IF (j <= hybrid%nbasp) coulomb(M, ikpt) = coulmat(j, i) END DO END DO END DO @@ -726,7 +723,7 @@ CONTAINS DO igpt1 = 1, igpt2 g = hybrid%gptm(:, igpt2) - hybrid%gptm(:, igpt1) gnorm = gptnorm(g, cell%bmat) - IF (gnorm .EQ. 0) THEN + IF (gnorm == 0) THEN DO itype = 1, atoms%ntype smat(igpt1, igpt2) = smat(igpt1, igpt2) + atoms%neq(itype)*4*pi_const*atoms%rmt(itype)**3/3 END DO @@ -758,7 +755,7 @@ CONTAINS iy = hybrid%nbasp q2 = MATMUL(kpts%bk(:, ikpt) + hybrid%gptm(:, igptp2), cell%bmat) rdum2 = SUM(q2**2) - IF (rdum2 .NE. 0) rdum2 = 4*pi_const/rdum2 + IF (rdum2 /= 0) rdum2 = 4*pi_const/rdum2 DO igpt1 = 1, igpt2 igptp1 = hybrid%pgptm(igpt1, ikpt) @@ -766,20 +763,20 @@ CONTAINS q1 = MATMUL(kpts%bk(:, ikpt) + hybrid%gptm(:, igptp1), cell%bmat) idum = ix*(ix - 1)/2 + iy rdum1 = SUM(q1**2) - IF (rdum1 .NE. 0) rdum1 = 4*pi_const/rdum1 + IF (rdum1 /= 0) rdum1 = 4*pi_const/rdum1 - IF (ikpt .EQ. 1) THEN - IF (igpt1 .NE. 1) THEN + IF (ikpt == 1) THEN + IF (igpt1 /= 1) THEN coulomb(idum, 1) = -smat(igptp1, igptp2)*rdum1/cell%vol END IF - IF (igpt2 .NE. 1) THEN + IF (igpt2 /= 1) THEN coulomb(idum, 1) = coulomb(idum, 1) - smat(igptp1, igptp2)*rdum2/cell%vol END IF ELSE coulomb(idum, ikpt) = -smat(igptp1, igptp2)*(rdum1 + rdum2)/cell%vol END IF END DO - IF (ikpt .NE. 1 .OR. igpt2 .NE. 1) THEN ! + IF (ikpt /= 1 .OR. igpt2 /= 1) THEN ! coulomb(idum, ikpt) = coulomb(idum, ikpt) + rdum2 ! diagonal term END IF ! END DO @@ -842,7 +839,7 @@ CONTAINS DO m2 = -l2, l2 lm2 = lm2 + 1 cdum = idum*sphbesmoment(l2, itype2, iqnrm2)*cexp*carr2a(lm2, igpt2) - IF (cdum .NE. 0) THEN + IF (cdum /= 0) THEN lm1 = 0 DO l1 = 0, hybrid%lexp l = l1 + l2 @@ -994,8 +991,8 @@ CONTAINS DO iqnrm = 1, nqnrm DO itype = 1, atoms%ntype rdum = qnrm(iqnrm)*atoms%rmt(itype) - call sphbes(hybrid%lexp+2, rdum, sphbes0(0, itype, iqnrm)) - IF (rdum .NE. 0) sphbes0(-1, itype, iqnrm) = COS(rdum)/rdum + call sphbes(hybrid%lexp + 2, rdum, sphbes0(0, itype, iqnrm)) + IF (rdum /= 0) sphbes0(-1, itype, iqnrm) = COS(rdum)/rdum END DO END DO call timestop("sphbesintegral") @@ -1115,7 +1112,7 @@ CONTAINS kpts, hybrid%maxlcutm1, atoms, hybrid%lcutm1, & hybrid%nindxm1, hybrid%maxindxm1, dwgn(:, :, :, isym), & hybrid%nbasp, nbasm1) - IF (iarr(igpt1) .EQ. 0) THEN + IF (iarr(igpt1) == 0) THEN CALL bramat_trafo( & carr2(:, 1), igpt1, & carr2(:, 2), igpt2, ikpt, isym, .TRUE., POINTER(ikpt, :, :, :), & @@ -1363,7 +1360,7 @@ CONTAINS ! additional contributions occur ! call timestart("gamma point treatment") - IF (ikpt .EQ. 1) THEN + IF (ikpt == 1) THEN ! ! store the contribution of the G=0 plane wave with the MT l=0 functions in ! coulomb_mt2(:hybrid%nindxm1(l=0,itype),0,hybrid%maxlcutm1+1,iatom) @@ -1429,7 +1426,7 @@ CONTAINS iatom, ikpt0) & - coulomb_mt3_r(:hybrid%nindxm1(0, itype) - 1, iatom, & iatom, ikpt0))) & - .GT. 1E-08) & + > 1E-08) & call judft_error('coulombmatrix: coulomb_mt2 and coulomb_mt3 are inconsistent') else @@ -1437,7 +1434,7 @@ CONTAINS iatom, ikpt0) & - coulomb_mt3_c(:hybrid%nindxm1(0, itype) - 1, iatom, & iatom, ikpt0))) & - .GT. 1E-08) & + > 1E-08) & call judft_error('coulombmatrix: coulomb_mt2 and coulomb_mt3 are inconsistent') endif END DO @@ -1479,7 +1476,7 @@ CONTAINS DO m1 = -l1, l1 indx2 = indx2 + 1 indx4 = indx4 + hybrid%nindxm1(l1, itype1) - IF (indx4 .LT. indx3) CYCLE + IF (indx4 < indx3) CYCLE IF (calc_mt(ikpt)) THEN IF (sym%invs) THEN coulomb_mtir_r(indx1, indx2, ikpt1) = coulhlp%data_r(indx3, indx4) @@ -1516,7 +1513,7 @@ CONTAINS END DO call timestop("residual MT contributions") - IF (indx1 .NE. ic) STOP 'coulombmatrix: error index counting' + IF (indx1 /= ic) STOP 'coulombmatrix: error index counting' ! ! add ir part to the matrix coulomb_mtir @@ -1637,7 +1634,7 @@ CONTAINS DO M = -l, l DO i = 1, hybrid%nindxm1(l, itype) j = j + 1 - IF (l .EQ. 0) THEN + IF (l == 0) THEN coeff(j) = SQRT(4*pi_const) & *intgrf(atoms%rmsh(:, itype)*hybrid%basm1(:, i, 0, itype), & atoms%jri, atoms%jmtd, atoms%rmsh, atoms%dx, atoms%ntype, itype, gridf) & @@ -1648,7 +1645,7 @@ CONTAINS atoms%jri, atoms%jmtd, atoms%rmsh, atoms%dx, atoms%ntype, itype, gridf) & /SQRT(cell%vol) - ELSE IF (l .EQ. 1) THEN + ELSE IF (l == 1) THEN cderiv(j, M) = -SQRT(4*pi_const/3)*CMPLX(0.0, 1.0) & *intgrf(atoms%rmsh(:, itype)**2*hybrid%basm1(:, i, 1, itype), & atoms%jri, atoms%jmtd, atoms%rmsh, atoms%dx, atoms%ntype, itype, gridf) & @@ -1815,13 +1812,13 @@ CONTAINS g(5) = rexp/a**6*(1 + a*(1 + a/2*(1 + a/3*(1 + a/4*(1 + a/5*(1 + a/6 & *(1 + a/7*(1 + a/8*(1 + a/9*(1 + a/10)))))))))) g(6) = rexp/a**7*(1 + a*(1 + a/2*(1 + a/3*(1 + a/4*(1 + a/5*(1 + a/6 & - *(1 + a/7*(1 + a/8*(1 + a/9*(1 + a/10*(1 + a/11*(1 + a/12)))))))))))) + *(1 + a/7*(1 + a/8*(1 + a/9*(1 + a/10*(1 + a/11*(1 + a/12)))))))))))) g(7) = rexp/a**8*(1 + a*(1 + a/2*(1 + a/3*(1 + a/4*(1 + a/5*(1 + a/6 & - *(1 + a/7*(1 + a/8*(1 + a/9*(1 + a/10*(1 + a/11*(1 + a/12*(1 + a/13))))))))))))) + *(1 + a/7*(1 + a/8*(1 + a/9*(1 + a/10*(1 + a/11*(1 + a/12*(1 + a/13))))))))))))) DO l = 8, 2*hybrid%lexp g(l) = a**(-l - 1) END DO - IF (ANY(g .GT. convpar/10)) THEN ! one digit more accuracy for real-space sum + IF (ANY(g > convpar/10)) THEN ! one digit more accuracy for real-space sum a = a + 1 GOTO 1 END IF @@ -1840,7 +1837,7 @@ CONTAINS g(5) = pref*aa**6*a**3/945 g(6) = pref*aa**7*a**4/10395 g(7) = pref*aa**7*a**5/135135 - IF (ANY(g .GT. convpar)) THEN + IF (ANY(g > convpar)) THEN a = a + 1 GOTO 2 END IF @@ -1869,7 +1866,7 @@ CONTAINS call timestart("realspace sum") DO ic2 = 1, atoms%nat DO ic1 = 1, atoms%nat - IF (ic2 .NE. 1 .AND. ic1 .EQ. ic2) CYCLE + IF (ic2 /= 1 .AND. ic1 == ic2) CYCLE rc = MATMUL(cell%amat, (atoms%taual(:, ic2) - atoms%taual(:, ic1))) DO i = 1, nptsh ra = MATMUL(cell%amat, ptsh(:, i)) + rc @@ -1887,45 +1884,45 @@ CONTAINS conv = HUGE(i) shlp = 0 DO i = 1, nptsh - IF (ALL(conv .NE. HUGE(i))) EXIT - IF (i .NE. 1) THEN - IF (ABS(radsh(i) - radsh(i - 1)) .GT. 10.0**-10) ishell = ishell + 1 + IF (ALL(conv /= HUGE(i))) EXIT + IF (i /= 1) THEN + IF (ABS(radsh(i) - radsh(i - 1)) > 10.0**-10) ishell = ishell + 1 ENDIF ra = MATMUL(cell%amat, ptsh(:, i)) + rc a = scale*SQRT(SUM(ra**2)) - IF (a .EQ. 0) THEN + IF (a == 0) THEN CYCLE - ELSE IF (ABS(a - a1) .GT. 10.0**-10) THEN + ELSE IF (ABS(a - a1) > 10.0**-10) THEN a1 = a rexp = EXP(-a) - IF (ishell .LE. conv(0)) g(0) = rexp/a & - *(1 + a*11/16*(1 + a*3/11*(1 + a/9))) - IF (ishell .LE. conv(1)) g(1) = rexp/a**2 & - *(1 + a*(1 + a/2*(1 + a*7/24*(1 + a/7)))) - IF (ishell .LE. conv(2)) g(2) = rexp/a**3 & - *(1 + a*(1 + a/2*(1 + a/3*(1 + a/4*(1 + a*3/16*(1 + a/9)))))) - IF (ishell .LE. conv(3)) g(3) = rexp/a**4 & - *(1 + a*(1 + a/2*(1 + a/3*(1 + a/4*(1 + a/5*(1 + a/6*(1 + a/8))))))) - IF (ishell .LE. conv(4)) g(4) = rexp/a**5 & - *(1 + a*(1 + a/2*(1 + a/3*(1 + a/4*(1 + a/5*(1 + a/6*(1 + a/7*(1 + a/8 & - *(1 + a/10))))))))) - IF (ishell .LE. conv(5)) g(5) = rexp/a**6 & - *(1 + a*(1 + a/2*(1 + a/3*(1 + a/4*(1 + a/5*(1 + a/6*(1 + a/7*(1 + a/8*(1 + a/9 & - *(1 + a/10)))))))))) - IF (ishell .LE. conv(6)) g(6) = rexp/a**7 & - *(1 + a*(1 + a/2*(1 + a/3*(1 + a/4*(1 + a/5*(1 + a/6*(1 + a/7*(1 + a/8*(1 + a/9 & - *(1 + a/10*(1 + a/11*(1 + a/12)))))))))))) - IF (ishell .LE. conv(7)) g(7) = rexp/a**8 & - *(1 + a*(1 + a/2*(1 + a/3*(1 + a/4*(1 + a/5*(1 + a/6*(1 + a/7*(1 + a/8*(1 + a/9 & - *(1 + a/10*(1 + a/11*(1 + a/12*(1 + a/13))))))))))))) + IF (ishell <= conv(0)) g(0) = rexp/a & + *(1 + a*11/16*(1 + a*3/11*(1 + a/9))) + IF (ishell <= conv(1)) g(1) = rexp/a**2 & + *(1 + a*(1 + a/2*(1 + a*7/24*(1 + a/7)))) + IF (ishell <= conv(2)) g(2) = rexp/a**3 & + *(1 + a*(1 + a/2*(1 + a/3*(1 + a/4*(1 + a*3/16*(1 + a/9)))))) + IF (ishell <= conv(3)) g(3) = rexp/a**4 & + *(1 + a*(1 + a/2*(1 + a/3*(1 + a/4*(1 + a/5*(1 + a/6*(1 + a/8))))))) + IF (ishell <= conv(4)) g(4) = rexp/a**5 & + *(1 + a*(1 + a/2*(1 + a/3*(1 + a/4*(1 + a/5*(1 + a/6*(1 + a/7*(1 + a/8 & + *(1 + a/10))))))))) + IF (ishell <= conv(5)) g(5) = rexp/a**6 & + *(1 + a*(1 + a/2*(1 + a/3*(1 + a/4*(1 + a/5*(1 + a/6*(1 + a/7*(1 + a/8*(1 + a/9 & + *(1 + a/10)))))))))) + IF (ishell <= conv(6)) g(6) = rexp/a**7 & + *(1 + a*(1 + a/2*(1 + a/3*(1 + a/4*(1 + a/5*(1 + a/6*(1 + a/7*(1 + a/8*(1 + a/9 & + *(1 + a/10*(1 + a/11*(1 + a/12)))))))))))) + IF (ishell <= conv(7)) g(7) = rexp/a**8 & + *(1 + a*(1 + a/2*(1 + a/3*(1 + a/4*(1 + a/5*(1 + a/6*(1 + a/7*(1 + a/8*(1 + a/9 & + *(1 + a/10*(1 + a/11*(1 + a/12*(1 + a/13))))))))))))) DO l = 8, maxl - IF (ishell .LE. conv(l)) g(l) = a**(-l - 1) + IF (ishell <= conv(l)) g(l) = a**(-l - 1) END DO DO l = 0, maxl - IF (conv(l) .EQ. HUGE(i) .AND. g(l) .LT. convpar(l)/10) conv(l) = ishell + ADDSHELL1 + IF (conv(l) == HUGE(i) .AND. g(l) < convpar(l)/10) conv(l) = ishell + ADDSHELL1 END DO END IF - IF (ishell .GT. conv(maxl) .AND. maxl .NE. 0) maxl = maxl - 1 + IF (ishell > conv(maxl) .AND. maxl /= 0) maxl = maxl - 1 call timestart("harmonics") call ylm4(maxl, ra, y) call timestop("harmonics") @@ -1936,7 +1933,7 @@ CONTAINS cexp = EXP(CMPLX(0.0, 1.0)*2*pi_const*rdum) lm = 0 DO l = 0, maxl - IF (ishell .LE. conv(l)) THEN + IF (ishell <= conv(l)) THEN cdum = cexp*g(l) DO M = -l, l lm = lm + 1 @@ -1980,43 +1977,43 @@ CONTAINS ishell = 1 conv = HUGE(i) DO i = 1, nptsh - IF (i .GT. 1) THEN - IF (ABS(radsh(i) - radsh(i - 1)) .GT. 10.0**-10) ishell = ishell + 1 + IF (i > 1) THEN + IF (ABS(radsh(i) - radsh(i - 1)) > 10.0**-10) ishell = ishell + 1 ENDIF ki = ptsh(:, i) + k - NINT(k) ! -nint(...) transforms to Wigner-Seitz cell ( i.e. -0.5 <= x,y,z < 0.5 ) ka = MATMUL(ki, cell%bmat) a = SQRT(SUM(ka**2))/scale aa = (1 + a**2)**(-1) - IF (ABS(a - a1) .GT. 10.0**-10) THEN + IF (ABS(a - a1) > 10.0**-10) THEN a1 = a - IF (a .EQ. 0) THEN + IF (a == 0) THEN g(0) = pref*(-4) g(1) = 0 ELSE - IF (ishell .LE. conv(0)) g(0) = pref*aa**4/a**2 - IF (ishell .LE. conv(1)) g(1) = pref*aa**4/a + IF (ishell <= conv(0)) g(0) = pref*aa**4/a**2 + IF (ishell <= conv(1)) g(1) = pref*aa**4/a END IF - IF (ishell .LE. conv(2)) g(2) = pref*aa**5/3 - IF (ishell .LE. conv(3)) g(3) = pref*aa**5*a/15 - IF (ishell .LE. conv(4)) g(4) = pref*aa**6*a**2/105 - IF (ishell .LE. conv(5)) g(5) = pref*aa**6*a**3/945 - IF (ishell .LE. conv(6)) g(6) = pref*aa**7*a**4/10395 - IF (ishell .LE. conv(7)) g(7) = pref*aa**7*a**5/135135 - IF (ishell .GT. 1) THEN + IF (ishell <= conv(2)) g(2) = pref*aa**5/3 + IF (ishell <= conv(3)) g(3) = pref*aa**5*a/15 + IF (ishell <= conv(4)) g(4) = pref*aa**6*a**2/105 + IF (ishell <= conv(5)) g(5) = pref*aa**6*a**3/945 + IF (ishell <= conv(6)) g(6) = pref*aa**7*a**4/10395 + IF (ishell <= conv(7)) g(7) = pref*aa**7*a**5/135135 + IF (ishell > 1) THEN DO l = 0, 7 - IF (conv(l) .EQ. HUGE(i) .AND. g(l) .LT. convpar(l)) conv(l) = ishell + ADDSHELL2 + IF (conv(l) == HUGE(i) .AND. g(l) < convpar(l)) conv(l) = ishell + ADDSHELL2 END DO END IF END IF - IF (ishell .GT. conv(maxl) .AND. maxl .NE. 0) maxl = maxl - 1 + IF (ishell > conv(maxl) .AND. maxl /= 0) maxl = maxl - 1 call timestart("harmonics") call ylm4(maxl, ka, y) call timestop("harmonics") cdum = 1.0 lm = 0 DO l = 0, maxl - IF (ishell .LE. conv(l)) THEN + IF (ishell <= conv(l)) THEN DO M = -l, l lm = lm + 1 y(lm) = CONJG(y(lm))*cdum*g(l) @@ -2029,7 +2026,7 @@ CONTAINS END DO DO ic2 = 1, atoms%nat DO ic1 = 1, atoms%nat - IF (ic2 .NE. 1 .AND. ic1 .EQ. ic2) CYCLE + IF (ic2 /= 1 .AND. ic1 == ic2) CYCLE cexp = EXP(CMPLX(0.0, 1.0)*2*pi_const*dot_PRODUCT(ki, atoms%taual(:, ic1) - atoms%taual(:, ic2))) DO lm = 1, (maxl + 1)**2 structconst(lm, ic1, ic2, ikpt) = structconst(lm, ic1, ic2, ikpt) + cexp*y(lm) @@ -2057,11 +2054,11 @@ CONTAINS rad = (cell%vol*3/4/pi_const)**(1.0/3) ! Wigner-Seitz radius (rad is recycled) ! Calculate accuracy of Gamma-decomposition - IF (ALL(kpts%bk .EQ. 0)) GOTO 4 + IF (ALL(kpts%bk == 0)) GOTO 4 a = 10.0**30 ! ikpt = index of shortest non-zero k-point DO i = 2, kpts%nkpt rdum = SUM(MATMUL(kpts%bk(:, i), cell%bmat)**2) - IF (rdum .LT. a) THEN + IF (rdum < a) THEN ikpt = i a = rdum END IF @@ -2108,7 +2105,7 @@ CONTAINS REAL, ALLOCATABLE :: rhelp(:) ALLOCATE (ptsh(3, 100000), radsh(100000), stat=ok) - IF (ok .NE. 0) STOP 'getshells: failure allocation ptsh/radsh' + IF (ok /= 0) STOP 'getshells: failure allocation ptsh/radsh' ptsh = 0 radsh = 0 @@ -2122,17 +2119,17 @@ CONTAINS iz = n - ABS(ix) - ABS(iy) 1 r = ix*lat(:, 1) + iy*lat(:, 2) + iz*lat(:, 3) rdum = SUM(r**2) - IF (rdum .LT. rad**2) THEN + IF (rdum < rad**2) THEN found = .TRUE. i = i + 1 - IF (i .GT. SIZE(radsh)) THEN + IF (i > SIZE(radsh)) THEN ALLOCATE (rhelp(SIZE(radsh)), ihelp(3, SIZE(ptsh, 2)), stat=ok) - IF (ok .NE. 0) STOP 'getshells: failure allocation rhelp/ihelp' + IF (ok /= 0) STOP 'getshells: failure allocation rhelp/ihelp' rhelp = radsh ihelp = ptsh DEALLOCATE (radsh, ptsh) ALLOCATE (radsh(SIZE(rhelp) + 100000), ptsh(3, SIZE(ihelp, 2) + 100000), stat=ok) - IF (ok .NE. 0) STOP 'getshells: failure re-allocation ptsh/radsh' + IF (ok /= 0) STOP 'getshells: failure re-allocation ptsh/radsh' radsh(1:SIZE(rhelp)) = rhelp ptsh(:, 1:SIZE(ihelp, 2)) = ihelp DEALLOCATE (rhelp, ihelp) @@ -2140,7 +2137,7 @@ CONTAINS ptsh(:, i) = (/ix, iy, iz/) radsh(i) = SQRT(rdum) END IF - IF (iz .GT. 0) THEN + IF (iz > 0) THEN iz = -iz GOTO 1 END IF @@ -2168,7 +2165,7 @@ CONTAINS ptsh = ptsh(:, pnt) nshell = 1 DO i = 2, nptsh - IF (radsh(i) - radsh(i - 1) .GT. 10.0**-10) nshell = nshell + 1 + IF (radsh(i) - radsh(i - 1) > 10.0**-10) nshell = nshell + 1 END DO IF (lwrite) & @@ -2199,11 +2196,11 @@ CONTAINS DO ikpt = 1, kpts%nkpt igptloop: DO igpt = 1, ngpt(ikpt) igptp = pgpt(igpt, ikpt) - IF (igptp .EQ. 0) STOP 'getnorm: zero pointer (bug?)' + IF (igptp == 0) STOP 'getnorm: zero pointer (bug?)' q = MATMUL(kpts%bk(:, ikpt) + gpt(:, igptp), cell%bmat) qnorm = SQRT(SUM(q**2)) DO j = 1, i - IF (ABS(qnrm(j) - qnorm) .LT. 10.0**-12) THEN + IF (ABS(qnrm(j) - qnorm) < 10.0**-12) THEN pqnrm(igpt, ikpt) = j CYCLE igptloop END IF @@ -2250,23 +2247,23 @@ CONTAINS q1 = qnrm(iqnrm1) q2 = qnrm(iqnrm2) s = atoms%rmt(itype) - IF (q1 .EQ. 0 .AND. q2 .EQ. 0) THEN - IF (l .GT. 0) THEN + IF (q1 == 0 .AND. q2 == 0) THEN + IF (l > 0) THEN sphbessel_integral = 0 ELSE sphbessel_integral = 2*s**5/15 ENDIF - ELSE IF (q1 .EQ. 0 .OR. q2 .EQ. 0) THEN - IF (l .GT. 0) THEN + ELSE IF (q1 == 0 .OR. q2 == 0) THEN + IF (l > 0) THEN sphbessel_integral = 0 - ELSE IF (q1 .EQ. 0) THEN + ELSE IF (q1 == 0) THEN sphbessel_integral = s**3/(3*q2**2)*(q2*s*sphbes0(1, itype, iqnrm2) & + sphbes0(2, itype, iqnrm2)) ELSE sphbessel_integral = s**3/(3*q1**2)*(q1*s*sphbes0(1, itype, iqnrm1) & + sphbes0(2, itype, iqnrm1)) ENDIF - ELSE IF (q1 .EQ. q2) THEN + ELSE IF (q1 == q2) THEN sphbessel_integral = s**3/(2*q1**2)*((2*l + 3)*sphbes0(l + 1, itype, iqnrm1)**2 - & (2*l + 1)*sphbes0(l, itype, iqnrm1)*sphbes0(l + 2, itype, iqnrm1)) ELSE ! We use either if two fromulas that are stable for high and small q1/q2 respectively @@ -2291,8 +2288,8 @@ CONTAINS r1 = ABS(da/a1) r2 = MIN(ABS(db/b1), ABS(dc/c1)) ! Ensure numerical stability. If both formulas are not sufficiently stable, the program stops. - IF (r1 .GT. r2) THEN - IF (r1 .LT. 10.0**-6 .AND. l_warn) THEN + IF (r1 > r2) THEN + IF (r1 < 10.0**-6 .AND. l_warn) THEN WRITE (6, '(A,E12.5,A,E12.5,A)') 'sphbessel_integral: Warning! Formula One possibly unstable. Ratios:', & r1, '(', r2, ')' WRITE (6, '(A,2F15.10,I4)') ' Current qnorms and atom type:', q1, q2, itype @@ -2300,7 +2297,7 @@ CONTAINS END IF sphbessel_integral = s**3/dq*da ELSE - IF (r2 .LT. 10.0**-6 .AND. l_warn) THEN + IF (r2 < 10.0**-6 .AND. l_warn) THEN WRITE (6, '(A,E13.5,A,E13.5,A)') 'sphbessel_integral: Warning! Formula Two possibly unstable. Ratios:', & r2, '(', r1, ')' WRITE (6, '(A,2F15.10,I4)') ' Current qnorms and atom type:', & diff --git a/hybrid/exchange_core.F90 b/hybrid/exchange_core.F90 index 82dbffdfbd53e1dfcb67ff6c6c7b1d50d4c0f0a5..55267c74b13a483747782ba9c1e56c0d722d953a 100644 --- a/hybrid/exchange_core.F90 +++ b/hybrid/exchange_core.F90 @@ -15,749 +15,729 @@ ! ! It is done directly without employing the mixed basis set. - MODULE m_exchange_core CONTAINS - SUBROUTINE exchange_vccv(nk,atoms, hybrid,hybdat, DIMENSION,jsp,lapw,& - maxbands,mnobd,mpi,degenerat,symequivalent,results,& - ex_vv_r,ex_vv_c,l_real) - - - USE m_constants - USE m_util - USE m_wrapper - USE m_types - USE m_io_hybrid - IMPLICIT NONE - - TYPE(t_hybdat),INTENT(IN) :: hybdat - TYPE(t_results),INTENT(INOUT) :: results - TYPE(t_mpi),INTENT(IN) :: mpi - TYPE(t_dimension),INTENT(IN) :: DIMENSION - TYPE(t_hybrid),INTENT(IN) :: hybrid - TYPE(t_atoms),INTENT(IN) :: atoms - TYPE(t_lapw),INTENT(IN) :: lapw - - ! -scalars - - INTEGER,INTENT(IN) :: jsp - INTEGER,INTENT(IN) ::nk ,maxbands, mnobd - ! - arays - - INTEGER,INTENT(IN) :: degenerat(hybrid%ne_eig(nk)) - LOGICAL,INTENT(IN) :: l_real - REAL ,INTENT(INOUT) :: ex_vv_r(:,:,:)!(maxbands,mnobd,nkpti) - COMPLEX ,INTENT(INOUT) :: ex_vv_c(:,:,:)!(maxbands,mnobd,nkpti) - LOGICAL :: symequivalent(COUNT(degenerat .GE. 1), COUNT(degenerat .GE. 1)) - - ! - local scalars - - INTEGER :: iatom,ieq,itype,ic,l,l1,l2, ll,lm ,m1,m2,p1,p2,n,n1,n2,i,j - INTEGER :: iband1,iband2,ndb1,ndb2,ic1,ic2 - INTEGER :: m - - REAL :: time1,time2 - REAL :: rdum - REAL :: sum_offdia - - COMPLEX :: cdum - - ! - local arrays - - INTEGER,ALLOCATABLE :: larr(:),larr2(:) - INTEGER,ALLOCATABLE :: parr(:),parr2(:) - - REAL :: integrand(atoms%jmtd) - REAL :: primf1(atoms%jmtd),primf2(atoms%jmtd) - REAL,ALLOCATABLE :: fprod(:,:),fprod2(:,:) - REAL,ALLOCATABLE :: integral(:,:) - - COMPLEX :: cmt(DIMENSION%neigd,hybrid%maxlmindx,atoms%nat) - COMPLEX :: exchange(hybrid%nbands(nk),hybrid%nbands(nk)) - COMPLEX,ALLOCATABLE :: carr(:,:),carr2(:,:),carr3(:,:) - - LOGICAL :: ldum(hybrid%nbands(nk),hybrid%nbands(nk)) - - WRITE(6,'(A)') new_LINE('n') // new_LINE('n') // '### valence-core-core-valence exchange ###' - WRITE(6,'(A)') new_LINE('n') // ' k-point band exchange (core contribution)' - - ! read in mt wavefunction coefficients from file cmt - CALL read_cmt(cmt,nk) - ALLOCATE ( fprod(atoms%jmtd,5),larr(5),parr(5) ) - - ! generate ldum(nbands(nk),nbands(nk)), which is true if the corresponding matrix entry is non-zero - ic1 = 0 - ldum = .FALSE. - DO iband1 = 1,hybrid%nbands(nk) - ndb1 = degenerat(iband1) - IF( ndb1 .GE. 1 ) THEN - ic1 = ic1 + 1 - ic2 = 0 - DO iband2 = 1,hybrid%nbands(nk) - ndb2 = degenerat(iband2) - IF( ndb2 .GE. 1 ) THEN - ic2 = ic2 + 1 - IF( symequivalent(ic2,ic1) ) THEN - IF( ndb1 .NE. ndb2 ) STOP 'exchange: failure symequivalent' - DO i = 0,ndb1-1 - DO j = 0,ndb2 - 1 - ldum(iband1+i,iband2+j) = .TRUE. - END DO - END DO - - END IF - END IF - END DO - END IF - END DO - - exchange = 0 - iatom = 0 - rdum = 0 - DO itype = 1,atoms%ntype - DO ieq = 1,atoms%neq(itype) - iatom = iatom + 1 - DO l1 = 0,hybdat%lmaxc(itype) - DO p1 = 1,hybdat%nindxc(l1,itype) - - DO l = 0,hybrid%lcutm1(itype) - - ! Define core-valence product functions - - n = 0 - DO l2 = 0,atoms%lmax(itype) - IF(l.LT.ABS(l1-l2).OR.l.GT.l1+l2) CYCLE - - DO p2 = 1,hybrid%nindx(l2,itype) - n = n + 1 - M = SIZE(fprod,2) - IF(n.GT.M) THEN - ALLOCATE ( fprod2(atoms%jmtd,M),larr2(M),parr2(M) ) - fprod2 = fprod ; larr2 = larr ; parr2 = parr - DEALLOCATE ( fprod,larr,parr ) - ALLOCATE ( fprod(atoms%jmtd,M+5),larr(M+5),parr(M+5) ) - fprod(:,:M) = fprod2 - larr(:M) = larr2 - parr(:M) = parr2 - DEALLOCATE ( fprod2,larr2,parr2 ) - END IF - fprod(:atoms%jri(itype),n) = ( hybdat%core1(:atoms%jri(itype),p1,l1,itype) *hybdat%bas1 (:atoms%jri(itype),p2,l2,itype)& - +hybdat%core2(:atoms%jri(itype),p1,l1,itype) *hybdat%bas2 (:atoms%jri(itype),p2,l2,itype) )/ atoms%rmsh(:atoms%jri(itype),itype) - larr(n) = l2 - parr(n) = p2 - END DO - END DO - - ! Evaluate radial integrals (special part of Coulomb matrix : contribution from single MT) - - ALLOCATE ( integral(n,n),carr(n,hybrid%nbands(nk)), carr2(n,lapw%nv(jsp)),carr3(n,lapw%nv(jsp)) ) - - DO i = 1,n - CALL primitivef(primf1,fprod(:,i)*atoms%rmsh(:,itype)**(l+1) ,atoms%rmsh,atoms%dx,atoms%jri,atoms%jmtd, itype,atoms%ntype) - CALL primitivef(primf2,fprod(:atoms%jri(itype),i)/atoms%rmsh(:atoms%jri(itype),itype)**l ,atoms%rmsh,atoms%dx,atoms%jri,atoms%jmtd,-itype,atoms%ntype) ! -itype is to enforce inward integration - - primf1(:atoms%jri(itype)) = primf1(:atoms%jri(itype)) / atoms%rmsh(:atoms%jri(itype),itype)**l - primf2(:atoms%jri(itype)) = primf2(:atoms%jri(itype)) * atoms%rmsh(:atoms%jri(itype),itype)**(l+1) - DO j = 1,n - integrand = fprod(:,j) * (primf1 + primf2) - integral(i,j) = fpi_const/(2*l+1) * intgrf(integrand,atoms%jri,atoms%jmtd,atoms%rmsh,& - atoms%dx,atoms%ntype,itype,hybdat%gridf) - END DO - END DO - - ! Add everything up - - DO m1 = -l1,l1 - DO M = -l,l - m2 = m1 + M - - carr = 0 - ic = 0 - DO n1=1,hybrid%nbands(nk) - - DO i = 1,n - ll = larr(i) - IF(ABS(m2).GT.ll) CYCLE - - lm = SUM((/ ((2*l2+1)*hybrid%nindx(l2,itype),l2=0,ll-1) /)) + (m2+ll)*hybrid%nindx(ll,itype) + parr(i) - - carr(i,n1) = cmt(n1,lm,iatom) * gaunt(l1,ll,l,m1,m2,M,hybdat%maxfac,hybdat%fac,hybdat%sfac) - - END DO - DO n2=1,n1 - IF( ldum(n2,n1) ) THEN - ic =ic + 1 - exchange(n2,n1) = exchange(n2,n1) + dot_PRODUCT( carr(:,n1), MATMUL(integral,carr(:,n2)) ) - END IF - END DO - END DO - END DO - END DO - - DEALLOCATE ( integral,carr,carr2,carr3 ) - - END DO - END DO - END DO - END DO - END DO - - - - IF (l_real) THEN - IF( ANY(ABS(AIMAG(exchange)).GT.10.0**-10) ) THEN - IF ( mpi%irank == 0 ) WRITE(6,'(A)') 'exchangeCore: Warning! Unusually large imaginary component.' - WRITE(*,*) MAXVAL(ABS(AIMAG(exchange))) - STOP 'exchangeCore: Unusually large imaginary component.' - END IF - ENDIF - - ! add the core-valence contribution to the exchange matrix ex_vv - - ! ic = 0 - sum_offdia = 0 - IF (l_real) THEN - DO n1=1,hybrid%nobd(nk) - DO n2=1,hybrid%nbands(nk) - ex_vv_r(n2,n1,nk) = ex_vv_r(n2,n1,nk) - exchange(n1,n2) - IF( n1 /= n2) sum_offdia = sum_offdia + 2*ABS(exchange(n1,n2)) - END DO - END DO - ELSE - DO n1=1,hybrid%nobd(nk) - DO n2=1,hybrid%nbands(nk) - ex_vv_c(n2,n1,nk) = ex_vv_c(n2,n1,nk) - exchange(n1,n2) - IF( n1 /= n2) sum_offdia = sum_offdia + 2*ABS(exchange(n1,n2)) - END DO - END DO - END IF - - DO n1=1,hybrid%nobd(nk) - results%te_hfex%core = results%te_hfex%core - results%w_iks(n1,nk,jsp)*exchange(n1,n1) - END DO - - WRITE(6,'(A,F20.15)') 'sum of the absolut real part of the non diagonal elements',sum_offdia - - - END SUBROUTINE exchange_vccv - - SUBROUTINE exchange_vccv1(nk,atoms, hybrid,hybdat, DIMENSION,jsp, lapw,& - nsymop,nsest,indx_sest,mpi, a_ex,results, mat_ex) - - USE m_constants - USE m_util - USE m_wrapper - USE m_types - USE m_io_hybrid - IMPLICIT NONE - - TYPE(t_hybdat),INTENT(IN) :: hybdat - TYPE(t_results),INTENT(INOUT) :: results - TYPE(t_mpi),INTENT(IN) :: mpi - TYPE(t_dimension),INTENT(IN) :: DIMENSION - TYPE(t_hybrid),INTENT(IN) :: hybrid - TYPE(t_atoms),INTENT(IN) :: atoms - TYPE(t_lapw),INTENT(IN) :: lapw - - ! -scalars - - INTEGER,INTENT(IN) :: jsp - INTEGER,INTENT(IN) :: nk - INTEGER,INTENT(IN) :: nsymop - REAL,INTENT(IN) :: a_ex - ! - arays - - INTEGER,INTENT(IN) :: nsest(hybrid%nbands(nk)),indx_sest(hybrid%nbands(nk),hybrid%nbands(nk)) - - TYPE(t_mat),INTENT(INOUT):: mat_ex - ! - local scalars - - INTEGER :: iatom,ieq,itype,ic,l,l1,l2 - INTEGER :: ll,lm ,m1,m2,p1,p2,n,n1,n2,nn2,i,j - INTEGER :: iband1,iband2,ndb1,ndb2,ic1,ic2 - INTEGER :: m - - REAL :: time1,time2 - REAL :: rdum - REAL :: sum_offdia - - COMPLEX :: cdum - ! - local arrays - - INTEGER,ALLOCATABLE :: larr(:),larr2(:) - INTEGER,ALLOCATABLE :: parr(:),parr2(:) - - REAL :: integrand(atoms%jmtd) - REAL :: primf1(atoms%jmtd),primf2(atoms%jmtd) - REAL,ALLOCATABLE :: fprod(:,:),fprod2(:,:) - REAL,ALLOCATABLE :: integral(:,:) - - COMPLEX :: cmt(DIMENSION%neigd,hybrid%maxlmindx,atoms%nat) - COMPLEX :: exchange(hybrid%nbands(nk),hybrid%nbands(nk)) - COMPLEX,ALLOCATABLE :: carr(:,:),carr2(:,:),carr3(:,:) - - LOGICAL :: ldum(hybrid%nbands(nk),hybrid%nbands(nk)) - - - - ! read in mt wavefunction coefficients from file cmt - - CALL read_cmt(cmt,nk) - - ALLOCATE ( fprod(atoms%jmtd,5),larr(5),parr(5) ) - - exchange = 0 - iatom = 0 - rdum = 0 - DO itype = 1,atoms%ntype - DO ieq = 1,atoms%neq(itype) - iatom = iatom + 1 - DO l1 = 0,hybdat%lmaxc(itype) - DO p1 = 1,hybdat%nindxc(l1,itype) - - DO l = 0,hybrid%lcutm1(itype) - - ! Define core-valence product functions - - n = 0 - DO l2 = 0,atoms%lmax(itype) - IF(l.LT.ABS(l1-l2).OR.l.GT.l1+l2) CYCLE - - DO p2 = 1,hybrid%nindx(l2,itype) - n = n + 1 - M = SIZE(fprod,2) - IF(n.GT.M) THEN - ALLOCATE ( fprod2(atoms%jmtd,M),larr2(M),parr2(M) ) - fprod2 = fprod ; larr2 = larr ; parr2 = parr - DEALLOCATE ( fprod,larr,parr ) - ALLOCATE ( fprod(atoms%jmtd,M+5),larr(M+5),parr(M+5) ) - fprod(:,:M) = fprod2 - larr(:M) = larr2 - parr(:M) = parr2 - DEALLOCATE ( fprod2,larr2,parr2 ) - END IF - fprod(:atoms%jri(itype),n) = ( hybdat%core1(:atoms%jri(itype),p1,l1,itype) *hybdat%bas1 (:atoms%jri(itype),p2,l2,itype) & - +hybdat%core2(:atoms%jri(itype),p1,l1,itype) *hybdat%bas2 (:atoms%jri(itype),p2,l2,itype) )/ atoms%rmsh(:atoms%jri(itype),itype) - larr(n) = l2 - parr(n) = p2 - END DO - END DO - - ! Evaluate radial integrals (special part of Coulomb matrix : contribution from single MT) - - ALLOCATE ( integral(n,n),carr(n,hybrid%nbands(nk)), carr2(n,lapw%nv(jsp)),carr3(n,lapw%nv(jsp)) ) - - DO i = 1,n - CALL primitivef(primf1,fprod(:atoms%jri(itype),i)*atoms%rmsh(:atoms%jri(itype),itype)**(l+1) ,atoms%rmsh,atoms%dx,atoms%jri,atoms%jmtd, itype,atoms%ntype) - CALL primitivef(primf2,fprod(:atoms%jri(itype),i)/atoms%rmsh(:atoms%jri(itype),itype)**l ,atoms%rmsh,atoms%dx,atoms%jri,atoms%jmtd,-itype,atoms%ntype) ! -itype is to enforce inward integration - - primf1(:atoms%jri(itype)) = primf1(:atoms%jri(itype)) / atoms%rmsh(:atoms%jri(itype),itype)**l - primf2(:atoms%jri(itype)) = primf2(:atoms%jri(itype)) * atoms%rmsh(:atoms%jri(itype),itype)**(l+1) - DO j = 1,n - integrand = fprod(:,j) * (primf1 + primf2) - integral(i,j) = fpi_const/(2*l+1) * intgrf(integrand,atoms%jri,atoms%jmtd,atoms%rmsh,& - atoms%dx,atoms%ntype,itype,hybdat%gridf) - END DO - END DO - - ! Add everything up - - DO m1 = -l1,l1 - DO M = -l,l - m2 = m1 + M - - carr = 0 - DO n1=1,hybrid%nbands(nk) - - DO i = 1,n - ll = larr(i) - IF(ABS(m2).GT.ll) CYCLE - - lm = SUM((/ ((2*l2+1)*hybrid%nindx(l2,itype),l2=0,ll-1) /))& - + (m2+ll)*hybrid%nindx(ll,itype) + parr(i) - - carr(i,n1) = cmt(n1,lm,iatom) * gaunt(l1,ll,l,m1,m2,M,hybdat%maxfac,hybdat%fac,hybdat%sfac) - - END DO - DO n2=1,nsest(n1)!n1 - nn2 = indx_sest(n2,n1) - exchange(nn2,n1) = exchange(nn2,n1) + dot_PRODUCT( carr(:,n1), MATMUL(integral,carr(:,nn2)) ) - - END DO - END DO - END DO - END DO - - DEALLOCATE ( integral,carr,carr2,carr3 ) - - END DO - END DO - END DO - END DO - END DO - - - - - IF (mat_ex%l_real) THEN - IF( ANY(ABS(AIMAG(exchange)).GT.10.0**-10) ) THEN - IF (mpi%irank == 0) WRITE(6,'(A)') 'exchangeCore: Warning! Unusually large imaginary component.' - WRITE(*,*) MAXVAL(ABS(AIMAG(exchange))) - STOP 'exchangeCore: Unusually large imaginary component.' - END IF - ENDIF - - DO n1=1,hybrid%nobd(nk) - results%te_hfex%core = results%te_hfex%Core - a_ex * results%w_iks(n1,nk,jsp)*exchange(n1,n1) - END DO - - ! add the core-valence contribution to the exchange matrix mat_ex - ! factor 1/nsymop is needed due to the symmetrization in symmetrizeh - - ic = 0 - sum_offdia = 0 - IF (mat_ex%l_real) THEN - mat_ex%data_r=mat_ex%data_r+exchange/nsymop - ELSE - mat_ex%data_c=mat_ex%data_c+CONJG(exchange)/nsymop - END IF - - END SUBROUTINE exchange_vccv1 - - - SUBROUTINE exchange_cccc(nk,atoms,hybdat, ncstd, sym,kpts,a_ex,mpi, results) - - - USE m_constants - USE m_util - USE m_wrapper - USE m_gaunt - USE m_trafo - USE m_types - USE m_io_hybrid - IMPLICIT NONE - TYPE(t_hybdat),INTENT(IN) :: hybdat - TYPE(t_results),INTENT(INOUT) :: results - TYPE(t_mpi),INTENT(IN) :: mpi - TYPE(t_sym),INTENT(IN) :: sym - TYPE(t_kpts),INTENT(IN) :: kpts - TYPE(t_atoms),INTENT(IN) :: atoms - - ! - scalars - - INTEGER,INTENT(IN) :: nk, ncstd - - REAL ,INTENT(IN) :: a_ex - - ! - arays - - - ! - local scalars - - INTEGER :: itype,ieq,icst,icst1,icst2,iatom,iatom0 - INTEGER :: l1,l2,l,ll,llmax - INTEGER :: m1,m2 ,mm,m - INTEGER :: n1,n2,n - - REAL :: rdum,rdum1 - ! - local arrays - - INTEGER :: point(hybdat%maxindxc,-hybdat%lmaxcd:hybdat%lmaxcd, 0:hybdat%lmaxcd,atoms%nat) - REAL :: rprod(atoms%jmtd),primf1(atoms%jmtd),primf2(atoms%jmtd), integrand(atoms%jmtd) - COMPLEX :: exch(ncstd,ncstd) - - ! IF ( irank == 0 ) THEN - ! WRITE(6,'(//A)') '### core-core-core-core exchange ###' - ! WRITE(6,'(/A)') ' k-point band exchange' - ! END IF - - - ! set up point - icst = 0 - iatom= 0 - DO itype = 1,atoms%ntype - DO ieq = 1,atoms%neq(itype) - iatom = iatom + 1 - DO l = 0,hybdat%lmaxc(itype) - DO M = -l,l - DO n = 1,hybdat%nindxc(l,itype) - icst = icst + 1 - point(n,M,l,iatom) = icst - END DO - END DO - END DO - END DO - END DO - - llmax = 2*hybdat%lmaxcd - exch = 0 - iatom0 = 0 - DO itype = 1,atoms%ntype - - DO l1 = 0,hybdat%lmaxc(itype) ! left core state - DO l2 = 0,hybdat%lmaxc(itype) ! right core state - DO l = 0,hybdat%lmaxc(itype) ! occupied core state - - DO ll = ABS(l1-l),l1+l - IF( ll .LT. ABS(l-l2) .OR. ll .GT. l+l2 ) CYCLE - IF( MOD(l+l1+ll,2) .NE. 0 ) CYCLE - IF( MOD(l+l2+ll,2) .NE. 0 ) CYCLE - - DO m1 = -l1,l1 - m2 = m1 - IF( ABS(m2) .GT. l2 ) CYCLE - DO M = -l,l - mm = M - m1 - IF( ABS(mm) .GT. ll ) CYCLE - rdum = fpi_const/(2*ll+1)*gaunt1(l,ll,l1,M,mm,m1,llmax) *gaunt1(l,ll,l2,M,mm,m2,llmax) - - DO n = 1,hybdat%nindxc(l,itype) - DO n2 = 1,hybdat%nindxc(l2,itype) - rprod(:atoms%jri(itype)) = ( hybdat%core1(:atoms%jri(itype),n,l,itype)*hybdat%core1(:atoms%jri(itype),n2,l2,itype)& - +hybdat%core2(:atoms%jri(itype),n,l,itype)*hybdat%core2(:atoms%jri(itype),n2,l2,itype) ) / atoms%rmsh(:atoms%jri(itype),itype) - - CALL primitivef(primf1,rprod(:)*atoms%rmsh(:,itype)**(ll+1) ,atoms%rmsh,atoms%dx,atoms%jri,atoms%jmtd, itype,atoms%ntype) - CALL primitivef(primf2,rprod(:atoms%jri(itype))/atoms%rmsh(:atoms%jri(itype),itype)**ll ,atoms%rmsh,atoms%dx,atoms%jri,atoms%jmtd,-itype,atoms%ntype) ! -itype is to enforce inward integration - - - primf1 = primf1 / atoms%rmsh(:,itype)**ll - primf2 = primf2 * atoms%rmsh(:,itype)**(ll+1) - - DO n1 = 1,hybdat%nindxc(l1,itype) - - rprod(:atoms%jri(itype)) = ( hybdat%core1(:atoms%jri(itype),n,l,itype)*hybdat%core1(:atoms%jri(itype),n1,l1,itype)& - +hybdat%core2(:atoms%jri(itype),n,l,itype)*hybdat%core2(:atoms%jri(itype),n1,l1,itype) ) / atoms%rmsh(:atoms%jri(itype),itype) - - integrand = rprod * (primf1 + primf2) - - rdum1 = rdum*intgrf(integrand,atoms%jri,atoms%jmtd,& - atoms%rmsh,atoms%dx,atoms%ntype,itype,hybdat%gridf) - - iatom = iatom0 - DO ieq = 1,atoms%neq(itype) - iatom = iatom + 1 - icst1 = point(n1,m1,l1,iatom) - icst2 = point(n2,m2,l2,iatom) - exch(icst1,icst2) = exch(icst1,icst2)+rdum1 - END DO - END DO !n1 - - END DO !n2 - END DO !n - - END DO !M - END DO !m1 - - END DO !ll - - END DO !l - END DO !l2 - END DO !l1 - iatom0 = iatom0 + atoms%neq(itype) - END DO !itype - - IF (sym%invs) THEN - CALL symmetrize(exch,ncstd,ncstd,3,.FALSE., atoms,hybdat%lmaxc,hybdat%lmaxcd,hybdat%nindxc, sym) - IF( ANY( ABS(AIMAG(exch)) .GT. 1E-6 ) ) STOP 'exchange_cccc: exch possesses significant imaginary part' - ENDIF - ! DO icst = 1,ncstd - ! IF ( irank == 0 ) - ! & WRITE(6,'( '' ('',F5.3,'','',F5.3,'','',F5.3,'')'',I4,1X,F12.5)')bkpt,icst,REAL(exch(icst,icst))*(-27.211608) - ! END DO - - - ! add core exchange contributions to the te_hfex - - DO icst1 = 1,ncstd - results%te_hfex%core = results%te_hfex%core - a_ex*kpts%wtkpt(nk)*exch(icst1,icst1) - END DO - - END SUBROUTINE exchange_cccc - - SUBROUTINE exchange_cccv(nk,atoms,hybdat, hybrid,DIMENSION,maxbands,ncstd,& - bkpt,sym,mpi, exch_cv_r, exch_cv_c,l_real ) - - USE m_constants - USE m_util - USE m_wrapper - USE m_gaunt - USE m_trafo - USE m_io_hybrid - USE m_types - IMPLICIT NONE - TYPE(t_hybdat),INTENT(IN) :: hybdat - TYPE(t_mpi),INTENT(IN) :: mpi - TYPE(t_dimension),INTENT(IN) :: DIMENSION - TYPE(t_hybrid),INTENT(IN) :: hybrid - TYPE(t_sym),INTENT(IN) :: sym - TYPE(t_atoms),INTENT(IN) :: atoms - ! - scalars - - INTEGER,INTENT(IN) :: nk ,ncstd - INTEGER,INTENT(IN) :: maxbands - - ! - arays - - REAL ,INTENT(IN) :: bkpt(3) - LOGICAL,INTENT(IN) :: l_real - REAL ,INTENT(INOUT) :: exch_cv_r(:,:,:)!(maxbands,ncstd,nkpti) - COMPLEX,INTENT(INOUT) :: exch_cv_c(:,:,:) !(maxbands,ncstd,nkpti) - ! - local scalars - - INTEGER :: itype,ieq,icst,icst1,icst2,iatom,iatom0 - INTEGER :: iatom1,iband - INTEGER :: l1,l2,l,ll,llmax - INTEGER :: lm2,lmp2 - INTEGER :: m1,m2 ,mm,m - INTEGER :: n1,n2,n,nn - - REAL :: rdum0,rdum1,rdum2,rdum3,rdum4 - COMPLEX :: cdum - COMPLEX,PARAMETER :: img=(0.0,1.0) - ! - local arrays - - INTEGER :: point(hybdat%maxindxc,-hybdat%lmaxcd:hybdat%lmaxcd, 0:hybdat%lmaxcd,atoms%nat) - INTEGER :: lmstart(0:atoms%lmaxd,atoms%ntype) - REAL :: rprod(atoms%jmtd),primf1(atoms%jmtd),primf2(atoms%jmtd) - REAL :: integrand(atoms%jmtd) - COMPLEX :: cexp(atoms%nat) - COMPLEX :: exch(hybrid%nbands(nk),ncstd) - COMPLEX :: cmt(DIMENSION%neigd,hybrid%maxlmindx,atoms%nat),carr(hybrid%nbands(nk)) - - IF ( mpi%irank == 0 ) THEN - WRITE(6,'(//A)') '### core-core-core-valence exchange ###' - WRITE(6,'(/A)') ' k-point band exchange' - END IF - - ! set up point - icst = 0 - iatom= 0 - DO itype = 1,atoms%ntype - DO ieq = 1,atoms%neq(itype) - iatom = iatom + 1 - DO l = 0,hybdat%lmaxc(itype) - DO M = -l,l - DO n = 1,hybdat%nindxc(l,itype) - icst = icst + 1 - point(n,M,l,iatom) = icst - END DO - END DO - END DO - END DO - END DO - - ! lmstart = lm start index for each l-quantum number and atom type (for cmt-coefficients) - DO itype = 1,atoms%ntype - DO l = 0,atoms%lmax(itype) - lmstart(l,itype) = SUM( (/ (hybrid%nindx(ll,itype)*(2*ll+1),ll=0,l-1) /) ) - END DO - END DO - - ! read in cmt coefficient at k-point nk - - CALL read_cmt(cmt,nk) - iatom = 0 - DO itype = 1,atoms%ntype - DO ieq = 1,atoms%neq(itype) - iatom = iatom + 1 - cexp(iatom) = EXP ( img*tpi_const* dot_PRODUCT(bkpt(:),atoms%taual(:,iatom)) ) - END DO - END DO - - cmt = CONJG(cmt) - - llmax = MAX(2*hybdat%lmaxcd,atoms%lmaxd) - - exch = 0 - iatom0 = 0 - DO itype = 1,atoms%ntype - - DO l1 = 0,hybdat%lmaxc(itype) ! left core state - DO l2 = 0,atoms%lmax(itype) ! right valence state - DO l = 0,hybdat%lmaxc(itype) ! occupied core state - - DO ll = ABS(l1-l),l1+l - IF( ll .LT. ABS(l-l2) .OR. ll .GT. l+l2 ) CYCLE - IF( MOD(l+l1+ll,2) .NE. 0 ) CYCLE - IF( MOD(l+l2+ll,2) .NE. 0 ) CYCLE - - ! WRITE(*,*) 'l1,l2,l,ll',l1,l2,l,ll - rdum0 = fpi_const/(2*ll+1) - - DO m1 = -l1,l1 - m2 = m1 - IF( ABS(m2) .GT. l2 ) CYCLE - lm2 = lmstart(l2,itype) +(m2+l2)*hybrid%nindx(l2,itype) - - DO M = -l,l - mm = M - m1 - IF( ABS(M-m1) .GT. ll ) CYCLE - - rdum1 = gaunt1(l,ll,l1,M,mm,m1,llmax)& - *gaunt1(l,ll,l2,M,mm,m1,llmax)*rdum0 - - DO n = 1,hybdat%nindxc(l,itype) - DO n2 = 1,hybrid%nindx(l2,itype) - lmp2 = lm2 + n2 - - rprod(:atoms%jri(itype)) = ( hybdat%core1(:atoms%jri(itype),n,l,itype)*hybdat%bas1(:atoms%jri(itype),n2,l2,itype)& - +hybdat%core2(:atoms%jri(itype),n,l,itype)*hybdat%bas2(:atoms%jri(itype),n2,l2,itype) ) / atoms%rmsh(:atoms%jri(itype),itype) - - CALL primitivef(primf1,rprod(:atoms%jri(itype))*atoms%rmsh(:atoms%jri(itype),itype)**(ll+1) ,atoms%rmsh,atoms%dx,atoms%jri,atoms%jmtd, itype,atoms%ntype) - CALL primitivef(primf2,rprod(:atoms%jri(itype))/atoms%rmsh(:atoms%jri(itype),itype)**ll ,atoms%rmsh,atoms%dx,atoms%jri,atoms%jmtd,-itype,atoms%ntype) ! -itype is to enforce inward integration - - - - - primf1(:atoms%jri(itype)) = primf1(:atoms%jri(itype)) / atoms%rmsh(:atoms%jri(itype),itype)**ll - primf2 = primf2 * atoms%rmsh(:,itype)**(ll+1) - - DO n1 = 1,hybdat%nindxc(l1,itype) - - rprod(:) = ( hybdat%core1(:,n,l,itype)*hybdat%core1(:,n1,l1,itype)& - +hybdat%core2(:,n,l,itype)*hybdat%core2(:,n1,l1,itype) ) / atoms%rmsh(:atoms%jri(itype),itype) - - integrand = rprod * (primf1 + primf2) - - rdum2 = rdum1*intgrf(integrand,atoms%jri,atoms%jmtd, atoms%rmsh,atoms%dx,atoms%ntype,itype,hybdat%gridf) - - iatom = iatom0 - DO ieq = 1,atoms%neq(itype) - iatom = iatom + 1 - icst1 = point(n1,m1,l1,iatom) - cdum = rdum2*cexp(iatom) - DO iband = 1,hybrid%nbands(nk) - - exch(iband,icst1) = exch(iband,icst1) + cdum*cmt(iband,lmp2,iatom) - - END DO - END DO - - END DO !n1 - - END DO !n2 - END DO !n - - END DO !M - END DO !m1 - - END DO !ll - - END DO !l - END DO !l2 - END DO !l1 - iatom0 = iatom0 + atoms%neq(itype) - END DO !itype + SUBROUTINE exchange_vccv(nk, atoms, hybrid, hybdat, DIMENSION, jsp, lapw, & + maxbands, mnobd, mpi, degenerat, symequivalent, results, & + ex_vv_r, ex_vv_c, l_real) + + USE m_constants + USE m_util + USE m_wrapper + USE m_types + USE m_io_hybrid + IMPLICIT NONE + + TYPE(t_hybdat), INTENT(IN) :: hybdat + TYPE(t_results), INTENT(INOUT) :: results + TYPE(t_mpi), INTENT(IN) :: mpi + TYPE(t_dimension), INTENT(IN) :: DIMENSION + TYPE(t_hybrid), INTENT(IN) :: hybrid + TYPE(t_atoms), INTENT(IN) :: atoms + TYPE(t_lapw), INTENT(IN) :: lapw + + ! -scalars - + INTEGER, INTENT(IN) :: jsp + INTEGER, INTENT(IN) ::nk, maxbands, mnobd + ! - arays - + INTEGER, INTENT(IN) :: degenerat(hybrid%ne_eig(nk)) + LOGICAL, INTENT(IN) :: l_real + REAL, INTENT(INOUT) :: ex_vv_r(:, :, :)!(maxbands,mnobd,nkpti) + COMPLEX, INTENT(INOUT) :: ex_vv_c(:, :, :)!(maxbands,mnobd,nkpti) + LOGICAL :: symequivalent(COUNT(degenerat >= 1), COUNT(degenerat >= 1)) + + ! - local scalars - + INTEGER :: iatom, ieq, itype, ic, l, l1, l2, ll, lm, m1, m2, p1, p2, n, n1, n2, i, j + INTEGER :: iband1, iband2, ndb1, ndb2, ic1, ic2 + INTEGER :: m + + REAL :: time1, time2 + REAL :: rdum + REAL :: sum_offdia + + COMPLEX :: cdum + + ! - local arrays - + INTEGER, ALLOCATABLE :: larr(:), larr2(:) + INTEGER, ALLOCATABLE :: parr(:), parr2(:) + + REAL :: integrand(atoms%jmtd) + REAL :: primf1(atoms%jmtd), primf2(atoms%jmtd) + REAL, ALLOCATABLE :: fprod(:, :), fprod2(:, :) + REAL, ALLOCATABLE :: integral(:, :) + + COMPLEX :: cmt(DIMENSION%neigd, hybrid%maxlmindx, atoms%nat) + COMPLEX :: exchange(hybrid%nbands(nk), hybrid%nbands(nk)) + COMPLEX, ALLOCATABLE :: carr(:, :), carr2(:, :), carr3(:, :) + + LOGICAL :: ldum(hybrid%nbands(nk), hybrid%nbands(nk)) + + WRITE (6, '(A)') new_LINE('n')//new_LINE('n')//'### valence-core-core-valence exchange ###' + WRITE (6, '(A)') new_LINE('n')//' k-point band exchange (core contribution)' + + ! read in mt wavefunction coefficients from file cmt + CALL read_cmt(cmt, nk) + ALLOCATE (fprod(atoms%jmtd, 5), larr(5), parr(5)) + + ! generate ldum(nbands(nk),nbands(nk)), which is true if the corresponding matrix entry is non-zero + ic1 = 0 + ldum = .FALSE. + DO iband1 = 1, hybrid%nbands(nk) + ndb1 = degenerat(iband1) + IF (ndb1 >= 1) THEN + ic1 = ic1 + 1 + ic2 = 0 + DO iband2 = 1, hybrid%nbands(nk) + ndb2 = degenerat(iband2) + IF (ndb2 >= 1) THEN + ic2 = ic2 + 1 + IF (symequivalent(ic2, ic1)) THEN + IF (ndb1 /= ndb2) STOP 'exchange: failure symequivalent' + DO i = 0, ndb1 - 1 + DO j = 0, ndb2 - 1 + ldum(iband1 + i, iband2 + j) = .TRUE. + END DO + END DO + + END IF + END IF + END DO + END IF + END DO + + exchange = 0 + iatom = 0 + rdum = 0 + DO itype = 1, atoms%ntype + DO ieq = 1, atoms%neq(itype) + iatom = iatom + 1 + DO l1 = 0, hybdat%lmaxc(itype) + DO p1 = 1, hybdat%nindxc(l1, itype) + + DO l = 0, hybrid%lcutm1(itype) + + ! Define core-valence product functions + + n = 0 + DO l2 = 0, atoms%lmax(itype) + IF (l < ABS(l1 - l2) .OR. l > l1 + l2) CYCLE + + DO p2 = 1, hybrid%nindx(l2, itype) + n = n + 1 + M = SIZE(fprod, 2) + IF (n > M) THEN + ALLOCATE (fprod2(atoms%jmtd, M), larr2(M), parr2(M)) + fprod2 = fprod; larr2 = larr; parr2 = parr + DEALLOCATE (fprod, larr, parr) + ALLOCATE (fprod(atoms%jmtd, M + 5), larr(M + 5), parr(M + 5)) + fprod(:, :M) = fprod2 + larr(:M) = larr2 + parr(:M) = parr2 + DEALLOCATE (fprod2, larr2, parr2) + END IF + fprod(:atoms%jri(itype), n) = (hybdat%core1(:atoms%jri(itype), p1, l1, itype)*hybdat%bas1(:atoms%jri(itype), p2, l2, itype) & + + hybdat%core2(:atoms%jri(itype), p1, l1, itype)*hybdat%bas2(:atoms%jri(itype), p2, l2, itype))/atoms%rmsh(:atoms%jri(itype), itype) + larr(n) = l2 + parr(n) = p2 + END DO + END DO + + ! Evaluate radial integrals (special part of Coulomb matrix : contribution from single MT) + + ALLOCATE (integral(n, n), carr(n, hybrid%nbands(nk)), carr2(n, lapw%nv(jsp)), carr3(n, lapw%nv(jsp))) + + DO i = 1, n + CALL primitivef(primf1, fprod(:, i)*atoms%rmsh(:, itype)**(l + 1), atoms%rmsh, atoms%dx, atoms%jri, atoms%jmtd, itype, atoms%ntype) + CALL primitivef(primf2, fprod(:atoms%jri(itype), i)/atoms%rmsh(:atoms%jri(itype), itype)**l, atoms%rmsh, atoms%dx, atoms%jri, atoms%jmtd, -itype, atoms%ntype) ! -itype is to enforce inward integration + + primf1(:atoms%jri(itype)) = primf1(:atoms%jri(itype))/atoms%rmsh(:atoms%jri(itype), itype)**l + primf2(:atoms%jri(itype)) = primf2(:atoms%jri(itype))*atoms%rmsh(:atoms%jri(itype), itype)**(l + 1) + DO j = 1, n + integrand = fprod(:, j)*(primf1 + primf2) + integral(i, j) = fpi_const/(2*l + 1)*intgrf(integrand, atoms%jri, atoms%jmtd, atoms%rmsh, & + atoms%dx, atoms%ntype, itype, hybdat%gridf) + END DO + END DO + + ! Add everything up + + DO m1 = -l1, l1 + DO M = -l, l + m2 = m1 + M + + carr = 0 + ic = 0 + DO n1 = 1, hybrid%nbands(nk) + + DO i = 1, n + ll = larr(i) + IF (ABS(m2) > ll) CYCLE + + lm = SUM((/((2*l2 + 1)*hybrid%nindx(l2, itype), l2=0, ll - 1)/)) + (m2 + ll)*hybrid%nindx(ll, itype) + parr(i) + + carr(i, n1) = cmt(n1, lm, iatom)*gaunt(l1, ll, l, m1, m2, M, hybdat%maxfac, hybdat%fac, hybdat%sfac) + + END DO + DO n2 = 1, n1 + IF (ldum(n2, n1)) THEN + ic = ic + 1 + exchange(n2, n1) = exchange(n2, n1) + dot_PRODUCT(carr(:, n1), MATMUL(integral, carr(:, n2))) + END IF + END DO + END DO + END DO + END DO + + DEALLOCATE (integral, carr, carr2, carr3) + + END DO + END DO + END DO + END DO + END DO + + IF (l_real) THEN + IF (ANY(ABS(AIMAG(exchange)) > 10.0**-10)) THEN + IF (mpi%irank == 0) WRITE (6, '(A)') 'exchangeCore: Warning! Unusually large imaginary component.' + WRITE (*, *) MAXVAL(ABS(AIMAG(exchange))) + STOP 'exchangeCore: Unusually large imaginary component.' + END IF + ENDIF + + ! add the core-valence contribution to the exchange matrix ex_vv + + ! ic = 0 + sum_offdia = 0 + IF (l_real) THEN + DO n1 = 1, hybrid%nobd(nk) + DO n2 = 1, hybrid%nbands(nk) + ex_vv_r(n2, n1, nk) = ex_vv_r(n2, n1, nk) - exchange(n1, n2) + IF (n1 /= n2) sum_offdia = sum_offdia + 2*ABS(exchange(n1, n2)) + END DO + END DO + ELSE + DO n1 = 1, hybrid%nobd(nk) + DO n2 = 1, hybrid%nbands(nk) + ex_vv_c(n2, n1, nk) = ex_vv_c(n2, n1, nk) - exchange(n1, n2) + IF (n1 /= n2) sum_offdia = sum_offdia + 2*ABS(exchange(n1, n2)) + END DO + END DO + END IF + + DO n1 = 1, hybrid%nobd(nk) + results%te_hfex%core = results%te_hfex%core - results%w_iks(n1, nk, jsp)*exchange(n1, n1) + END DO + + WRITE (6, '(A,F20.15)') 'sum of the absolut real part of the non diagonal elements', sum_offdia + + END SUBROUTINE exchange_vccv + + SUBROUTINE exchange_vccv1(nk, atoms, hybrid, hybdat, DIMENSION, jsp, lapw, & + nsymop, nsest, indx_sest, mpi, a_ex, results, mat_ex) + + USE m_constants + USE m_util + USE m_wrapper + USE m_types + USE m_io_hybrid + IMPLICIT NONE + + TYPE(t_hybdat), INTENT(IN) :: hybdat + TYPE(t_results), INTENT(INOUT) :: results + TYPE(t_mpi), INTENT(IN) :: mpi + TYPE(t_dimension), INTENT(IN) :: DIMENSION + TYPE(t_hybrid), INTENT(IN) :: hybrid + TYPE(t_atoms), INTENT(IN) :: atoms + TYPE(t_lapw), INTENT(IN) :: lapw + + ! -scalars - + INTEGER, INTENT(IN) :: jsp + INTEGER, INTENT(IN) :: nk + INTEGER, INTENT(IN) :: nsymop + REAL, INTENT(IN) :: a_ex + ! - arays - + INTEGER, INTENT(IN) :: nsest(hybrid%nbands(nk)), indx_sest(hybrid%nbands(nk), hybrid%nbands(nk)) + + TYPE(t_mat), INTENT(INOUT):: mat_ex + ! - local scalars - + INTEGER :: iatom, ieq, itype, ic, l, l1, l2 + INTEGER :: ll, lm, m1, m2, p1, p2, n, n1, n2, nn2, i, j + INTEGER :: iband1, iband2, ndb1, ndb2, ic1, ic2 + INTEGER :: m + + REAL :: time1, time2 + REAL :: rdum + REAL :: sum_offdia + + COMPLEX :: cdum + ! - local arrays - + INTEGER, ALLOCATABLE :: larr(:), larr2(:) + INTEGER, ALLOCATABLE :: parr(:), parr2(:) + + REAL :: integrand(atoms%jmtd) + REAL :: primf1(atoms%jmtd), primf2(atoms%jmtd) + REAL, ALLOCATABLE :: fprod(:, :), fprod2(:, :) + REAL, ALLOCATABLE :: integral(:, :) + + COMPLEX :: cmt(DIMENSION%neigd, hybrid%maxlmindx, atoms%nat) + COMPLEX :: exchange(hybrid%nbands(nk), hybrid%nbands(nk)) + COMPLEX, ALLOCATABLE :: carr(:, :), carr2(:, :), carr3(:, :) + + LOGICAL :: ldum(hybrid%nbands(nk), hybrid%nbands(nk)) + + ! read in mt wavefunction coefficients from file cmt + + CALL read_cmt(cmt, nk) + + ALLOCATE (fprod(atoms%jmtd, 5), larr(5), parr(5)) + + exchange = 0 + iatom = 0 + rdum = 0 + DO itype = 1, atoms%ntype + DO ieq = 1, atoms%neq(itype) + iatom = iatom + 1 + DO l1 = 0, hybdat%lmaxc(itype) + DO p1 = 1, hybdat%nindxc(l1, itype) + + DO l = 0, hybrid%lcutm1(itype) + + ! Define core-valence product functions + + n = 0 + DO l2 = 0, atoms%lmax(itype) + IF (l < ABS(l1 - l2) .OR. l > l1 + l2) CYCLE + + DO p2 = 1, hybrid%nindx(l2, itype) + n = n + 1 + M = SIZE(fprod, 2) + IF (n > M) THEN + ALLOCATE (fprod2(atoms%jmtd, M), larr2(M), parr2(M)) + fprod2 = fprod; larr2 = larr; parr2 = parr + DEALLOCATE (fprod, larr, parr) + ALLOCATE (fprod(atoms%jmtd, M + 5), larr(M + 5), parr(M + 5)) + fprod(:, :M) = fprod2 + larr(:M) = larr2 + parr(:M) = parr2 + DEALLOCATE (fprod2, larr2, parr2) + END IF + fprod(:atoms%jri(itype), n) = (hybdat%core1(:atoms%jri(itype), p1, l1, itype)*hybdat%bas1(:atoms%jri(itype), p2, l2, itype) & + + hybdat%core2(:atoms%jri(itype), p1, l1, itype)*hybdat%bas2(:atoms%jri(itype), p2, l2, itype))/atoms%rmsh(:atoms%jri(itype), itype) + larr(n) = l2 + parr(n) = p2 + END DO + END DO + + ! Evaluate radial integrals (special part of Coulomb matrix : contribution from single MT) + + ALLOCATE (integral(n, n), carr(n, hybrid%nbands(nk)), carr2(n, lapw%nv(jsp)), carr3(n, lapw%nv(jsp))) + + DO i = 1, n + CALL primitivef(primf1, fprod(:atoms%jri(itype), i)*atoms%rmsh(:atoms%jri(itype), itype)**(l + 1), atoms%rmsh, atoms%dx, atoms%jri, atoms%jmtd, itype, atoms%ntype) + CALL primitivef(primf2, fprod(:atoms%jri(itype), i)/atoms%rmsh(:atoms%jri(itype), itype)**l, atoms%rmsh, atoms%dx, atoms%jri, atoms%jmtd, -itype, atoms%ntype) ! -itype is to enforce inward integration + + primf1(:atoms%jri(itype)) = primf1(:atoms%jri(itype))/atoms%rmsh(:atoms%jri(itype), itype)**l + primf2(:atoms%jri(itype)) = primf2(:atoms%jri(itype))*atoms%rmsh(:atoms%jri(itype), itype)**(l + 1) + DO j = 1, n + integrand = fprod(:, j)*(primf1 + primf2) + integral(i, j) = fpi_const/(2*l + 1)*intgrf(integrand, atoms%jri, atoms%jmtd, atoms%rmsh, & + atoms%dx, atoms%ntype, itype, hybdat%gridf) + END DO + END DO + + ! Add everything up + + DO m1 = -l1, l1 + DO M = -l, l + m2 = m1 + M + + carr = 0 + DO n1 = 1, hybrid%nbands(nk) + + DO i = 1, n + ll = larr(i) + IF (ABS(m2) > ll) CYCLE + + lm = SUM((/((2*l2 + 1)*hybrid%nindx(l2, itype), l2=0, ll - 1)/)) & + + (m2 + ll)*hybrid%nindx(ll, itype) + parr(i) + + carr(i, n1) = cmt(n1, lm, iatom)*gaunt(l1, ll, l, m1, m2, M, hybdat%maxfac, hybdat%fac, hybdat%sfac) + + END DO + DO n2 = 1, nsest(n1)!n1 + nn2 = indx_sest(n2, n1) + exchange(nn2, n1) = exchange(nn2, n1) + dot_PRODUCT(carr(:, n1), MATMUL(integral, carr(:, nn2))) + + END DO + END DO + END DO + END DO + + DEALLOCATE (integral, carr, carr2, carr3) + + END DO + END DO + END DO + END DO + END DO + + IF (mat_ex%l_real) THEN + IF (ANY(ABS(AIMAG(exchange)) > 10.0**-10)) THEN + IF (mpi%irank == 0) WRITE (6, '(A)') 'exchangeCore: Warning! Unusually large imaginary component.' + WRITE (*, *) MAXVAL(ABS(AIMAG(exchange))) + STOP 'exchangeCore: Unusually large imaginary component.' + END IF + ENDIF + + DO n1 = 1, hybrid%nobd(nk) + results%te_hfex%core = results%te_hfex%Core - a_ex*results%w_iks(n1, nk, jsp)*exchange(n1, n1) + END DO + + ! add the core-valence contribution to the exchange matrix mat_ex + ! factor 1/nsymop is needed due to the symmetrization in symmetrizeh + + ic = 0 + sum_offdia = 0 + IF (mat_ex%l_real) THEN + mat_ex%data_r = mat_ex%data_r + exchange/nsymop + ELSE + mat_ex%data_c = mat_ex%data_c + CONJG(exchange)/nsymop + END IF + + END SUBROUTINE exchange_vccv1 + + SUBROUTINE exchange_cccc(nk, atoms, hybdat, ncstd, sym, kpts, a_ex, mpi, results) + + USE m_constants + USE m_util + USE m_wrapper + USE m_gaunt + USE m_trafo + USE m_types + USE m_io_hybrid + IMPLICIT NONE + TYPE(t_hybdat), INTENT(IN) :: hybdat + TYPE(t_results), INTENT(INOUT) :: results + TYPE(t_mpi), INTENT(IN) :: mpi + TYPE(t_sym), INTENT(IN) :: sym + TYPE(t_kpts), INTENT(IN) :: kpts + TYPE(t_atoms), INTENT(IN) :: atoms + + ! - scalars - + INTEGER, INTENT(IN) :: nk, ncstd + + REAL, INTENT(IN) :: a_ex + + ! - arays - + + ! - local scalars - + INTEGER :: itype, ieq, icst, icst1, icst2, iatom, iatom0 + INTEGER :: l1, l2, l, ll, llmax + INTEGER :: m1, m2, mm, m + INTEGER :: n1, n2, n + + REAL :: rdum, rdum1 + ! - local arrays - + INTEGER :: point(hybdat%maxindxc, -hybdat%lmaxcd:hybdat%lmaxcd, 0:hybdat%lmaxcd, atoms%nat) + REAL :: rprod(atoms%jmtd), primf1(atoms%jmtd), primf2(atoms%jmtd), integrand(atoms%jmtd) + COMPLEX :: exch(ncstd, ncstd) + + ! IF ( irank == 0 ) THEN + ! WRITE(6,'(//A)') '### core-core-core-core exchange ###' + ! WRITE(6,'(/A)') ' k-point band exchange' + ! END IF + + ! set up point + icst = 0 + iatom = 0 + DO itype = 1, atoms%ntype + DO ieq = 1, atoms%neq(itype) + iatom = iatom + 1 + DO l = 0, hybdat%lmaxc(itype) + DO M = -l, l + DO n = 1, hybdat%nindxc(l, itype) + icst = icst + 1 + point(n, M, l, iatom) = icst + END DO + END DO + END DO + END DO + END DO + + llmax = 2*hybdat%lmaxcd + exch = 0 + iatom0 = 0 + DO itype = 1, atoms%ntype + + DO l1 = 0, hybdat%lmaxc(itype) ! left core state + DO l2 = 0, hybdat%lmaxc(itype) ! right core state + DO l = 0, hybdat%lmaxc(itype) ! occupied core state + + DO ll = ABS(l1 - l), l1 + l + IF (ll < ABS(l - l2) .OR. ll > l + l2) CYCLE + IF (MOD(l + l1 + ll, 2) /= 0) CYCLE + IF (MOD(l + l2 + ll, 2) /= 0) CYCLE + + DO m1 = -l1, l1 + m2 = m1 + IF (ABS(m2) > l2) CYCLE + DO M = -l, l + mm = M - m1 + IF (ABS(mm) > ll) CYCLE + rdum = fpi_const/(2*ll + 1)*gaunt1(l, ll, l1, M, mm, m1, llmax)*gaunt1(l, ll, l2, M, mm, m2, llmax) + + DO n = 1, hybdat%nindxc(l, itype) + DO n2 = 1, hybdat%nindxc(l2, itype) + rprod(:atoms%jri(itype)) = (hybdat%core1(:atoms%jri(itype), n, l, itype)*hybdat%core1(:atoms%jri(itype), n2, l2, itype) & + + hybdat%core2(:atoms%jri(itype), n, l, itype)*hybdat%core2(:atoms%jri(itype), n2, l2, itype))/atoms%rmsh(:atoms%jri(itype), itype) + + CALL primitivef(primf1, rprod(:)*atoms%rmsh(:, itype)**(ll + 1), atoms%rmsh, atoms%dx, atoms%jri, atoms%jmtd, itype, atoms%ntype) + CALL primitivef(primf2, rprod(:atoms%jri(itype))/atoms%rmsh(:atoms%jri(itype), itype)**ll, atoms%rmsh, atoms%dx, atoms%jri, atoms%jmtd, -itype, atoms%ntype) ! -itype is to enforce inward integration + + primf1 = primf1/atoms%rmsh(:, itype)**ll + primf2 = primf2*atoms%rmsh(:, itype)**(ll + 1) + + DO n1 = 1, hybdat%nindxc(l1, itype) + + rprod(:atoms%jri(itype)) = (hybdat%core1(:atoms%jri(itype), n, l, itype)*hybdat%core1(:atoms%jri(itype), n1, l1, itype) & + + hybdat%core2(:atoms%jri(itype), n, l, itype)*hybdat%core2(:atoms%jri(itype), n1, l1, itype))/atoms%rmsh(:atoms%jri(itype), itype) + + integrand = rprod*(primf1 + primf2) + + rdum1 = rdum*intgrf(integrand, atoms%jri, atoms%jmtd, & + atoms%rmsh, atoms%dx, atoms%ntype, itype, hybdat%gridf) + + iatom = iatom0 + DO ieq = 1, atoms%neq(itype) + iatom = iatom + 1 + icst1 = point(n1, m1, l1, iatom) + icst2 = point(n2, m2, l2, iatom) + exch(icst1, icst2) = exch(icst1, icst2) + rdum1 + END DO + END DO !n1 + + END DO !n2 + END DO !n + + END DO !M + END DO !m1 + + END DO !ll + + END DO !l + END DO !l2 + END DO !l1 + iatom0 = iatom0 + atoms%neq(itype) + END DO !itype + + IF (sym%invs) THEN + CALL symmetrize(exch, ncstd, ncstd, 3, .FALSE., atoms, hybdat%lmaxc, hybdat%lmaxcd, hybdat%nindxc, sym) + IF (ANY(ABS(AIMAG(exch)) > 1E-6)) STOP 'exchange_cccc: exch possesses significant imaginary part' + ENDIF + ! DO icst = 1,ncstd + ! IF ( irank == 0 ) + ! & WRITE(6,'( '' ('',F5.3,'','',F5.3,'','',F5.3,'')'',I4,1X,F12.5)')bkpt,icst,REAL(exch(icst,icst))*(-27.211608) + ! END DO + + ! add core exchange contributions to the te_hfex + + DO icst1 = 1, ncstd + results%te_hfex%core = results%te_hfex%core - a_ex*kpts%wtkpt(nk)*exch(icst1, icst1) + END DO + + END SUBROUTINE exchange_cccc + + SUBROUTINE exchange_cccv(nk, atoms, hybdat, hybrid, DIMENSION, maxbands, ncstd, & + bkpt, sym, mpi, exch_cv_r, exch_cv_c, l_real) + + USE m_constants + USE m_util + USE m_wrapper + USE m_gaunt + USE m_trafo + USE m_io_hybrid + USE m_types + IMPLICIT NONE + TYPE(t_hybdat), INTENT(IN) :: hybdat + TYPE(t_mpi), INTENT(IN) :: mpi + TYPE(t_dimension), INTENT(IN) :: DIMENSION + TYPE(t_hybrid), INTENT(IN) :: hybrid + TYPE(t_sym), INTENT(IN) :: sym + TYPE(t_atoms), INTENT(IN) :: atoms + ! - scalars - + INTEGER, INTENT(IN) :: nk, ncstd + INTEGER, INTENT(IN) :: maxbands + + ! - arays - + REAL, INTENT(IN) :: bkpt(3) + LOGICAL, INTENT(IN) :: l_real + REAL, INTENT(INOUT) :: exch_cv_r(:, :, :)!(maxbands,ncstd,nkpti) + COMPLEX, INTENT(INOUT) :: exch_cv_c(:, :, :) !(maxbands,ncstd,nkpti) + ! - local scalars - + INTEGER :: itype, ieq, icst, icst1, icst2, iatom, iatom0 + INTEGER :: iatom1, iband + INTEGER :: l1, l2, l, ll, llmax + INTEGER :: lm2, lmp2 + INTEGER :: m1, m2, mm, m + INTEGER :: n1, n2, n, nn + + REAL :: rdum0, rdum1, rdum2, rdum3, rdum4 + COMPLEX :: cdum + COMPLEX, PARAMETER :: img = (0.0, 1.0) + ! - local arrays - + INTEGER :: point(hybdat%maxindxc, -hybdat%lmaxcd:hybdat%lmaxcd, 0:hybdat%lmaxcd, atoms%nat) + INTEGER :: lmstart(0:atoms%lmaxd, atoms%ntype) + REAL :: rprod(atoms%jmtd), primf1(atoms%jmtd), primf2(atoms%jmtd) + REAL :: integrand(atoms%jmtd) + COMPLEX :: cexp(atoms%nat) + COMPLEX :: exch(hybrid%nbands(nk), ncstd) + COMPLEX :: cmt(DIMENSION%neigd, hybrid%maxlmindx, atoms%nat), carr(hybrid%nbands(nk)) + + IF (mpi%irank == 0) THEN + WRITE (6, '(//A)') '### core-core-core-valence exchange ###' + WRITE (6, '(/A)') ' k-point band exchange' + END IF + + ! set up point + icst = 0 + iatom = 0 + DO itype = 1, atoms%ntype + DO ieq = 1, atoms%neq(itype) + iatom = iatom + 1 + DO l = 0, hybdat%lmaxc(itype) + DO M = -l, l + DO n = 1, hybdat%nindxc(l, itype) + icst = icst + 1 + point(n, M, l, iatom) = icst + END DO + END DO + END DO + END DO + END DO + + ! lmstart = lm start index for each l-quantum number and atom type (for cmt-coefficients) + DO itype = 1, atoms%ntype + DO l = 0, atoms%lmax(itype) + lmstart(l, itype) = SUM((/(hybrid%nindx(ll, itype)*(2*ll + 1), ll=0, l - 1)/)) + END DO + END DO + + ! read in cmt coefficient at k-point nk + + CALL read_cmt(cmt, nk) + iatom = 0 + DO itype = 1, atoms%ntype + DO ieq = 1, atoms%neq(itype) + iatom = iatom + 1 + cexp(iatom) = EXP(img*tpi_const*dot_PRODUCT(bkpt(:), atoms%taual(:, iatom))) + END DO + END DO + + cmt = CONJG(cmt) + + llmax = MAX(2*hybdat%lmaxcd, atoms%lmaxd) + + exch = 0 + iatom0 = 0 + DO itype = 1, atoms%ntype + + DO l1 = 0, hybdat%lmaxc(itype) ! left core state + DO l2 = 0, atoms%lmax(itype) ! right valence state + DO l = 0, hybdat%lmaxc(itype) ! occupied core state + + DO ll = ABS(l1 - l), l1 + l + IF (ll < ABS(l - l2) .OR. ll > l + l2) CYCLE + IF (MOD(l + l1 + ll, 2) /= 0) CYCLE + IF (MOD(l + l2 + ll, 2) /= 0) CYCLE + + ! WRITE(*,*) 'l1,l2,l,ll',l1,l2,l,ll + rdum0 = fpi_const/(2*ll + 1) + + DO m1 = -l1, l1 + m2 = m1 + IF (ABS(m2) > l2) CYCLE + lm2 = lmstart(l2, itype) + (m2 + l2)*hybrid%nindx(l2, itype) + + DO M = -l, l + mm = M - m1 + IF (ABS(M - m1) > ll) CYCLE + + rdum1 = gaunt1(l, ll, l1, M, mm, m1, llmax) & + *gaunt1(l, ll, l2, M, mm, m1, llmax)*rdum0 + + DO n = 1, hybdat%nindxc(l, itype) + DO n2 = 1, hybrid%nindx(l2, itype) + lmp2 = lm2 + n2 + + rprod(:atoms%jri(itype)) = (hybdat%core1(:atoms%jri(itype), n, l, itype)*hybdat%bas1(:atoms%jri(itype), n2, l2, itype) & + + hybdat%core2(:atoms%jri(itype), n, l, itype)*hybdat%bas2(:atoms%jri(itype), n2, l2, itype))/atoms%rmsh(:atoms%jri(itype), itype) + + CALL primitivef(primf1, rprod(:atoms%jri(itype))*atoms%rmsh(:atoms%jri(itype), itype)**(ll + 1), atoms%rmsh, atoms%dx, atoms%jri, atoms%jmtd, itype, atoms%ntype) + CALL primitivef(primf2, rprod(:atoms%jri(itype))/atoms%rmsh(:atoms%jri(itype), itype)**ll, atoms%rmsh, atoms%dx, atoms%jri, atoms%jmtd, -itype, atoms%ntype) ! -itype is to enforce inward integration + + primf1(:atoms%jri(itype)) = primf1(:atoms%jri(itype))/atoms%rmsh(:atoms%jri(itype), itype)**ll + primf2 = primf2*atoms%rmsh(:, itype)**(ll + 1) + + DO n1 = 1, hybdat%nindxc(l1, itype) + + rprod(:) = (hybdat%core1(:, n, l, itype)*hybdat%core1(:, n1, l1, itype) & + + hybdat%core2(:, n, l, itype)*hybdat%core2(:, n1, l1, itype))/atoms%rmsh(:atoms%jri(itype), itype) + + integrand = rprod*(primf1 + primf2) + + rdum2 = rdum1*intgrf(integrand, atoms%jri, atoms%jmtd, atoms%rmsh, atoms%dx, atoms%ntype, itype, hybdat%gridf) + + iatom = iatom0 + DO ieq = 1, atoms%neq(itype) + iatom = iatom + 1 + icst1 = point(n1, m1, l1, iatom) + cdum = rdum2*cexp(iatom) + DO iband = 1, hybrid%nbands(nk) + + exch(iband, icst1) = exch(iband, icst1) + cdum*cmt(iband, lmp2, iatom) + + END DO + END DO + + END DO !n1 + + END DO !n2 + END DO !n + + END DO !M + END DO !m1 + END DO !ll - IF (l_real) THEN - !symmetrize core-wavefunctions such that phi(-r) = phi(r)* - CALL symmetrize( exch,hybrid%nbands(nk),ncstd,2,.FALSE., atoms,hybdat%lmaxc,hybdat%lmaxcd,hybdat%nindxc, sym) + END DO !l + END DO !l2 + END DO !l1 + iatom0 = iatom0 + atoms%neq(itype) + END DO !itype - IF( ANY( ABS(AIMAG(exch)) .GT. 1E-6 ) ) STOP 'exchange_cccv: exch possesses significant imaginary part' - ENDIF + IF (l_real) THEN + !symmetrize core-wavefunctions such that phi(-r) = phi(r)* + CALL symmetrize(exch, hybrid%nbands(nk), ncstd, 2, .FALSE., atoms, hybdat%lmaxc, hybdat%lmaxcd, hybdat%nindxc, sym) - IF (l_real) THEN - DO icst = 1,ncstd - DO iband = 1,hybrid%nbands(nk) - exch_cv_r(iband,icst,nk) = exch_cv_r(iband,icst,nk) - exch(iband,icst) - END DO - END DO - ELSE - DO icst = 1,ncstd - DO iband = 1,hybrid%nbands(nk) - exch_cv_c(iband,icst,nk) = exch_cv_c(iband,icst,nk) - exch(iband,icst) - END DO - END DO - END IF + IF (ANY(ABS(AIMAG(exch)) > 1E-6)) STOP 'exchange_cccv: exch possesses significant imaginary part' + ENDIF - END SUBROUTINE exchange_cccv + IF (l_real) THEN + DO icst = 1, ncstd + DO iband = 1, hybrid%nbands(nk) + exch_cv_r(iband, icst, nk) = exch_cv_r(iband, icst, nk) - exch(iband, icst) + END DO + END DO + ELSE + DO icst = 1, ncstd + DO iband = 1, hybrid%nbands(nk) + exch_cv_c(iband, icst, nk) = exch_cv_c(iband, icst, nk) - exch(iband, icst) + END DO + END DO + END IF + END SUBROUTINE exchange_cccv END MODULE m_exchange_core diff --git a/hybrid/exchange_val_hf.F90 b/hybrid/exchange_val_hf.F90 index 2855b9b5aa7c943a4ebb125b4603528a4d827d11..b8d6050a904d1c546272b4b6a2ad96fcb7624f21 100644 --- a/hybrid/exchange_val_hf.F90 +++ b/hybrid/exchange_val_hf.F90 @@ -4,7 +4,7 @@ ! of the MIT license as expressed in the LICENSE file in more detail. !-------------------------------------------------------------------------------- -! Calculates the HF exchange term +! Calculates the HF exchange term ! ! s s* s s* ! phi (r) phi (r) phi (r') phi (r') @@ -16,7 +16,7 @@ ! = - SUM SUM v < phi | phi M > < M phi | phi > ! k,n' I,J k,IJ n'k+q n_1k q,I q,J n_2k n'k+q ! -! for the different combinations of n_1 and n_2 and where n' runs only over the valence states. +! for the different combinations of n_1 and n_2 and where n' runs only over the valence states. ! ( n_1,n_2: valence-valence, core-core,core-valence ) ! ! @@ -51,315 +51,313 @@ MODULE m_exchange_valence_hf - LOGICAL,PARAMETER:: zero_order=.false.,ibs_corr=.false. - INTEGER,PARAMETER:: maxmem=600 + LOGICAL, PARAMETER:: zero_order = .false., ibs_corr = .false. + INTEGER, PARAMETER:: maxmem = 600 CONTAINS -SUBROUTINE 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,mat_ex) - - USE m_types - USE m_wrapper - USE m_constants - USE m_trafo - USE m_wavefproducts - USE m_olap - USE m_spmvec - USE m_hsefunctional ,ONLY: dynamic_hse_adjustment + SUBROUTINE 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, mat_ex) + + USE m_types + USE m_wrapper + USE m_constants + USE m_trafo + USE m_wavefproducts + USE m_olap + USE m_spmvec + USE m_hsefunctional, ONLY: dynamic_hse_adjustment #if defined(CPP_MPI)&&defined(CPP_NEVER) - USE m_mpi_work_dist - USE m_mpi_tags + USE m_mpi_work_dist + USE m_mpi_tags #endif - USE m_io_hybrid - USE m_kp_perturbation - - IMPLICIT NONE - - TYPE(t_results), INTENT(IN) :: results - TYPE(t_xcpot_inbuild), INTENT(IN) :: xcpot - TYPE(t_mpi), INTENT(IN) :: mpi - TYPE(t_dimension), INTENT(IN) :: dimension - TYPE(t_hybrid), INTENT(INOUT) :: hybrid - TYPE(t_input), INTENT(IN) :: input - TYPE(t_noco), INTENT(IN) :: noco - TYPE(t_sym), INTENT(IN) :: sym - TYPE(t_cell), INTENT(IN) :: cell - TYPE(t_kpts), INTENT(IN) :: kpts - TYPE(t_atoms), INTENT(IN) :: atoms - TYPE(t_lapw), INTENT(IN) :: lapw - TYPE(t_mat), INTENT(INOUT) :: mat_ex - TYPE(t_hybdat), INTENT(INOUT) :: hybdat - - ! scalars - INTEGER, INTENT(IN) :: it - INTEGER, INTENT(IN) :: jsp - INTEGER, INTENT(IN) :: nk,nkpt_EIBZ - INTEGER, INTENT(IN) :: mnobd - - ! arrays - INTEGER, INTENT(IN) :: n_q(nkpt_EIBZ) - - INTEGER, INTENT(IN) :: parent(kpts%nkptf) - INTEGER, INTENT(IN) :: pointer_EIBZ(nkpt_EIBZ) - INTEGER, INTENT(IN) :: nsest(hybrid%nbands(nk)) - INTEGER, INTENT(IN) :: indx_sest(hybrid%nbands(nk),hybrid%nbands(nk)) - - - REAL, INTENT(IN) :: eig_irr(dimension%neigd,kpts%nkpt) - REAL, INTENT(IN) :: wl_iks(dimension%neigd,kpts%nkptf) - - ! local scalars - INTEGER :: iband,iband1,ibando,ikpt,ikpt0 - INTEGER :: i,ic,ix,iy,iz - INTEGER :: irecl_coulomb,irecl_coulomb1 - INTEGER :: j - INTEGER :: m1,m2 - INTEGER :: n,n1,n2,nn,nn2 - INTEGER :: nkqpt - INTEGER :: npot - INTEGER :: ok - INTEGER :: psize - REAL :: rdum - REAL :: k0 - - REAL , SAVE :: divergence - - COMPLEX :: cdum,cdum1,cdum2 - COMPLEX :: exch0 - - LOGICAL, SAVE :: initialize = .true. - - ! local arrays - INTEGER :: kcorner(3,8) = reshape((/ 0,0,0, 1,0,0, 0,1,0, 0,0,1, 1,1,0, 1,0,1, 0,1,1, 1,1,1 /), (/3,8/) ) - COMPLEX :: exchcorrect(kpts%nkptf) - COMPLEX :: dcprod(hybrid%nbands(nk),hybrid%nbands(nk),3) - COMPLEX :: exch_vv(hybrid%nbands(nk),hybrid%nbands(nk)) - COMPLEX :: hessian(3,3) - COMPLEX :: proj_ibsc(3,mnobd,hybrid%nbands(nk)) - COMPLEX :: olap_ibsc(3,3,mnobd,mnobd) - REAL :: carr1_v_r(hybrid%maxbasm1),carr1_c_r(hybrid%maxbasm1) - COMPLEX :: carr1_v_c(hybrid%maxbasm1),carr1_c_c(hybrid%maxbasm1) - COMPLEX, ALLOCATABLE :: phase_vv(:,:) - REAL, ALLOCATABLE :: cprod_vv_r(:,:,:),cprod_cv_r(:,:,:), carr3_vv_r(:,:,:),carr3_cv_r(:,:,:) - COMPLEX, ALLOCATABLE :: cprod_vv_c(:,:,:),cprod_cv_c(:,:,:), carr3_vv_c(:,:,:),carr3_cv_c(:,:,:) - + USE m_io_hybrid + USE m_kp_perturbation + + IMPLICIT NONE + + TYPE(t_results), INTENT(IN) :: results + TYPE(t_xcpot_inbuild), INTENT(IN) :: xcpot + TYPE(t_mpi), INTENT(IN) :: mpi + TYPE(t_dimension), INTENT(IN) :: dimension + TYPE(t_hybrid), INTENT(INOUT) :: hybrid + TYPE(t_input), INTENT(IN) :: input + TYPE(t_noco), INTENT(IN) :: noco + TYPE(t_sym), INTENT(IN) :: sym + TYPE(t_cell), INTENT(IN) :: cell + TYPE(t_kpts), INTENT(IN) :: kpts + TYPE(t_atoms), INTENT(IN) :: atoms + TYPE(t_lapw), INTENT(IN) :: lapw + TYPE(t_mat), INTENT(INOUT) :: mat_ex + TYPE(t_hybdat), INTENT(INOUT) :: hybdat + + ! scalars + INTEGER, INTENT(IN) :: it + INTEGER, INTENT(IN) :: jsp + INTEGER, INTENT(IN) :: nk, nkpt_EIBZ + INTEGER, INTENT(IN) :: mnobd + + ! arrays + INTEGER, INTENT(IN) :: n_q(nkpt_EIBZ) + + INTEGER, INTENT(IN) :: parent(kpts%nkptf) + INTEGER, INTENT(IN) :: pointer_EIBZ(nkpt_EIBZ) + INTEGER, INTENT(IN) :: nsest(hybrid%nbands(nk)) + INTEGER, INTENT(IN) :: indx_sest(hybrid%nbands(nk), hybrid%nbands(nk)) + + REAL, INTENT(IN) :: eig_irr(dimension%neigd, kpts%nkpt) + REAL, INTENT(IN) :: wl_iks(dimension%neigd, kpts%nkptf) + + ! local scalars + INTEGER :: iband, iband1, ibando, ikpt, ikpt0 + INTEGER :: i, ic, ix, iy, iz + INTEGER :: irecl_coulomb, irecl_coulomb1 + INTEGER :: j + INTEGER :: m1, m2 + INTEGER :: n, n1, n2, nn, nn2 + INTEGER :: nkqpt + INTEGER :: npot + INTEGER :: ok + INTEGER :: psize + REAL :: rdum + REAL :: k0 + + REAL, SAVE :: divergence + + COMPLEX :: cdum, cdum1, cdum2 + COMPLEX :: exch0 + + LOGICAL, SAVE :: initialize = .true. + + ! local arrays + INTEGER :: kcorner(3, 8) = reshape((/0, 0, 0, 1, 0, 0, 0, 1, 0, 0, 0, 1, 1, 1, 0, 1, 0, 1, 0, 1, 1, 1, 1, 1/), (/3, 8/)) + COMPLEX :: exchcorrect(kpts%nkptf) + COMPLEX :: dcprod(hybrid%nbands(nk), hybrid%nbands(nk), 3) + COMPLEX :: exch_vv(hybrid%nbands(nk), hybrid%nbands(nk)) + COMPLEX :: hessian(3, 3) + COMPLEX :: proj_ibsc(3, mnobd, hybrid%nbands(nk)) + COMPLEX :: olap_ibsc(3, 3, mnobd, mnobd) + REAL :: carr1_v_r(hybrid%maxbasm1), carr1_c_r(hybrid%maxbasm1) + COMPLEX :: carr1_v_c(hybrid%maxbasm1), carr1_c_c(hybrid%maxbasm1) + COMPLEX, ALLOCATABLE :: phase_vv(:, :) + REAL, ALLOCATABLE :: cprod_vv_r(:, :, :), cprod_cv_r(:, :, :), carr3_vv_r(:, :, :), carr3_cv_r(:, :, :) + COMPLEX, ALLOCATABLE :: cprod_vv_c(:, :, :), cprod_cv_c(:, :, :), carr3_vv_c(:, :, :), carr3_cv_c(:, :, :) #if defined(CPP_MPI)&&defined(CPP_NEVER) - COMPLEX :: buf_vv(hybrid%nbands(nk),nbands(nk)) + COMPLEX :: buf_vv(hybrid%nbands(nk), nbands(nk)) #endif #if ( !defined CPP_NOSPMVEC && !defined CPP_IRAPPROX ) - REAL :: coulomb_mt1(hybrid%maxindxm1-1,hybrid%maxindxm1-1, 0:hybrid%maxlcutm1,atoms%ntype) - REAL :: coulomb_mt2_r(hybrid%maxindxm1-1,-hybrid%maxlcutm1:hybrid%maxlcutm1,0:hybrid%maxlcutm1+1,atoms%nat) - REAL :: coulomb_mt3_r(hybrid%maxindxm1-1,atoms%nat,atoms%nat) - COMPLEX :: coulomb_mt2_c(hybrid%maxindxm1-1,-hybrid%maxlcutm1:hybrid%maxlcutm1,0:hybrid%maxlcutm1+1,atoms%nat) - COMPLEX :: coulomb_mt3_c(hybrid%maxindxm1-1,atoms%nat,atoms%nat) + REAL :: coulomb_mt1(hybrid%maxindxm1 - 1, hybrid%maxindxm1 - 1, 0:hybrid%maxlcutm1, atoms%ntype) + REAL :: coulomb_mt2_r(hybrid%maxindxm1 - 1, -hybrid%maxlcutm1:hybrid%maxlcutm1, 0:hybrid%maxlcutm1 + 1, atoms%nat) + REAL :: coulomb_mt3_r(hybrid%maxindxm1 - 1, atoms%nat, atoms%nat) + COMPLEX :: coulomb_mt2_c(hybrid%maxindxm1 - 1, -hybrid%maxlcutm1:hybrid%maxlcutm1, 0:hybrid%maxlcutm1 + 1, atoms%nat) + COMPLEX :: coulomb_mt3_c(hybrid%maxindxm1 - 1, atoms%nat, atoms%nat) #else - REAL :: coulomb_r(hybrid%maxbasm1*(hybrid%maxbasm1+1)/2) - COMPLEX :: coulomb_c(hybrid%maxbasm1*(hybrid%maxbasm1+1)/2) + REAL :: coulomb_r(hybrid%maxbasm1*(hybrid%maxbasm1 + 1)/2) + COMPLEX :: coulomb_c(hybrid%maxbasm1*(hybrid%maxbasm1 + 1)/2) #endif #ifdef CPP_IRCOULOMBAPPROX - REAL :: coulomb_mtir_r((hybrid%maxlcutm1+1)**2*atoms%nat,& - (hybrid%maxlcutm1+1)**2*atoms%nat+maxval(hybrid%ngptm)) + REAL :: coulomb_mtir_r((hybrid%maxlcutm1 + 1)**2*atoms%nat, & + (hybrid%maxlcutm1 + 1)**2*atoms%nat + maxval(hybrid%ngptm)) #else - REAL :: coulomb_mtir_r(((hybrid%maxlcutm1+1)**2*atoms%nat +maxval(hybrid%ngptm)) *& - ((hybrid%maxlcutm1+1)**2*atoms%nat +maxval(hybrid%ngptm)+1)/2) + REAL :: coulomb_mtir_r(((hybrid%maxlcutm1 + 1)**2*atoms%nat + maxval(hybrid%ngptm))* & + ((hybrid%maxlcutm1 + 1)**2*atoms%nat + maxval(hybrid%ngptm) + 1)/2) #endif #ifdef CPP_IRCOULOMBAPPROX - COMPLEX :: coulomb_mtir_c((hybrid%maxlcutm1+1)**2*atoms%nat,& - (hybrid%maxlcutm1+1)**2*atoms%nat+maxval(hybrid%ngptm)) + COMPLEX :: coulomb_mtir_c((hybrid%maxlcutm1 + 1)**2*atoms%nat, & + (hybrid%maxlcutm1 + 1)**2*atoms%nat + maxval(hybrid%ngptm)) #else - COMPLEX :: coulomb_mtir_c(((hybrid%maxlcutm1+1)**2*atoms%nat +maxval(hybrid%ngptm)) *& - ((hybrid%maxlcutm1+1)**2*atoms%nat +maxval(hybrid%ngptm)+1)/2) + COMPLEX :: coulomb_mtir_c(((hybrid%maxlcutm1 + 1)**2*atoms%nat + maxval(hybrid%ngptm))* & + ((hybrid%maxlcutm1 + 1)**2*atoms%nat + maxval(hybrid%ngptm) + 1)/2) #endif - LOGICAL :: occup(dimension%neigd) + LOGICAL :: occup(dimension%neigd) #if defined(CPP_MPI)&&defined(CPP_NEVER) - INCLUDE "mpif.h" - INTEGER :: ierr,ierr2,length,rank - CHARACTER(LEN=MPI_MAX_ERROR_STRING) :: errmsg + INCLUDE "mpif.h" + INTEGER :: ierr, ierr2, length, rank + CHARACTER(LEN=MPI_MAX_ERROR_STRING) :: errmsg #endif - CALL timestart("valence exchange calculation") - - IF(initialize) THEN !it .eq. 1 .and. nk .eq. 1) THEN - call calc_divergence(cell,kpts,divergence) - PRINT *,"Divergence:",divergence - initialize = .false. - END IF - - ! calculate valence-valence-valence-valence, core-valence-valence-valence - ! and core-valence-valence-core exchange at current k-point - ! the sum over the inner occupied valence states is restricted to the EIBZ(k) - ! the contribution of the Gamma-point is treated separately (see below) - - ! determine package size loop over the occupied bands - rdum = hybrid%maxbasm1*hybrid%nbands(nk)*4/1048576. - psize = 1 - DO iband = mnobd,1,-1 - ! ensure that the packages have equal size - IF(modulo(mnobd,iband).eq.0) THEN - ! choose packet size such that cprod is smaller than memory threshold - IF(rdum*iband.le.maxmem) THEN - psize = iband - EXIT + CALL timestart("valence exchange calculation") + + IF (initialize) THEN !it .eq. 1 .and. nk .eq. 1) THEN + call calc_divergence(cell, kpts, divergence) + PRINT *, "Divergence:", divergence + initialize = .false. + END IF + + ! calculate valence-valence-valence-valence, core-valence-valence-valence + ! and core-valence-valence-core exchange at current k-point + ! the sum over the inner occupied valence states is restricted to the EIBZ(k) + ! the contribution of the Gamma-point is treated separately (see below) + + ! determine package size loop over the occupied bands + rdum = hybrid%maxbasm1*hybrid%nbands(nk)*4/1048576. + psize = 1 + DO iband = mnobd, 1, -1 + ! ensure that the packages have equal size + IF (modulo(mnobd, iband) == 0) THEN + ! choose packet size such that cprod is smaller than memory threshold + IF (rdum*iband <= maxmem) THEN + psize = iband + EXIT + END IF END IF + END DO + + IF (psize /= mnobd) THEN + WRITE (6, '(A,A,i3,A,f7.2,A)') ' Divide the loop over the occupied hybrid%bands in packages', & + ' of the size', psize, ' (cprod=', rdum*psize, 'MB)' END IF - END DO - - IF(psize.ne.mnobd) THEN - WRITE(6,'(A,A,i3,A,f7.2,A)') ' Divide the loop over the occupied hybrid%bands in packages',& - ' of the size',psize,' (cprod=',rdum*psize,'MB)' - END IF - ALLOCATE( phase_vv(psize,hybrid%nbands(nk)),stat=ok ) - IF(ok.ne.0) STOP 'exchange_val_hf: error allocation phase' - phase_vv=0 - IF(ok.ne.0) STOP 'exchange_val_hf: error allocation phase' - - if (mat_ex%l_real) THEN - ALLOCATE( cprod_vv_c(hybrid%maxbasm1,0,0), carr3_vv_c(hybrid%maxbasm1,0,0)) - ALLOCATE( cprod_vv_r(hybrid%maxbasm1,psize,hybrid%nbands(nk)),stat=ok ) - IF( ok .ne. 0 ) STOP 'exchange_val_hf: error allocation cprod' - ALLOCATE( carr3_vv_r(hybrid%maxbasm1,psize,hybrid%nbands(nk)),stat=ok ) - IF( ok .ne. 0 ) STOP 'exchange_val_hf: error allocation carr3' - cprod_vv_r = 0 ; carr3_vv_r = 0 - ELSE - ALLOCATE( cprod_vv_r(hybrid%maxbasm1,0,0), carr3_vv_r(hybrid%maxbasm1,0,0)) - ALLOCATE( cprod_vv_c(hybrid%maxbasm1,psize,hybrid%nbands(nk)),stat=ok ) - IF( ok .ne. 0 ) STOP 'exchange_val_hf: error allocation cprod' - ALLOCATE( carr3_vv_c(hybrid%maxbasm1,psize,hybrid%nbands(nk)),stat=ok ) - IF( ok .ne. 0 ) STOP 'exchange_val_hf: error allocation carr3' - cprod_vv_c = 0 ; carr3_vv_c = 0 - END IF - - exch_vv = 0 - - DO ikpt = 1,nkpt_EIBZ - - ikpt0 = pointer_EIBZ(ikpt) - - n = hybrid%nbasp + hybrid%ngptm(ikpt0) - IF( hybrid%nbasm(ikpt0).ne.n) STOP 'error hybrid%nbasm' - nn = n*(n+1)/2 - - ! read in coulomb matrix from direct access file coulomb - IF (mat_ex%l_real) THEN - CALL read_coulomb_spm_r(kpts%bkp(ikpt0),coulomb_mt1,coulomb_mt2_r,coulomb_mt3_r,coulomb_mtir_r) + ALLOCATE (phase_vv(psize, hybrid%nbands(nk)), stat=ok) + IF (ok /= 0) STOP 'exchange_val_hf: error allocation phase' + phase_vv = 0 + IF (ok /= 0) STOP 'exchange_val_hf: error allocation phase' + + if (mat_ex%l_real) THEN + ALLOCATE (cprod_vv_c(hybrid%maxbasm1, 0, 0), carr3_vv_c(hybrid%maxbasm1, 0, 0)) + ALLOCATE (cprod_vv_r(hybrid%maxbasm1, psize, hybrid%nbands(nk)), stat=ok) + IF (ok /= 0) STOP 'exchange_val_hf: error allocation cprod' + ALLOCATE (carr3_vv_r(hybrid%maxbasm1, psize, hybrid%nbands(nk)), stat=ok) + IF (ok /= 0) STOP 'exchange_val_hf: error allocation carr3' + cprod_vv_r = 0; carr3_vv_r = 0 ELSE - CALL read_coulomb_spm_c(kpts%bkp(ikpt0),coulomb_mt1,coulomb_mt2_c,coulomb_mt3_c,coulomb_mtir_c) + ALLOCATE (cprod_vv_r(hybrid%maxbasm1, 0, 0), carr3_vv_r(hybrid%maxbasm1, 0, 0)) + ALLOCATE (cprod_vv_c(hybrid%maxbasm1, psize, hybrid%nbands(nk)), stat=ok) + IF (ok /= 0) STOP 'exchange_val_hf: error allocation cprod' + ALLOCATE (carr3_vv_c(hybrid%maxbasm1, psize, hybrid%nbands(nk)), stat=ok) + IF (ok /= 0) STOP 'exchange_val_hf: error allocation carr3' + cprod_vv_c = 0; carr3_vv_c = 0 END IF - IF(kpts%bkp(ikpt0).ne.ikpt0) THEN -#if( !defined CPP_NOSPMVEC && !defined CPP_IRAPPROX ) - IF((kpts%bksym(ikpt0).gt.sym%nop).and.(.not.mat_ex%l_real)) THEN - coulomb_mt2_c = conjg(coulomb_mt2_c) - coulomb_mtir_c = conjg(coulomb_mtir_c) + exch_vv = 0 + + DO ikpt = 1, nkpt_EIBZ + + ikpt0 = pointer_EIBZ(ikpt) + + n = hybrid%nbasp + hybrid%ngptm(ikpt0) + IF (hybrid%nbasm(ikpt0) /= n) STOP 'error hybrid%nbasm' + nn = n*(n + 1)/2 + + ! read in coulomb matrix from direct access file coulomb + IF (mat_ex%l_real) THEN + CALL read_coulomb_spm_r(kpts%bkp(ikpt0), coulomb_mt1, coulomb_mt2_r, coulomb_mt3_r, coulomb_mtir_r) + ELSE + CALL read_coulomb_spm_c(kpts%bkp(ikpt0), coulomb_mt1, coulomb_mt2_c, coulomb_mt3_c, coulomb_mtir_c) END IF + + IF (kpts%bkp(ikpt0) /= ikpt0) THEN +#if( !defined CPP_NOSPMVEC && !defined CPP_IRAPPROX ) + IF ((kpts%bksym(ikpt0) > sym%nop) .and. (.not. mat_ex%l_real)) THEN + coulomb_mt2_c = conjg(coulomb_mt2_c) + coulomb_mtir_c = conjg(coulomb_mtir_c) + END IF #else - if (.not.mat_ex%l_real) THEN - IF( kpts%bksym(ikpt0) .gt. sym%nop ) coulomb = conjg(coulomb) - endif + if (.not. mat_ex%l_real) THEN + IF (kpts%bksym(ikpt0) > sym%nop) coulomb = conjg(coulomb) + endif #endif - END IF + END IF - DO ibando = 1, mnobd, psize + DO ibando = 1, mnobd, psize - IF (mat_ex%l_real) THEN + IF (mat_ex%l_real) THEN #ifdef CPP_IRAPPROX - CALL wavefproducts_inv(1,hybdat,dimension,input,jsp,atoms,lapw,obsolete,kpts,nk,ikpt0,& - mnobd,hybrid,parent,cell,sym,noco,nkqpt,cprod_vv) + CALL wavefproducts_inv(1, hybdat, dimension, input, jsp, atoms, lapw, obsolete, kpts, nk, ikpt0, & + mnobd, hybrid, parent, cell, sym, noco, nkqpt, cprod_vv) #else - CALL wavefproducts_inv5(1,hybrid%nbands(nk),ibando,ibando+psize-1,dimension,input,jsp,atoms,& - lapw,kpts,nk,ikpt0,hybdat,mnobd,hybrid,parent,cell,hybrid%nbasp,sym,& - noco,nkqpt,cprod_vv_r) + CALL wavefproducts_inv5(1, hybrid%nbands(nk), ibando, ibando + psize - 1, dimension, input, jsp, atoms, & + lapw, kpts, nk, ikpt0, hybdat, mnobd, hybrid, parent, cell, hybrid%nbasp, sym, & + noco, nkqpt, cprod_vv_r) #endif - ELSE + ELSE #ifdef CPP_IRAPPROX - CALL wavefproducts_noinv(1,hybdat,nk,ikpt0,dimension,input,jsp,cell,atoms,hybrid, - kpts,mnobd,lapw,sym,noco,nkqpt,cprod_vv) + CALL wavefproducts_noinv(1, hybdat, nk, ikpt0, dimension, input, jsp, cell, atoms, hybrid, + kpts, mnobd, lapw, sym, noco, nkqpt, cprod_vv) #else - CALL wavefproducts_noinv5(1,hybrid%nbands(nk),ibando,ibando+psize-1,nk,ikpt0,dimension,input,jsp,&!jsp,& - cell,atoms,hybrid,hybdat,kpts,mnobd,lapw,sym,hybrid%nbasp,noco,nkqpt,cprod_vv_c) + CALL wavefproducts_noinv5(1, hybrid%nbands(nk), ibando, ibando + psize - 1, nk, ikpt0, dimension, input, jsp, &!jsp,& + cell, atoms, hybrid, hybdat, kpts, mnobd, lapw, sym, hybrid%nbasp, noco, nkqpt, cprod_vv_c) #endif - END IF + END IF - ! The sparse matrix technique is not feasible for the HSE - ! functional. Thus, a dynamic adjustment is implemented - ! The mixed basis functions and the potential difference - ! are Fourier transformed, so that the exchange can be calculated - ! in Fourier space + ! The sparse matrix technique is not feasible for the HSE + ! functional. Thus, a dynamic adjustment is implemented + ! The mixed basis functions and the potential difference + ! are Fourier transformed, so that the exchange can be calculated + ! in Fourier space #ifndef CPP_NOSPMVEC - IF (xcpot%is_name("hse").OR.xcpot%is_name("vhse")) THEN - iband1 = hybrid%nobd(nkqpt) - - exch_vv = exch_vv +& - dynamic_hse_adjustment(atoms%rmsh,atoms%rmt,atoms%dx,atoms%jri,atoms%jmtd,kpts%bkf(:,ikpt0),ikpt0,& - kpts%nkptf,cell%bmat,cell%omtil,atoms%ntype,atoms%neq,atoms%nat,atoms%taual,& - hybrid%lcutm1,hybrid%maxlcutm1,hybrid%nindxm1,hybrid%maxindxm1,hybrid%gptm,& - hybrid%ngptm(ikpt0),hybrid%pgptm(:,ikpt0),hybrid%gptmd,hybrid%basm1,& - hybrid%nbasm(ikpt0),iband1,hybrid%nbands(nk),nsest,ibando,psize,indx_sest,& - atoms%invsat,sym%invsatnr,mpi%irank,cprod_vv_r(:hybrid%nbasm(ikpt0),:,:),& - cprod_vv_c(:hybrid%nbasm(ikpt0),:,:),mat_ex%l_real,wl_iks(:iband1,nkqpt),n_q(ikpt)) - END IF + IF (xcpot%is_name("hse") .OR. xcpot%is_name("vhse")) THEN + iband1 = hybrid%nobd(nkqpt) + + exch_vv = exch_vv + & + dynamic_hse_adjustment(atoms%rmsh, atoms%rmt, atoms%dx, atoms%jri, atoms%jmtd, kpts%bkf(:, ikpt0), ikpt0, & + kpts%nkptf, cell%bmat, cell%omtil, atoms%ntype, atoms%neq, atoms%nat, atoms%taual, & + hybrid%lcutm1, hybrid%maxlcutm1, hybrid%nindxm1, hybrid%maxindxm1, hybrid%gptm, & + hybrid%ngptm(ikpt0), hybrid%pgptm(:, ikpt0), hybrid%gptmd, hybrid%basm1, & + hybrid%nbasm(ikpt0), iband1, hybrid%nbands(nk), nsest, ibando, psize, indx_sest, & + atoms%invsat, sym%invsatnr, mpi%irank, cprod_vv_r(:hybrid%nbasm(ikpt0), :, :), & + cprod_vv_c(:hybrid%nbasm(ikpt0), :, :), mat_ex%l_real, wl_iks(:iband1, nkqpt), n_q(ikpt)) + END IF #endif - ! the Coulomb matrix is only evaluated at the irrecuible k-points - ! bra_trafo transforms cprod instead of rotating the Coulomb matrix - ! from IBZ to current k-point - IF( kpts%bkp(ikpt0) .ne. ikpt0 ) THEN - CALL bra_trafo2(mat_ex%l_real,carr3_vv_r(:hybrid%nbasm(ikpt0),:,:),cprod_vv_r(:hybrid%nbasm(ikpt0),:,:),& - carr3_vv_c(:hybrid%nbasm(ikpt0),:,:),cprod_vv_c(:hybrid%nbasm(ikpt0),:,:),& - hybrid%nbasm(ikpt0),psize,hybrid%nbands(nk),kpts%bkp(ikpt0),ikpt0,kpts%bksym(ikpt0),sym,& - hybrid,kpts,cell,atoms,phase_vv) - IF (mat_ex%l_real) THEN - cprod_vv_r(:hybrid%nbasm(ikpt0),:,:) = carr3_vv_r(:hybrid%nbasm(ikpt0),:,:) - ELSE - cprod_vv_c(:hybrid%nbasm(ikpt0),:,:) = carr3_vv_c(:hybrid%nbasm(ikpt0),:,:) - ENDIF - ELSE - phase_vv(:,:) = (1.0,0.0) - END IF - - ! calculate exchange matrix at ikpt0 - - call timestart("exchange matrix") - DO n1=1,hybrid%nbands(nk) - DO iband = 1,psize - IF((ibando+iband-1).gt.hybrid%nobd(nkqpt)) CYCLE - - cdum = wl_iks(ibando+iband-1,nkqpt) * conjg(phase_vv(iband,n1))/n_q(ikpt) - + ! the Coulomb matrix is only evaluated at the irrecuible k-points + ! bra_trafo transforms cprod instead of rotating the Coulomb matrix + ! from IBZ to current k-point + IF (kpts%bkp(ikpt0) /= ikpt0) THEN + CALL bra_trafo2(mat_ex%l_real, carr3_vv_r(:hybrid%nbasm(ikpt0), :, :), cprod_vv_r(:hybrid%nbasm(ikpt0), :, :), & + carr3_vv_c(:hybrid%nbasm(ikpt0), :, :), cprod_vv_c(:hybrid%nbasm(ikpt0), :, :), & + hybrid%nbasm(ikpt0), psize, hybrid%nbands(nk), kpts%bkp(ikpt0), ikpt0, kpts%bksym(ikpt0), sym, & + hybrid, kpts, cell, atoms, phase_vv) IF (mat_ex%l_real) THEN - carr1_v_r(:n) = 0 - CALL spmvec_invs(atoms,hybrid,hybdat,ikpt0,kpts,cell,coulomb_mt1,coulomb_mt2_r,coulomb_mt3_r,& - coulomb_mtir_r,cprod_vv_r(:n,iband,n1),carr1_v_r(:n)) + cprod_vv_r(:hybrid%nbasm(ikpt0), :, :) = carr3_vv_r(:hybrid%nbasm(ikpt0), :, :) ELSE - carr1_v_c(:n) = 0 - CALL spmvec_noinvs(atoms,hybrid,hybdat,ikpt0,kpts,cell,coulomb_mt1,coulomb_mt2_c,coulomb_mt3_c,& - coulomb_mtir_c,cprod_vv_c(:n,iband,n1),carr1_v_c(:n)) - END IF + cprod_vv_c(:hybrid%nbasm(ikpt0), :, :) = carr3_vv_c(:hybrid%nbasm(ikpt0), :, :) + ENDIF + ELSE + phase_vv(:, :) = (1.0, 0.0) + END IF - IF (mat_ex%l_real) THEN - DO n2=1,nsest(n1)!n1 - nn2 = indx_sest(n2,n1) - exch_vv(nn2,n1) = exch_vv(nn2,n1) + cdum*phase_vv(iband,nn2) *& - dotprod(carr1_v_r(:n),cprod_vv_r(:n,iband,nn2)) - END DO !n2 - ELSE - DO n2=1,nsest(n1)!n1 - nn2 = indx_sest(n2,n1) - exch_vv(nn2,n1) = exch_vv(nn2,n1) + cdum*phase_vv(iband,nn2) *& - dotprod(carr1_v_c(:n),cprod_vv_c(:n,iband,nn2)) - END DO !n2 - END IF - END DO - END DO !n1 - call timestop("exchange matrix") - END DO !ibando - END DO !ikpt + ! calculate exchange matrix at ikpt0 + + call timestart("exchange matrix") + DO n1 = 1, hybrid%nbands(nk) + DO iband = 1, psize + IF ((ibando + iband - 1) > hybrid%nobd(nkqpt)) CYCLE + + cdum = wl_iks(ibando + iband - 1, nkqpt)*conjg(phase_vv(iband, n1))/n_q(ikpt) + + IF (mat_ex%l_real) THEN + carr1_v_r(:n) = 0 + CALL spmvec_invs(atoms, hybrid, hybdat, ikpt0, kpts, cell, coulomb_mt1, coulomb_mt2_r, coulomb_mt3_r, & + coulomb_mtir_r, cprod_vv_r(:n, iband, n1), carr1_v_r(:n)) + ELSE + carr1_v_c(:n) = 0 + CALL spmvec_noinvs(atoms, hybrid, hybdat, ikpt0, kpts, cell, coulomb_mt1, coulomb_mt2_c, coulomb_mt3_c, & + coulomb_mtir_c, cprod_vv_c(:n, iband, n1), carr1_v_c(:n)) + END IF + + IF (mat_ex%l_real) THEN + DO n2 = 1, nsest(n1)!n1 + nn2 = indx_sest(n2, n1) + exch_vv(nn2, n1) = exch_vv(nn2, n1) + cdum*phase_vv(iband, nn2)* & + dotprod(carr1_v_r(:n), cprod_vv_r(:n, iband, nn2)) + END DO !n2 + ELSE + DO n2 = 1, nsest(n1)!n1 + nn2 = indx_sest(n2, n1) + exch_vv(nn2, n1) = exch_vv(nn2, n1) + cdum*phase_vv(iband, nn2)* & + dotprod(carr1_v_c(:n), cprod_vv_c(:n, iband, nn2)) + END DO !n2 + END IF + END DO + END DO !n1 + call timestop("exchange matrix") + END DO !ibando + END DO !ikpt ! WRITE(7001,'(a,i7)') 'nk: ', nk ! DO n1=1,hybrid%nbands(nk) @@ -368,118 +366,117 @@ SUBROUTINE exchange_valence_hf(nk,kpts,nkpt_EIBZ,sym,atoms,hybrid,cell,dimension ! END DO ! END DO - ! add contribution of the gamma point to the different cases (exch_vv,exch_cv,exch_cc) + ! add contribution of the gamma point to the different cases (exch_vv,exch_cv,exch_cc) - ! valence-valence-valence-valence exchange + ! valence-valence-valence-valence exchange - IF ((.not.xcpot%is_name("hse")).AND.(.not.xcpot%is_name("vhse"))) THEN ! no gamma point correction needed for HSE functional - IF( zero_order .and. .not. ibs_corr ) THEN - WRITE(6,'(A)') ' Take zero order terms into account.' - ELSE IF( zero_order .and. ibs_corr ) THEN - WRITE(6,'(A)') ' Take zero order terms and ibs-correction into account.' - END IF + IF ((.not. xcpot%is_name("hse")) .AND. (.not. xcpot%is_name("vhse"))) THEN ! no gamma point correction needed for HSE functional + IF (zero_order .and. .not. ibs_corr) THEN + WRITE (6, '(A)') ' Take zero order terms into account.' + ELSE IF (zero_order .and. ibs_corr) THEN + WRITE (6, '(A)') ' Take zero order terms and ibs-correction into account.' + END IF - IF(zero_order) THEN - CALL dwavefproducts(dcprod,nk,1,hybrid%nbands(nk),1,hybrid%nbands(nk),.false.,atoms,hybrid,& - cell,hybdat,kpts,kpts%nkpt,lapw,dimension,jsp,eig_irr) + IF (zero_order) THEN + CALL dwavefproducts(dcprod, nk, 1, hybrid%nbands(nk), 1, hybrid%nbands(nk), .false., atoms, hybrid, & + cell, hybdat, kpts, kpts%nkpt, lapw, dimension, jsp, eig_irr) - ! make dcprod hermitian - DO n1 = 1, hybrid%nbands(nk) - DO n2 = 1,n1 - dcprod(n1,n2,:) = (dcprod(n1,n2,:) - conjg(dcprod(n2,n1,:)))/2 - dcprod(n2,n1,:) = -conjg(dcprod(n1,n2,:)) + ! make dcprod hermitian + DO n1 = 1, hybrid%nbands(nk) + DO n2 = 1, n1 + dcprod(n1, n2, :) = (dcprod(n1, n2, :) - conjg(dcprod(n2, n1, :)))/2 + dcprod(n2, n1, :) = -conjg(dcprod(n1, n2, :)) + END DO END DO - END DO - IF(ibs_corr) THEN - CALL ibs_correction(nk,atoms,dimension,input,jsp,hybdat,hybrid,lapw,kpts,kpts%nkpt,cell,mnobd,& - sym,proj_ibsc,olap_ibsc) - END IF - END IF - - !This should be done with w_iks I guess!TODO - occup = .false. - DO i=1,hybrid%ne_eig(nk) - IF (results%ef.ge.eig_irr(i,nk)) THEN - occup(i) = .true. - ELSE IF ((eig_irr(i,nk)-results%ef).le.1E-06) THEN - occup(i) = .true. + IF (ibs_corr) THEN + CALL ibs_correction(nk, atoms, dimension, input, jsp, hybdat, hybrid, lapw, kpts, kpts%nkpt, cell, mnobd, & + sym, proj_ibsc, olap_ibsc) + END IF END IF - END DO - DO n1 = 1, hybrid%nbands(nk) - DO n2 = 1, nsest(n1)!n1 - nn2 = indx_sest(n2,n1) - exchcorrect = 0 - exch0 = 0 - - ! if zero_order = .true. add averaged k-dependent term to the numerical integration at Gamma-point contribution - - ! if we start with a system with a small DFT band gap (like GaAs), the contribution - ! of the highest occupied and lowest unoccupied state in Hessian is typically - ! large; a correct numerical integration requires a dense k-point mesh, so - ! we don't add the contribution exchcorrect for such materials - - IF(zero_order) THEN - hessian = 0 - IF(occup(n1).and.occup(nn2)) THEN - DO i = 1,3 - j = i - DO iband = 1, hybrid%nbands(nk) - IF(occup(iband)) THEN - hessian(i,j) = hessian(i,j) + conjg(dcprod(iband,n1,i)) *dcprod(iband,nn2,j) - END IF - hessian(i,j) = hessian(i,j) - dcprod(iband,nn2,i) * conjg(dcprod(iband,n1,j)) - END DO + !This should be done with w_iks I guess!TODO + occup = .false. + DO i = 1, hybrid%ne_eig(nk) + IF (results%ef >= eig_irr(i, nk)) THEN + occup(i) = .true. + ELSE IF ((eig_irr(i, nk) - results%ef) <= 1E-06) THEN + occup(i) = .true. + END IF + END DO - ! ibs correction - IF(ibs_corr) THEN - hessian(i,j) = hessian(i,j) - olap_ibsc(i,j,n1,nn2)/cell%omtil - DO iband = 1,hybrid%nbands(nk) - hessian(i,j) = hessian(i,j) + conjg(proj_ibsc(i,nn2,iband)) * proj_ibsc(j,n1,iband)/cell%omtil + DO n1 = 1, hybrid%nbands(nk) + DO n2 = 1, nsest(n1)!n1 + nn2 = indx_sest(n2, n1) + exchcorrect = 0 + exch0 = 0 + + ! if zero_order = .true. add averaged k-dependent term to the numerical integration at Gamma-point contribution + + ! if we start with a system with a small DFT band gap (like GaAs), the contribution + ! of the highest occupied and lowest unoccupied state in Hessian is typically + ! large; a correct numerical integration requires a dense k-point mesh, so + ! we don't add the contribution exchcorrect for such materials + + IF (zero_order) THEN + hessian = 0 + IF (occup(n1) .and. occup(nn2)) THEN + DO i = 1, 3 + j = i + DO iband = 1, hybrid%nbands(nk) + IF (occup(iband)) THEN + hessian(i, j) = hessian(i, j) + conjg(dcprod(iband, n1, i))*dcprod(iband, nn2, j) + END IF + hessian(i, j) = hessian(i, j) - dcprod(iband, nn2, i)*conjg(dcprod(iband, n1, j)) END DO - END IF - END DO - ELSE - DO i = 1,3 - j = i - DO iband = 1, hybrid%nbands(nk) - IF(occup(iband)) THEN - hessian(i,j) = hessian(i,j) + conjg(dcprod(iband,n1,i)) * dcprod(iband,nn2,j) + + ! ibs correction + IF (ibs_corr) THEN + hessian(i, j) = hessian(i, j) - olap_ibsc(i, j, n1, nn2)/cell%omtil + DO iband = 1, hybrid%nbands(nk) + hessian(i, j) = hessian(i, j) + conjg(proj_ibsc(i, nn2, iband))*proj_ibsc(j, n1, iband)/cell%omtil + END DO END IF END DO - END DO - END IF - - exchcorrect(1) = fpi_const/3 * (hessian(1,1)+hessian(2,2)+hessian(3,3)) - exch0 = exchcorrect(1)/kpts%nkptf - END IF + ELSE + DO i = 1, 3 + j = i + DO iband = 1, hybrid%nbands(nk) + IF (occup(iband)) THEN + hessian(i, j) = hessian(i, j) + conjg(dcprod(iband, n1, i))*dcprod(iband, nn2, j) + END IF + END DO + END DO + END IF - ! tail correction/contribution from all other k-points (it goes into exchcorrect ) + exchcorrect(1) = fpi_const/3*(hessian(1, 1) + hessian(2, 2) + hessian(3, 3)) + exch0 = exchcorrect(1)/kpts%nkptf + END IF - ! Analytic contribution + ! tail correction/contribution from all other k-points (it goes into exchcorrect ) - cdum2 = 0 - !multiply divergent contribution with occupation number; - !this only affects metals - IF (n1.eq.nn2) THEN - cdum2 = fpi_const/cell%omtil * divergence * wl_iks(n1,nk)*kpts%nkptf - END IF + ! Analytic contribution - ! due to the symmetrization afterwards the factor 1/n_q(1) must be added + cdum2 = 0 + !multiply divergent contribution with occupation number; + !this only affects metals + IF (n1 == nn2) THEN + cdum2 = fpi_const/cell%omtil*divergence*wl_iks(n1, nk)*kpts%nkptf + END IF - IF(n1.EQ.nn2) hybrid%div_vv(n1,nk,jsp) = REAL(cdum2) - exch_vv(nn2,n1) = exch_vv(nn2,n1) + (exch0 + cdum2)/n_q(1) + ! due to the symmetrization afterwards the factor 1/n_q(1) must be added - END DO !n2 - END DO !n1 - END IF ! xcpot%icorr .ne. icorr_hse + IF (n1 == nn2) hybrid%div_vv(n1, nk, jsp) = REAL(cdum2) + exch_vv(nn2, n1) = exch_vv(nn2, n1) + (exch0 + cdum2)/n_q(1) + END DO !n2 + END DO !n1 + END IF ! xcpot%icorr .ne. icorr_hse - IF (mat_ex%l_real) THEN - IF(any(abs(aimag(exch_vv)).gt.1E-08)) CALL judft_warn('unusally large imaginary part of exch_vv',& - calledby='exchange_val_hf.F90') - END IF + IF (mat_ex%l_real) THEN + IF (any(abs(aimag(exch_vv)) > 1E-08)) CALL judft_warn('unusally large imaginary part of exch_vv', & + calledby='exchange_val_hf.F90') + END IF ! WRITE(7000,'(a,i7)') 'nk: ', nk ! DO n1=1,hybrid%nbands(nk) @@ -488,70 +485,67 @@ SUBROUTINE exchange_valence_hf(nk,kpts,nkpt_EIBZ,sym,atoms,hybrid,cell,dimension ! END DO ! END DO - ! write exch_vv in mat_ex - CALL mat_ex%alloc(matsize1=hybrid%nbands(nk)) - IF (mat_ex%l_real) THEN - mat_ex%data_r=exch_vv - ELSE - mat_ex%data_c=exch_vv - END IF - CALL timestop("valence exchange calculation") - -END SUBROUTINE exchange_valence_hf - - - - -SUBROUTINE calc_divergence(cell,kpts,divergence) - - USE m_util, ONLY: cerf - USE m_types - USE m_constants - - IMPLICIT NONE - - TYPE(t_cell), INTENT(IN) :: cell - TYPE(t_kpts), INTENT(IN) :: kpts - REAL, INTENT(OUT) :: divergence - - INTEGER :: ix,iy,iz,sign,n - logical :: found - REAL :: expo,rrad,k(3),kv1(3),kv2(3),kv3(3),knorm2 - COMPLEX :: cdum - - expo = 5*10.0**-3 - rrad = sqrt(-log(5*10.0**-3)/expo) - cdum = sqrt(expo)*rrad - divergence = cell%omtil / (tpi_const**2) * sqrt(pi_const/expo) * cerf(cdum) - rrad = rrad**2 - kv1 = cell%bmat(1,:)/kpts%nkpt3(1) - kv2 = cell%bmat(2,:)/kpts%nkpt3(2) - kv3 = cell%bmat(3,:)/kpts%nkpt3(3) - n = 1 - found = .true. - - DO WHILE(found) - found = .false. - DO ix = -n,n - DO iy = -(n-abs(ix)),n-abs(ix) - iz = n - abs(ix) - abs(iy) - DO sign=-1,1,2 - iz=sign*iz - k(1) = ix*kv1(1) + iy*kv2(1) + iz*kv3(1) - k(2) = ix*kv1(2) + iy*kv2(2) + iz*kv3(2) - k(3) = ix*kv1(3) + iy*kv2(3) + iz*kv3(3) - knorm2 = k(1)**2 + k(2)**2 + k(3)**2 - IF(knorm2.lt.rrad) THEN - found = .true. - divergence = divergence - exp(-expo*knorm2)/knorm2 / kpts%nkptf - END IF - IF(iz==0) exit - END DO + ! write exch_vv in mat_ex + CALL mat_ex%alloc(matsize1=hybrid%nbands(nk)) + IF (mat_ex%l_real) THEN + mat_ex%data_r = exch_vv + ELSE + mat_ex%data_c = exch_vv + END IF + CALL timestop("valence exchange calculation") + + END SUBROUTINE exchange_valence_hf + + SUBROUTINE calc_divergence(cell, kpts, divergence) + + USE m_util, ONLY: cerf + USE m_types + USE m_constants + + IMPLICIT NONE + + TYPE(t_cell), INTENT(IN) :: cell + TYPE(t_kpts), INTENT(IN) :: kpts + REAL, INTENT(OUT) :: divergence + + INTEGER :: ix, iy, iz, sign, n + logical :: found + REAL :: expo, rrad, k(3), kv1(3), kv2(3), kv3(3), knorm2 + COMPLEX :: cdum + + expo = 5*10.0**-3 + rrad = sqrt(-log(5*10.0**-3)/expo) + cdum = sqrt(expo)*rrad + divergence = cell%omtil/(tpi_const**2)*sqrt(pi_const/expo)*cerf(cdum) + rrad = rrad**2 + kv1 = cell%bmat(1, :)/kpts%nkpt3(1) + kv2 = cell%bmat(2, :)/kpts%nkpt3(2) + kv3 = cell%bmat(3, :)/kpts%nkpt3(3) + n = 1 + found = .true. + + DO WHILE (found) + found = .false. + DO ix = -n, n + DO iy = -(n - abs(ix)), n - abs(ix) + iz = n - abs(ix) - abs(iy) + DO sign = -1, 1, 2 + iz = sign*iz + k(1) = ix*kv1(1) + iy*kv2(1) + iz*kv3(1) + k(2) = ix*kv1(2) + iy*kv2(2) + iz*kv3(2) + k(3) = ix*kv1(3) + iy*kv2(3) + iz*kv3(3) + knorm2 = k(1)**2 + k(2)**2 + k(3)**2 + IF (knorm2 < rrad) THEN + found = .true. + divergence = divergence - exp(-expo*knorm2)/knorm2/kpts%nkptf + END IF + IF (iz == 0) exit + END DO + END DO END DO + n = n + 1 END DO - n = n + 1 - END DO -END SUBROUTINE calc_divergence + END SUBROUTINE calc_divergence END MODULE m_exchange_valence_hf diff --git a/hybrid/exponential_integral.f90 b/hybrid/exponential_integral.f90 index 82a2fd9cc9ee843ea9e6ff5475383c252af55cf7..6e9aff067bf6a15e901b55edb6188152dcbeaadc 100644 --- a/hybrid/exponential_integral.f90 +++ b/hybrid/exponential_integral.f90 @@ -2,120 +2,120 @@ ! [1] Tseng, Lee, Journal of Hydrology, 205 (1998) 38-51 module m_exponential_integral - implicit none - - real, parameter :: series_laguerre = 4.0 + implicit none + + real, parameter :: series_laguerre = 4.0 contains - ! Calculate the exponential integral E_1(x): - ! - ! inf - ! / -t - ! | e - ! E (x) = | dt ----- - ! 1 | t - ! / - ! x - ! - ! Input: arg - position at which exponential integral is evaluated (arg > 0) - ! Output: res - E_1(arg) - pure subroutine calculateExponentialIntegral(arg, res) - - implicit none - - real, intent(in) :: arg - real, intent(out) :: res - - ! For arguments smaller than 4 the series expansion is used - if (arg < series_laguerre) then - res = seriesExpansion(arg) - - ! otherwise a Gauss-Laguerre expansion is better - else - res = exp(-arg) * gauss_laguerre(arg) - endif - - end subroutine calculateExponentialIntegral - - ! Series expansion of the exponential integral - ! - ! n_cut - ! ----- n n - ! \ (-1) x - ! E (x) = -gamma - ln(x) - ) -------- - ! 1 / n * n! - ! ----- - ! n = 1 - ! - ! where gamma is the Euler constant. - ! n_cut is set to 25 - ! Input: arg - argument for which the exponential integral is approximated - ! Return: approximation by series expansion for E_1(arg) - pure real function seriesExpansion(arg) - - implicit none - - real, intent(in) :: arg - - real :: res, fact ! result of the summation, 1 / n - integer :: i ! counter variable - - real, parameter :: EULER_GAMMA = 0.57721566490153286060651209008241 ! Euler constant - integer, parameter :: ITERATION = 25 ! Cutoff for series expansion - - ! initialize summation result - res = 0.0 - - ! perform the summation - do i = ITERATION, 2, -1 - ! calculate 1/n - fact = 1.0 / i - ! add next term of summation - res = arg * fact * (fact - res) - end do - - ! calculate the final result - seriesExpansion = -EULER_GAMMA - log(arg) + arg * (1.0 - res) - - end function seriesExpansion - - ! The Gauss Laguerre expansion of the exponential integral can be written as - ! - ! N - ! E (arg) ----- a - ! 1 \ n - ! ------- = ) -------- - ! -arg / x + arg - ! e ----- n - ! n=1 - ! - ! where the a_n and x_n are determined by least quadrature and are given in [1] - ! Input: arg - point at which Gaussian Laguerre quadrature is calculated - ! Return: E_1(arg) in this approximation - pure real function gauss_laguerre(arg) - - implicit none - - real, intent(in) :: arg - - ! the quadrature constants a_n and x_n from [1] - real, parameter :: a(1:15) = (/& - 0.2182348859400869e+00, 0.3422101779228833e+00, 0.2630275779416801e+00, & - 0.1264258181059305e+00, 0.4020686492100091e-01, 0.8563877803611838e-02, & - 0.1212436147214252e-02, 0.1116743923442519e-03, 0.6459926762022901e-05, & - 0.2226316907096273e-06, 0.4227430384979365e-08, 0.3921897267041089e-10, & - 0.1456515264073126e-12, 0.1483027051113301e-15, 0.1600594906211133e-19/) - real, parameter :: x(1:15) = (/& - 0.9330781201728180e-01, 0.4926917403018839e+00, 0.1215595412070949e+01, & - 0.2269949526203743e+01, 0.3667622721751437e+01, 0.5425336627413553e+01, & - 0.7565916226613068e+01, 0.1012022856801911e+02, 0.1313028248217572e+02, & - 0.1665440770832996e+02, 0.2077647889944877e+02, 0.2562389422672878e+02, & - 0.3140751916975394e+02, 0.3853068330648601e+02, 0.4802608557268579e+02/) - - ! Calculate the summation - gauss_laguerre = sum( a / (x + arg) ) - - end function gauss_laguerre + ! Calculate the exponential integral E_1(x): + ! + ! inf + ! / -t + ! | e + ! E (x) = | dt ----- + ! 1 | t + ! / + ! x + ! + ! Input: arg - position at which exponential integral is evaluated (arg > 0) + ! Output: res - E_1(arg) + pure subroutine calculateExponentialIntegral(arg, res) + + implicit none + + real, intent(in) :: arg + real, intent(out) :: res + + ! For arguments smaller than 4 the series expansion is used + if (arg < series_laguerre) then + res = seriesExpansion(arg) + + ! otherwise a Gauss-Laguerre expansion is better + else + res = exp(-arg)*gauss_laguerre(arg) + endif + + end subroutine calculateExponentialIntegral + + ! Series expansion of the exponential integral + ! + ! n_cut + ! ----- n n + ! \ (-1) x + ! E (x) = -gamma - ln(x) - ) -------- + ! 1 / n * n! + ! ----- + ! n = 1 + ! + ! where gamma is the Euler constant. + ! n_cut is set to 25 + ! Input: arg - argument for which the exponential integral is approximated + ! Return: approximation by series expansion for E_1(arg) + pure real function seriesExpansion(arg) + + implicit none + + real, intent(in) :: arg + + real :: res, fact ! result of the summation, 1 / n + integer :: i ! counter variable + + real, parameter :: EULER_GAMMA = 0.57721566490153286060651209008241 ! Euler constant + integer, parameter :: ITERATION = 25 ! Cutoff for series expansion + + ! initialize summation result + res = 0.0 + + ! perform the summation + do i = ITERATION, 2, -1 + ! calculate 1/n + fact = 1.0/i + ! add next term of summation + res = arg*fact*(fact - res) + end do + + ! calculate the final result + seriesExpansion = -EULER_GAMMA - log(arg) + arg*(1.0 - res) + + end function seriesExpansion + + ! The Gauss Laguerre expansion of the exponential integral can be written as + ! + ! N + ! E (arg) ----- a + ! 1 \ n + ! ------- = ) -------- + ! -arg / x + arg + ! e ----- n + ! n=1 + ! + ! where the a_n and x_n are determined by least quadrature and are given in [1] + ! Input: arg - point at which Gaussian Laguerre quadrature is calculated + ! Return: E_1(arg) in this approximation + pure real function gauss_laguerre(arg) + + implicit none + + real, intent(in) :: arg + + ! the quadrature constants a_n and x_n from [1] + real, parameter :: a(1:15) = (/ & + 0.2182348859400869e+00, 0.3422101779228833e+00, 0.2630275779416801e+00, & + 0.1264258181059305e+00, 0.4020686492100091e-01, 0.8563877803611838e-02, & + 0.1212436147214252e-02, 0.1116743923442519e-03, 0.6459926762022901e-05, & + 0.2226316907096273e-06, 0.4227430384979365e-08, 0.3921897267041089e-10, & + 0.1456515264073126e-12, 0.1483027051113301e-15, 0.1600594906211133e-19/) + real, parameter :: x(1:15) = (/ & + 0.9330781201728180e-01, 0.4926917403018839e+00, 0.1215595412070949e+01, & + 0.2269949526203743e+01, 0.3667622721751437e+01, 0.5425336627413553e+01, & + 0.7565916226613068e+01, 0.1012022856801911e+02, 0.1313028248217572e+02, & + 0.1665440770832996e+02, 0.2077647889944877e+02, 0.2562389422672878e+02, & + 0.3140751916975394e+02, 0.3853068330648601e+02, 0.4802608557268579e+02/) + + ! Calculate the summation + gauss_laguerre = sum(a/(x + arg)) + + end function gauss_laguerre end module m_exponential_integral diff --git a/hybrid/gen_wavf.F90 b/hybrid/gen_wavf.F90 index 8c942876c4ba9e54361d7cbc30c7f61c516a17c7..2ebbd0a98afcd1cac02df076d64287bb0bac47a7 100644 --- a/hybrid/gen_wavf.F90 +++ b/hybrid/gen_wavf.F90 @@ -10,22 +10,22 @@ ! and writes them out in cmt and z, respectively. ! ! M.Betzinger(09/07) ! !!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!! - + MODULE m_gen_wavf CONTAINS - SUBROUTINE gen_wavf (nkpti,kpts,it,sym,atoms,el_eig,ello_eig,cell,dimension,hybrid,vr0,& - hybdat,noco,oneD,mpi,input,jsp,zmat) + SUBROUTINE gen_wavf(nkpti, kpts, it, sym, atoms, el_eig, ello_eig, cell, dimension, hybrid, vr0, & + hybdat, noco, oneD, mpi, input, jsp, zmat) ! nkpti :: number of irreducible k-points - ! nkpt :: number of all k-points + ! nkpt :: number of all k-points USE m_radfun USE m_radflo USE m_abcof - USE m_trafo ,ONLY: waveftrafo_genwavf - USE m_util ,ONLY: modulo1 + USE m_trafo, ONLY: waveftrafo_genwavf + USE m_util, ONLY: modulo1 USE m_olap USE m_types USE m_hyb_abcrot @@ -33,144 +33,140 @@ CONTAINS IMPLICIT NONE - TYPE(t_hybdat), INTENT(INOUT) :: hybdat - TYPE(t_mpi), INTENT(IN) :: mpi + TYPE(t_hybdat), INTENT(INOUT) :: hybdat + TYPE(t_mpi), INTENT(IN) :: mpi TYPE(t_dimension), INTENT(IN) :: dimension - TYPE(t_oneD), INTENT(IN) :: oneD - TYPE(t_hybrid), INTENT(IN) :: hybrid - TYPE(t_input), INTENT(IN) :: input - TYPE(t_noco), INTENT(IN) :: noco - TYPE(t_sym), INTENT(IN) :: sym - TYPE(t_cell), INTENT(IN) :: cell - TYPE(t_kpts), INTENT(IN) :: kpts - TYPE(t_atoms), INTENT(IN) :: atoms - TYPE(t_mat), INTENT(IN) :: zmat(:) !for all kpoints - - INTEGER, INTENT(IN) :: nkpti, it - INTEGER, INTENT(IN) :: jsp - - REAL, INTENT(IN) :: vr0(:,:,:)!(jmtd,ntype,jspd) - REAL, INTENT(IN) :: el_eig(0:atoms%lmaxd,atoms%ntype) - REAL, INTENT(IN) :: ello_eig(atoms%nlod,atoms%ntype) + TYPE(t_oneD), INTENT(IN) :: oneD + TYPE(t_hybrid), INTENT(IN) :: hybrid + TYPE(t_input), INTENT(IN) :: input + TYPE(t_noco), INTENT(IN) :: noco + TYPE(t_sym), INTENT(IN) :: sym + TYPE(t_cell), INTENT(IN) :: cell + TYPE(t_kpts), INTENT(IN) :: kpts + TYPE(t_atoms), INTENT(IN) :: atoms + TYPE(t_mat), INTENT(IN) :: zmat(:) !for all kpoints + + INTEGER, INTENT(IN) :: nkpti, it + INTEGER, INTENT(IN) :: jsp + + REAL, INTENT(IN) :: vr0(:, :, :)!(jmtd,ntype,jspd) + REAL, INTENT(IN) :: el_eig(0:atoms%lmaxd, atoms%ntype) + REAL, INTENT(IN) :: ello_eig(atoms%nlod, atoms%ntype) ! local scalars - INTEGER :: ilo,idum,m,irecl_cmt,irecl_z + INTEGER :: ilo, idum, m, irecl_cmt, irecl_z COMPLEX :: cdum TYPE(t_mat) :: zhlp - INTEGER :: ikpt0,ikpt,itype,iop,ispin,ieq,indx,iatom - INTEGER :: i,j,l ,ll,lm,ng,ok - COMPLEX :: img=(0.0,1.0) + INTEGER :: ikpt0, ikpt, itype, iop, ispin, ieq, indx, iatom + INTEGER :: i, j, l, ll, lm, ng, ok + COMPLEX :: img = (0.0, 1.0) - INTEGER :: nodem,noded + INTEGER :: nodem, noded REAL :: wronk INTEGER :: lower, upper LOGICAL :: found ! local arrays - INTEGER :: rrot(3,3,sym%nsym) + INTEGER :: rrot(3, 3, sym%nsym) INTEGER :: map_lo(atoms%nlod) - INTEGER :: iarr(0:atoms%lmaxd,atoms%ntype) - COMPLEX,ALLOCATABLE :: acof(:,:,:),bcof(:,:,:),ccof(:,:,:,:) - - COMPLEX,ALLOCATABLE :: cmt(:,:,:),cmthlp(:,:,:) - - REAL :: vr(atoms%jmtd,atoms%ntype,input%jspins) - REAL,ALLOCATABLE :: f(:,:,:),df(:,:,:) - - REAL :: flo(atoms%jmtd,2,atoms%nlod) - REAL :: uuilon(atoms%nlod,atoms%ntype),duilon(atoms%nlod,atoms%ntype) - REAL :: ulouilopn(atoms%nlod,atoms%nlod,atoms%ntype) - + INTEGER :: iarr(0:atoms%lmaxd, atoms%ntype) + COMPLEX, ALLOCATABLE :: acof(:, :, :), bcof(:, :, :), ccof(:, :, :, :) + + COMPLEX, ALLOCATABLE :: cmt(:, :, :), cmthlp(:, :, :) + + REAL :: vr(atoms%jmtd, atoms%ntype, input%jspins) + REAL, ALLOCATABLE :: f(:, :, :), df(:, :, :) + + REAL :: flo(atoms%jmtd, 2, atoms%nlod) + REAL :: uuilon(atoms%nlod, atoms%ntype), duilon(atoms%nlod, atoms%ntype) + REAL :: ulouilopn(atoms%nlod, atoms%nlod, atoms%ntype) + REAL :: bkpt(3) ! local arrays for abcof1 ! COMPLEX :: a(nvd,0:lmd,natd,nkpti),b(nvd,0:lmd,natd,nkpti) - TYPE(t_lapw) :: lapw(kpts%nkptf) TYPE(t_usdus) :: usdus - CALL usdus%init(atoms,input%jspins) - CALL zhlp%alloc(zmat(1)%l_real,zmat(1)%matsize1,zmat(1)%matsize2) + CALL usdus%init(atoms, input%jspins) + CALL zhlp%alloc(zmat(1)%l_real, zmat(1)%matsize1, zmat(1)%matsize2) - ! setup rotations in reciprocal space DO iop = 1, sym%nsym - IF(iop.LE.sym%nop) THEN - rrot(:,:,iop) = transpose(sym%mrot(:,:,sym%invtab(iop))) + IF (iop <= sym%nop) THEN + rrot(:, :, iop) = transpose(sym%mrot(:, :, sym%invtab(iop))) ELSE - rrot(:,:,iop) = -rrot(:,:,iop-sym%nop) + rrot(:, :, iop) = -rrot(:, :, iop - sym%nop) END IF END DO ! generate G-vectors, which fulfill |k+G|= 1) THEN + CALL radflo(atoms, itype, jsp, ello_eig, vr(:, itype, jsp), f, df, mpi, usdus, uuilon, duilon, ulouilopn, flo) - DO ilo=1,atoms%nlo(itype) - iarr(atoms%llo(ilo,itype),itype) = iarr(atoms%llo(ilo,itype),itype) + 1 - hybdat%bas1(1:ng,iarr(atoms%llo(ilo,itype),itype),atoms%llo(ilo,itype),itype) = flo(1:ng,1,ilo) - hybdat%bas2(1:ng,iarr(atoms%llo(ilo,itype),itype),atoms%llo(ilo,itype),itype) = flo(1:ng,2,ilo) - hybdat%bas1_MT(iarr(atoms%llo(ilo,itype),itype),atoms%llo(ilo,itype),itype) = usdus%ulos(ilo,itype,jsp) - hybdat%drbas1_MT(iarr(atoms%llo(ilo,itype),itype),atoms%llo(ilo,itype),itype) = usdus%dulos(ilo,itype,jsp) + DO ilo = 1, atoms%nlo(itype) + iarr(atoms%llo(ilo, itype), itype) = iarr(atoms%llo(ilo, itype), itype) + 1 + hybdat%bas1(1:ng, iarr(atoms%llo(ilo, itype), itype), atoms%llo(ilo, itype), itype) = flo(1:ng, 1, ilo) + hybdat%bas2(1:ng, iarr(atoms%llo(ilo, itype), itype), atoms%llo(ilo, itype), itype) = flo(1:ng, 2, ilo) + hybdat%bas1_MT(iarr(atoms%llo(ilo, itype), itype), atoms%llo(ilo, itype), itype) = usdus%ulos(ilo, itype, jsp) + hybdat%drbas1_MT(iarr(atoms%llo(ilo, itype), itype), atoms%llo(ilo, itype), itype) = usdus%dulos(ilo, itype, jsp) END DO END IF END DO - DEALLOCATE (f,df) + DEALLOCATE (f, df) #if CPP_DEBUG ! consistency check - IF(.not.all(iarr.eq.hybrid%nindx)) STOP 'gen_wavf: counting error' + IF (.not. all(iarr == hybrid%nindx)) STOP 'gen_wavf: counting error' #endif - 8000 FORMAT (1x,/,/,' wavefunction parameters for atom type',i3,':',/,t32,'radial function',t79,& - 'energy derivative',/,t3,'l',t8,'energy',t26,'value',t39,'derivative',t53,& - 'nodes',t68,'value',t81,'derivative',t95,'nodes',t107,'norm',t119,'wronskian') - 8010 FORMAT (i3,f10.5,2 (5x,1p,2e16.7,i5),1p,2e16.7) +8000 FORMAT(1x, /, /, ' wavefunction parameters for atom type', i3, ':', /, t32, 'radial function', t79, & + 'energy derivative', /, t3, 'l', t8, 'energy', t26, 'value', t39, 'derivative', t53, & + 'nodes', t68, 'value', t81, 'derivative', t95, 'nodes', t107, 'norm', t119, 'wronskian') +8010 FORMAT(i3, f10.5, 2(5x, 1p, 2e16.7, i5), 1p, 2e16.7) ! determine boundaries for parallel calculations lower = 1 @@ -178,7 +174,7 @@ CONTAINS found = .false. #ifdef CPP_MPI DO ikpt = 1, nkpti - IF (.NOT.found) THEN + IF (.NOT. found) THEN lower = ikpt found = .true. END IF @@ -186,7 +182,7 @@ CONTAINS #else found = .true. #endif - IF (.NOT.found) THEN + IF (.NOT. found) THEN upper = 0 END IF @@ -194,16 +190,16 @@ CONTAINS ! (acof,bcof,ccof) and APW-basis coefficients ! (a,b,bascofold_lo) at irred. kpoints - ALLOCATE(acof(dimension%neigd,0:dimension%lmd,atoms%nat),stat=ok) - IF (ok.NE.0) STOP 'gen_wavf: failure allocation acof' - ALLOCATE(bcof(dimension%neigd,0:dimension%lmd,atoms%nat),stat=ok) - IF (ok.NE.0) STOP 'gen_wavf: failure allocation bcof' - ALLOCATE(ccof(-atoms%llod:atoms%llod,dimension%neigd,atoms%nlod,atoms%nat),stat=ok) - IF (ok.NE.0) STOP 'gen_wavf: failure allocation ccof' - ALLOCATE (cmt(dimension%neigd,hybrid%maxlmindx,atoms%nat),stat=ok) - IF (ok.NE.0) STOP 'gen_wavf: Failure allocation cmt' - ALLOCATE (cmthlp(dimension%neigd,hybrid%maxlmindx,atoms%nat),stat=ok) - IF (ok.NE.0) STOP 'gen_wavf: failure allocation cmthlp' + ALLOCATE (acof(dimension%neigd, 0:dimension%lmd, atoms%nat), stat=ok) + IF (ok /= 0) STOP 'gen_wavf: failure allocation acof' + ALLOCATE (bcof(dimension%neigd, 0:dimension%lmd, atoms%nat), stat=ok) + IF (ok /= 0) STOP 'gen_wavf: failure allocation bcof' + ALLOCATE (ccof(-atoms%llod:atoms%llod, dimension%neigd, atoms%nlod, atoms%nat), stat=ok) + IF (ok /= 0) STOP 'gen_wavf: failure allocation ccof' + ALLOCATE (cmt(dimension%neigd, hybrid%maxlmindx, atoms%nat), stat=ok) + IF (ok /= 0) STOP 'gen_wavf: Failure allocation cmt' + ALLOCATE (cmthlp(dimension%neigd, hybrid%maxlmindx, atoms%nat), stat=ok) + IF (ok /= 0) STOP 'gen_wavf: failure allocation cmthlp' DO ikpt0 = lower, upper @@ -212,24 +208,24 @@ CONTAINS ! abcof calculates the wavefunction coefficients ! stored in acof,bcof,ccof lapw(ikpt0)%nmat = lapw(ikpt0)%nv(jsp) + atoms%nlotot - CALL abcof(input,atoms,sym,cell,lapw(ikpt0),hybrid%nbands(ikpt0),usdus,noco,jsp,&!hybdat%kveclo_eig(:,ikpt0),& - oneD,acof(: hybrid%nbands(ikpt0),:,:),bcof(: hybrid%nbands(ikpt0),:,:),& - ccof(:,: hybrid%nbands(ikpt0),:,:),zmat(ikpt0)) + CALL abcof(input, atoms, sym, cell, lapw(ikpt0), hybrid%nbands(ikpt0), usdus, noco, jsp, &!hybdat%kveclo_eig(:,ikpt0),& + oneD, acof(:hybrid%nbands(ikpt0), :, :), bcof(:hybrid%nbands(ikpt0), :, :), & + ccof(:, :hybrid%nbands(ikpt0), :, :), zmat(ikpt0)) ! call was ... - ! gpt(1,:,:,ikpt0),gpt(2,:,:,ikpt0),& - ! gpt(3,:,:,ikpt0),ngpt(:,ikpt0),&!k1hlp,k2hlp,k3hlp,nvhlp,& - ! ngpt(jsp,ikpt0)+nbands(ikpt0),z(:,:,ikpt0),&!nvhlp(jsp)+ & - ! &usdus,& - ! noco,& - ! jsp,kveclo_eig(:ikpt0),oneD,oneD,& - ! acof(:nbands(ikpt0),:,:),& - ! bcof(:nbands(ikpt0),:,:),ccof(:,:nbands(ikpt0),:,:) ) + ! gpt(1,:,:,ikpt0),gpt(2,:,:,ikpt0),& + ! gpt(3,:,:,ikpt0),ngpt(:,ikpt0),&!k1hlp,k2hlp,k3hlp,nvhlp,& + ! ngpt(jsp,ikpt0)+nbands(ikpt0),z(:,:,ikpt0),&!nvhlp(jsp)+ & + ! &usdus,& + ! noco,& + ! jsp,kveclo_eig(:ikpt0),oneD,oneD,& + ! acof(:nbands(ikpt0),:,:),& + ! bcof(:nbands(ikpt0),:,:),ccof(:,:nbands(ikpt0),:,:) ) ! MT wavefunction coefficients are calculated in a local coordinate system rotate them in the global one - CALL hyb_abcrot(hybrid,atoms,hybrid%nbands(ikpt0),sym,cell,oneD,acof(: hybrid%nbands(ikpt0),:,:),& - bcof(: hybrid%nbands(ikpt0),:,:),ccof(:,: hybrid%nbands(ikpt0),:,:)) + CALL hyb_abcrot(hybrid, atoms, hybrid%nbands(ikpt0), sym, cell, oneD, acof(:hybrid%nbands(ikpt0), :, :), & + bcof(:hybrid%nbands(ikpt0), :, :), ccof(:, :hybrid%nbands(ikpt0), :, :)) ! decorate acof, bcof, ccof with coefficient i**l and store them ! in the field cmt(neigd,nkpt,maxlmindx,nat), i.e. @@ -242,17 +238,17 @@ CONTAINS iatom = iatom + 1 indx = 0 DO l = 0, atoms%lmax(itype) - ll = l*(l+1) + ll = l*(l + 1) cdum = img**l ! determine number of local orbitals with quantum number l ! map returns the number of the local orbital of quantum ! number l in the list of all local orbitals of the atom type - idum = 0 + idum = 0 map_lo = 0 - IF (hybrid%nindx(l,itype).GT.2) THEN + IF (hybrid%nindx(l, itype) > 2) THEN DO j = 1, atoms%nlo(itype) - IF (atoms%llo(j,itype).EQ.l) THEN + IF (atoms%llo(j, itype) == l) THEN idum = idum + 1 map_lo(idum) = j END IF @@ -261,15 +257,15 @@ CONTAINS DO M = -l, l lm = ll + M - DO i = 1, hybrid%nindx(l,itype) + DO i = 1, hybrid%nindx(l, itype) indx = indx + 1 - IF(i.EQ.1) THEN - cmt(:,indx,iatom) = cdum * acof(:,lm,iatom) - ELSE IF (i.EQ.2) THEN - cmt(:,indx,iatom) = cdum * bcof(:,lm,iatom) + IF (i == 1) THEN + cmt(:, indx, iatom) = cdum*acof(:, lm, iatom) + ELSE IF (i == 2) THEN + cmt(:, indx, iatom) = cdum*bcof(:, lm, iatom) ELSE idum = i - 2 - cmt(:,indx,iatom) = cdum * ccof(M,:,map_lo(idum),iatom) + cmt(:, indx, iatom) = cdum*ccof(M, :, map_lo(idum), iatom) END IF END DO END DO @@ -278,34 +274,34 @@ CONTAINS END DO ! write cmt at irreducible k-points in direct-access file cmt - CALL write_cmt(cmt,ikpt0) - CALL zhlp%alloc(zmat(ikpt0)%l_real,zmat(ikpt0)%matsize1,zmat(ikpt0)%matsize2) - + CALL write_cmt(cmt, ikpt0) + CALL zhlp%alloc(zmat(ikpt0)%l_real, zmat(ikpt0)%matsize1, zmat(ikpt0)%matsize2) + IF (zhlp%l_real) THEN zhlp%data_r = zmat(ikpt0)%data_r ELSE zhlp%data_c = zmat(ikpt0)%data_c END IF - CALL write_z(zhlp,ikpt0) + CALL write_z(zhlp, ikpt0) ! generate wavefunctions coefficients at all k-points from ! irreducible k-points DO ikpt = 1, kpts%nkptf - IF ((kpts%bkp(ikpt).EQ.ikpt0).AND.(ikpt0.NE.ikpt)) THEN + IF ((kpts%bkp(ikpt) == ikpt0) .AND. (ikpt0 /= ikpt)) THEN iop = kpts%bksym(ikpt) - CALL waveftrafo_genwavf(cmthlp,zhlp%data_r,zhlp%data_c,cmt(:,:,:),zmat(1)%l_real,zmat(ikpt0)%data_r(:,:),& - zmat(ikpt0)%data_c(:,:),ikpt0,iop,atoms,hybrid,kpts,sym,jsp,dimension,& - hybrid%nbands(ikpt0),cell,lapw(ikpt0),lapw(ikpt),.true.) + CALL waveftrafo_genwavf(cmthlp, zhlp%data_r, zhlp%data_c, cmt(:, :, :), zmat(1)%l_real, zmat(ikpt0)%data_r(:, :), & + zmat(ikpt0)%data_c(:, :), ikpt0, iop, atoms, hybrid, kpts, sym, jsp, dimension, & + hybrid%nbands(ikpt0), cell, lapw(ikpt0), lapw(ikpt), .true.) - CALL write_cmt(cmthlp,ikpt) - CALL write_z(zhlp,ikpt) + CALL write_cmt(cmthlp, ikpt) + CALL write_z(zhlp, ikpt) END IF END DO !ikpt END DO !ikpt0 - DEALLOCATE(acof,bcof,ccof) - DEALLOCATE(cmt,cmthlp) + DEALLOCATE (acof, bcof, ccof) + DEALLOCATE (cmt, cmthlp) END SUBROUTINE gen_wavf diff --git a/hybrid/hf_setup.F90 b/hybrid/hf_setup.F90 index 2aa37030b7e93c2139a778bcddbb4e1f723c4afd..a3f5c5e64f814bdef286bd17c320701fe31628ff 100644 --- a/hybrid/hf_setup.F90 +++ b/hybrid/hf_setup.F90 @@ -8,291 +8,291 @@ MODULE m_hf_setup CONTAINS -SUBROUTINE hf_setup(hybrid,input,sym,kpts,DIMENSION,atoms,mpi,noco,cell,oneD,results,jsp,enpara,eig_id_hf,& - hybdat,it,l_real,vr0,eig_irr) - USE m_types - USE m_eig66_io - USE m_util - USE m_checkolap - USE m_read_core - USE m_gen_wavf - - IMPLICIT NONE - - TYPE(t_hybrid), INTENT(INOUT) :: hybrid - TYPE(t_kpts), INTENT(IN) :: kpts - TYPE(t_dimension), INTENT(IN) :: dimension - TYPE(t_atoms), INTENT(IN) :: atoms - TYPE(t_mpi), INTENT(IN) :: mpi - TYPE(t_noco), INTENT(IN) :: noco - TYPE(t_cell), INTENT(IN) :: cell - TYPE(t_oneD), INTENT(IN) :: oneD - TYPE(t_input), INTENT(IN) :: input - TYPE(t_sym), INTENT(IN) :: sym - TYPE(t_enpara), INTENT(IN) :: enpara - TYPE(t_results), INTENT(INOUT) :: results - TYPE(t_hybdat), INTENT(INOUT) :: hybdat - - INTEGER, INTENT(IN) :: it - INTEGER, INTENT(IN) :: jsp,eig_id_hf - REAL, INTENT(IN) :: vr0(:,:,:) - LOGICAL, INTENT(IN) :: l_real - - REAL, ALLOCATABLE, INTENT(OUT) :: eig_irr(:,:) - - ! local type variables - TYPE(t_lapw) :: lapw - TYPE(t_mat), ALLOCATABLE :: zmat(:) - - ! local scalars - INTEGER :: ok,nk,nrec1,i,j,ll,l1,l2,ng,itype,n,l,n1,n2,nn - INTEGER :: nbasfcn - - ! local arrays - - REAL, ALLOCATABLE :: basprod(:) - INTEGER :: degenerat(DIMENSION%neigd2+1,kpts%nkpt) - LOGICAL :: skip_kpt(kpts%nkpt) - INTEGER :: g(3) + SUBROUTINE hf_setup(hybrid, input, sym, kpts, DIMENSION, atoms, mpi, noco, cell, oneD, results, jsp, enpara, eig_id_hf, & + hybdat, it, l_real, vr0, eig_irr) + USE m_types + USE m_eig66_io + USE m_util + USE m_checkolap + USE m_read_core + USE m_gen_wavf + + IMPLICIT NONE + + TYPE(t_hybrid), INTENT(INOUT) :: hybrid + TYPE(t_kpts), INTENT(IN) :: kpts + TYPE(t_dimension), INTENT(IN) :: dimension + TYPE(t_atoms), INTENT(IN) :: atoms + TYPE(t_mpi), INTENT(IN) :: mpi + TYPE(t_noco), INTENT(IN) :: noco + TYPE(t_cell), INTENT(IN) :: cell + TYPE(t_oneD), INTENT(IN) :: oneD + TYPE(t_input), INTENT(IN) :: input + TYPE(t_sym), INTENT(IN) :: sym + TYPE(t_enpara), INTENT(IN) :: enpara + TYPE(t_results), INTENT(INOUT) :: results + TYPE(t_hybdat), INTENT(INOUT) :: hybdat + + INTEGER, INTENT(IN) :: it + INTEGER, INTENT(IN) :: jsp, eig_id_hf + REAL, INTENT(IN) :: vr0(:, :, :) + LOGICAL, INTENT(IN) :: l_real + + REAL, ALLOCATABLE, INTENT(OUT) :: eig_irr(:, :) + + ! local type variables + TYPE(t_lapw) :: lapw + TYPE(t_mat), ALLOCATABLE :: zmat(:) + + ! local scalars + INTEGER :: ok, nk, nrec1, i, j, ll, l1, l2, ng, itype, n, l, n1, n2, nn + INTEGER :: nbasfcn + + ! local arrays + + REAL, ALLOCATABLE :: basprod(:) + INTEGER :: degenerat(DIMENSION%neigd2 + 1, kpts%nkpt) + LOGICAL :: skip_kpt(kpts%nkpt) + INTEGER :: g(3) #if defined(CPP_MPI)&&defined(CPP_NEVER) - INTEGER :: sndreqd, rcvreqd, rcvreq(kpts%nkpt) - INTEGER(KIND=MPI_ADDRESS_KIND) :: addr - INTEGER :: ierr(3) - INCLUDE 'mpif.h' + INTEGER :: sndreqd, rcvreqd, rcvreq(kpts%nkpt) + INTEGER(KIND=MPI_ADDRESS_KIND) :: addr + INTEGER :: ierr(3) + INCLUDE 'mpif.h' #endif - skip_kpt=.FALSE. + skip_kpt = .FALSE. - IF(hybrid%l_calhf) THEN - ! Preparations for HF and hybrid functional calculation - CALL timestart("gen_bz and gen_wavf") + IF (hybrid%l_calhf) THEN + ! Preparations for HF and hybrid functional calculation + CALL timestart("gen_bz and gen_wavf") - ALLOCATE(zmat(kpts%nkptf),stat=ok) - IF(ok.NE.0) STOP 'eigen_hf: failure allocation z_c' - ALLOCATE (eig_irr(DIMENSION%neigd2,kpts%nkpt), stat=ok) - IF(ok.NE.0) STOP 'eigen_hf: failure allocation eig_irr' - ALLOCATE (hybdat%kveclo_eig(atoms%nlotot,kpts%nkpt), stat=ok) - IF(ok.NE.0) STOP 'eigen_hf: failure allocation hybdat%kveclo_eig' - eig_irr = 0 - hybdat%kveclo_eig = 0 + ALLOCATE (zmat(kpts%nkptf), stat=ok) + IF (ok /= 0) STOP 'eigen_hf: failure allocation z_c' + ALLOCATE (eig_irr(DIMENSION%neigd2, kpts%nkpt), stat=ok) + IF (ok /= 0) STOP 'eigen_hf: failure allocation eig_irr' + ALLOCATE (hybdat%kveclo_eig(atoms%nlotot, kpts%nkpt), stat=ok) + IF (ok /= 0) STOP 'eigen_hf: failure allocation hybdat%kveclo_eig' + eig_irr = 0 + hybdat%kveclo_eig = 0 - ! Reading the eig file - DO nk = 1, kpts%nkpt + ! Reading the eig file + DO nk = 1, kpts%nkpt #if defined(CPP_MPI)&&defined(CPP_NEVER) - ! jump to next k-point if this process is not present in communicator - IF (skip_kpt(nk)) CYCLE + ! jump to next k-point if this process is not present in communicator + IF (skip_kpt(nk)) CYCLE #endif - nrec1 = kpts%nkpt*(jsp-1) + nk - CALL lapw%init(input,noco,kpts,atoms,sym,nk,cell,sym%zrfs) - nbasfcn = MERGE(lapw%nv(1)+lapw%nv(2)+2*atoms%nlotot,lapw%nv(1)+atoms%nlotot,noco%l_noco) - CALL zMat(nk)%init(l_real,nbasfcn,dimension%neigd2) - CALL read_eig(eig_id_hf,nk,jsp,zmat=zMat(nk)) - eig_irr(:,nk) = results%eig(:,nk,jsp) - hybrid%ne_eig(nk) = results%neig(nk,jsp) - END DO - !Allocate further space - DO nk = kpts%nkpt+1, kpts%nkptf - nbasfcn = zMat(kpts%bkp(nk))%matsize1 - CALL zMat(nk)%init(l_real,nbasfcn,dimension%neigd2) - END DO - - !determine degenerate states at each k-point - ! - ! degenerat(i) =1 band i is not degenerat , - ! degenerat(i) =j band i has j-1 degenart states ( i, i+1, ..., i+j) - ! degenerat(i) =0 band i is degenerat, but is not the lowest band - ! of the group of degenerate states - IF (mpi%irank == 0) THEN - WRITE(6,*) - WRITE(6,'(A)') " k-point | number of occupied bands | maximal number of bands" - END IF - degenerat = 1 - hybrid%nobd = 0 - DO nk = 1, kpts%nkpt + nrec1 = kpts%nkpt*(jsp - 1) + nk + CALL lapw%init(input, noco, kpts, atoms, sym, nk, cell, sym%zrfs) + nbasfcn = MERGE(lapw%nv(1) + lapw%nv(2) + 2*atoms%nlotot, lapw%nv(1) + atoms%nlotot, noco%l_noco) + CALL zMat(nk)%init(l_real, nbasfcn, dimension%neigd2) + CALL read_eig(eig_id_hf, nk, jsp, zmat=zMat(nk)) + eig_irr(:, nk) = results%eig(:, nk, jsp) + hybrid%ne_eig(nk) = results%neig(nk, jsp) + END DO + !Allocate further space + DO nk = kpts%nkpt + 1, kpts%nkptf + nbasfcn = zMat(kpts%bkp(nk))%matsize1 + CALL zMat(nk)%init(l_real, nbasfcn, dimension%neigd2) + END DO + + !determine degenerate states at each k-point + ! + ! degenerat(i) =1 band i is not degenerat , + ! degenerat(i) =j band i has j-1 degenart states ( i, i+1, ..., i+j) + ! degenerat(i) =0 band i is degenerat, but is not the lowest band + ! of the group of degenerate states + IF (mpi%irank == 0) THEN + WRITE (6, *) + WRITE (6, '(A)') " k-point | number of occupied bands | maximal number of bands" + END IF + degenerat = 1 + hybrid%nobd = 0 + DO nk = 1, kpts%nkpt #if defined(CPP_MPI)&&defined(CPP_NEVER) - ! jump to next k-point if this k-point is not treated at this process - IF (skip_kpt(nk)) CYCLE + ! jump to next k-point if this k-point is not treated at this process + IF (skip_kpt(nk)) CYCLE #endif - DO i = 1, hybrid%ne_eig(nk) - DO j = i+1, hybrid%ne_eig(nk) - IF (ABS(results%eig(i,nk,jsp)-results%eig(j,nk,jsp)) < 1E-07) THEN !0.015 - degenerat(i,nk) = degenerat(i,nk) + 1 - END IF + DO i = 1, hybrid%ne_eig(nk) + DO j = i + 1, hybrid%ne_eig(nk) + IF (ABS(results%eig(i, nk, jsp) - results%eig(j, nk, jsp)) < 1E-07) THEN !0.015 + degenerat(i, nk) = degenerat(i, nk) + 1 + END IF + END DO END DO - END DO - DO i = 1, hybrid%ne_eig(nk) - IF((degenerat(i,nk).NE.1).OR.(degenerat(i,nk).NE.0)) degenerat(i+1:i+degenerat(i,nk)-1,nk) = 0 - END DO + DO i = 1, hybrid%ne_eig(nk) + IF ((degenerat(i, nk) /= 1) .OR. (degenerat(i, nk) /= 0)) degenerat(i + 1:i + degenerat(i, nk) - 1, nk) = 0 + END DO - ! set the size of the exchange matrix in the space of the wavefunctions + ! set the size of the exchange matrix in the space of the wavefunctions - hybrid%nbands(nk) = hybrid%bands1 - IF(hybrid%nbands(nk).GT.hybrid%ne_eig(nk)) THEN - IF (mpi%irank == 0) THEN - WRITE(*,*) ' maximum for hybrid%nbands is', hybrid%ne_eig(nk) - WRITE(*,*) ' increase energy window to obtain enough eigenvalues' - WRITE(*,*) ' set hybrid%nbands equal to hybrid%ne_eig' + hybrid%nbands(nk) = hybrid%bands1 + IF (hybrid%nbands(nk) > hybrid%ne_eig(nk)) THEN + IF (mpi%irank == 0) THEN + WRITE (*, *) ' maximum for hybrid%nbands is', hybrid%ne_eig(nk) + WRITE (*, *) ' increase energy window to obtain enough eigenvalues' + WRITE (*, *) ' set hybrid%nbands equal to hybrid%ne_eig' + END IF + hybrid%nbands(nk) = hybrid%ne_eig(nk) END IF - hybrid%nbands(nk) = hybrid%ne_eig(nk) - END IF - DO i = hybrid%nbands(nk)-1, 1, -1 - IF((degenerat(i,nk).GE.1).AND.(degenerat(i,nk)+i-1.NE.hybrid%nbands(nk))) THEN - hybrid%nbands(nk) = i + degenerat(i,nk) - 1 - EXIT - END IF - END DO + DO i = hybrid%nbands(nk) - 1, 1, -1 + IF ((degenerat(i, nk) >= 1) .AND. (degenerat(i, nk) + i - 1 /= hybrid%nbands(nk))) THEN + hybrid%nbands(nk) = i + degenerat(i, nk) - 1 + EXIT + END IF + END DO - DO i = 1,hybrid%ne_eig(nk) - IF(results%w_iks(i,nk,jsp).GT.0.0) hybrid%nobd(nk) = hybrid%nobd(nk) + 1 - END DO + DO i = 1, hybrid%ne_eig(nk) + IF (results%w_iks(i, nk, jsp) > 0.0) hybrid%nobd(nk) = hybrid%nobd(nk) + 1 + END DO - IF (hybrid%nobd(nk)>hybrid%nbands(nk)) THEN - WRITE(*,*) 'k-point: ', nk - WRITE(*,*) 'number of bands: ', hybrid%nbands(nk) - WRITE(*,*) 'number of occupied bands: ', hybrid%nobd(nk) - CALL judft_warn("More occupied bands than total no of bands!?") - hybrid%nbands(nk) = hybrid%nobd(nk) - END IF - PRINT *,"bands:",nk, hybrid%nobd(nk),hybrid%nbands(nk),hybrid%ne_eig(nk) - END DO + IF (hybrid%nobd(nk) > hybrid%nbands(nk)) THEN + WRITE (*, *) 'k-point: ', nk + WRITE (*, *) 'number of bands: ', hybrid%nbands(nk) + WRITE (*, *) 'number of occupied bands: ', hybrid%nobd(nk) + CALL judft_warn("More occupied bands than total no of bands!?") + hybrid%nbands(nk) = hybrid%nobd(nk) + END IF + PRINT *, "bands:", nk, hybrid%nobd(nk), hybrid%nbands(nk), hybrid%ne_eig(nk) + END DO #if defined(CPP_MPI)&&defined(CPP_NEVER) - ! send results for occupied bands to all processes - sndreqd = 0 ; rcvreqd = 0 - DO nk = 1,kpts%nkpt - IF ( skip_kpt(nk) ) THEN - rcvreqd = rcvreqd + 1 - CALL MPI_IRECV(hybrid%nobd(nk),1,MPI_INTEGER4, MPI_ANY_SOURCE,TAG_SNDRCV_HYBDAT%NOBD+nk, mpi,rcvreq(rcvreqd),ierr(1)) - ELSE - i = MOD( mpi%irank + 1, mpi%isize ) - DO WHILE ( i < mpi%irank .OR. i >= mpi%irank+1 ) - sndreqd = sndreqd + 1 - CALL MPI_ISSEND(hybrid%nobd(nk),1,MPI_INTEGER4,i, TAG_SNDRCV_HYBDAT%NOBD+nk,mpi, sndreq(sndreqd),ierr(1) ) - i = MOD( i + 1, mpi%isize ) - END DO - END IF - END DO - CALL MPI_WAITALL( rcvreqd, rcvreq, MPI_STATUSES_IGNORE, ierr(1) ) - ! Necessary to avoid compiler optimization - ! Compiler does not know that hybrid%nobd is modified in mpi_waitall - CALL MPI_GET_ADDRESS( hybrid%nobd, addr, ierr(1) ) - rcvreqd = 0 + ! send results for occupied bands to all processes + sndreqd = 0; rcvreqd = 0 + DO nk = 1, kpts%nkpt + IF (skip_kpt(nk)) THEN + rcvreqd = rcvreqd + 1 + CALL MPI_IRECV(hybrid%nobd(nk), 1, MPI_INTEGER4, MPI_ANY_SOURCE, TAG_SNDRCV_HYBDAT%NOBD + nk, mpi, rcvreq(rcvreqd), ierr(1)) + ELSE + i = MOD(mpi%irank + 1, mpi%isize) + DO WHILE (i < mpi%irank .OR. i >= mpi%irank + 1) + sndreqd = sndreqd + 1 + CALL MPI_ISSEND(hybrid%nobd(nk), 1, MPI_INTEGER4, i, TAG_SNDRCV_HYBDAT%NOBD + nk, mpi, sndreq(sndreqd), ierr(1)) + i = MOD(i + 1, mpi%isize) + END DO + END IF + END DO + CALL MPI_WAITALL(rcvreqd, rcvreq, MPI_STATUSES_IGNORE, ierr(1)) + ! Necessary to avoid compiler optimization + ! Compiler does not know that hybrid%nobd is modified in mpi_waitall + CALL MPI_GET_ADDRESS(hybrid%nobd, addr, ierr(1)) + rcvreqd = 0 #endif - ! spread hybrid%nobd from IBZ to whole BZ - DO nk = 1, kpts%nkptf - i = kpts%bkp(nk) - hybrid%nobd(nk) = hybrid%nobd(i) - END DO + ! spread hybrid%nobd from IBZ to whole BZ + DO nk = 1, kpts%nkptf + i = kpts%bkp(nk) + hybrid%nobd(nk) = hybrid%nobd(i) + END DO - ! generate eigenvectors z and MT coefficients from the previous iteration at all k-points - CALL gen_wavf(kpts%nkpt,kpts,it,sym,atoms,enpara%el0(:,:,jsp),enpara%ello0(:,:,jsp),cell,dimension,& - hybrid,vr0,hybdat,noco,oneD,mpi,input,jsp,zmat) + ! generate eigenvectors z and MT coefficients from the previous iteration at all k-points + CALL gen_wavf(kpts%nkpt, kpts, it, sym, atoms, enpara%el0(:, :, jsp), enpara%ello0(:, :, jsp), cell, dimension, & + hybrid, vr0, hybdat, noco, oneD, mpi, input, jsp, zmat) - ! generate core wave functions (-> core1/2(jmtd,hybdat%nindxc,0:lmaxc,ntype) ) - CALL corewf(atoms,jsp,input,DIMENSION,vr0,hybdat%lmaxcd,hybdat%maxindxc,mpi,& - hybdat%lmaxc,hybdat%nindxc,hybdat%core1,hybdat%core2,hybdat%eig_c) + ! generate core wave functions (-> core1/2(jmtd,hybdat%nindxc,0:lmaxc,ntype) ) + CALL corewf(atoms, jsp, input, DIMENSION, vr0, hybdat%lmaxcd, hybdat%maxindxc, mpi, & + hybdat%lmaxc, hybdat%nindxc, hybdat%core1, hybdat%core2, hybdat%eig_c) #if defined(CPP_MPI)&&defined(CPP_NEVER) - ! wait until all files are written in gen_wavf - CALL MPI_BARRIER(mpi%mpi_comm,ierr) + ! wait until all files are written in gen_wavf + CALL MPI_BARRIER(mpi%mpi_comm, ierr) #endif - ! check olap between core-basis/core-valence/basis-basis - CALL checkolap(atoms,hybdat,hybrid,kpts%nkpt,kpts,dimension,mpi,skip_kpt,& - input,sym,noco,cell,lapw,jsp) - - ! set up pointer pntgpt - - ! setup dimension of pntgpt - ALLOCATE(hybdat%pntgptd(3)) - hybdat%pntgptd = 0 - DO nk = 1, kpts%nkptf - CALL lapw%init(input,noco, kpts,atoms,sym,nk,cell,sym%zrfs) - hybdat%pntgptd(1) = MAXVAL( (/ ( ABS(lapw%k1(i,jsp)),i=1,lapw%nv(jsp)), hybdat%pntgptd(1) /) ) - hybdat%pntgptd(2) = MAXVAL( (/ ( ABS(lapw%k2(i,jsp)),i=1,lapw%nv(jsp)), hybdat%pntgptd(2) /) ) - hybdat%pntgptd(3) = MAXVAL( (/ ( ABS(lapw%k3(i,jsp)),i=1,lapw%nv(jsp)), hybdat%pntgptd(3) /) ) - END DO - - ALLOCATE(hybdat%pntgpt(-hybdat%pntgptd(1):hybdat%pntgptd(1), -hybdat%pntgptd(2):hybdat%pntgptd(2),& - -hybdat%pntgptd(3):hybdat%pntgptd(3),kpts%nkptf),stat=ok) - IF(ok.NE.0) STOP 'eigen_hf: failure allocation pntgpt' - hybdat%pntgpt = 0 - DO nk = 1, kpts%nkptf - CALL lapw%init(input,noco,kpts,atoms,sym,nk,cell,sym%zrfs) - DO i = 1, lapw%nv(jsp) - g = (/lapw%k1(i,jsp),lapw%k2(i,jsp),lapw%k3(i,jsp)/) - hybdat%pntgpt(g(1),g(2),g(3),nk) = i + ! check olap between core-basis/core-valence/basis-basis + CALL checkolap(atoms, hybdat, hybrid, kpts%nkpt, kpts, dimension, mpi, skip_kpt, & + input, sym, noco, cell, lapw, jsp) + + ! set up pointer pntgpt + + ! setup dimension of pntgpt + ALLOCATE (hybdat%pntgptd(3)) + hybdat%pntgptd = 0 + DO nk = 1, kpts%nkptf + CALL lapw%init(input, noco, kpts, atoms, sym, nk, cell, sym%zrfs) + hybdat%pntgptd(1) = MAXVAL((/(ABS(lapw%k1(i, jsp)), i=1, lapw%nv(jsp)), hybdat%pntgptd(1)/)) + hybdat%pntgptd(2) = MAXVAL((/(ABS(lapw%k2(i, jsp)), i=1, lapw%nv(jsp)), hybdat%pntgptd(2)/)) + hybdat%pntgptd(3) = MAXVAL((/(ABS(lapw%k3(i, jsp)), i=1, lapw%nv(jsp)), hybdat%pntgptd(3)/)) + END DO + + ALLOCATE (hybdat%pntgpt(-hybdat%pntgptd(1):hybdat%pntgptd(1), -hybdat%pntgptd(2):hybdat%pntgptd(2), & + -hybdat%pntgptd(3):hybdat%pntgptd(3), kpts%nkptf), stat=ok) + IF (ok /= 0) STOP 'eigen_hf: failure allocation pntgpt' + hybdat%pntgpt = 0 + DO nk = 1, kpts%nkptf + CALL lapw%init(input, noco, kpts, atoms, sym, nk, cell, sym%zrfs) + DO i = 1, lapw%nv(jsp) + g = (/lapw%k1(i, jsp), lapw%k2(i, jsp), lapw%k3(i, jsp)/) + hybdat%pntgpt(g(1), g(2), g(3), nk) = i + END DO END DO - END DO - - ALLOCATE (basprod(atoms%jmtd),stat=ok) - IF(ok.NE.0)STOP 'eigen_hf: failure allocation basprod' - ALLOCATE (hybdat%prodm(hybrid%maxindxm1,hybrid%maxindxp1,0:hybrid%maxlcutm1,atoms%ntype), stat=ok) - IF(ok.NE.0) STOP 'eigen_hf: failure allocation hybdat%prodm' - ALLOCATE (hybdat%prod(hybrid%maxindxp1,0:hybrid%maxlcutm1,atoms%ntype),stat=ok) - IF(ok.NE.0) STOP 'eigen_hf: failure allocation hybdat%prod' - basprod = 0 ; hybdat%prodm = 0 ; hybdat%prod%l1 = 0 ; hybdat%prod%l2 = 0 - hybdat%prod%n1 = 0 ; hybdat%prod%n2 = 0 - ALLOCATE(hybdat%nindxp1(0:hybrid%maxlcutm1,atoms%ntype)) - hybdat%nindxp1 = 0 - DO itype = 1,atoms%ntype - ng = atoms%jri(itype) - DO l2 = 0,MIN(atoms%lmax(itype),hybrid%lcutwf(itype)) - ll = l2 - DO l1 = 0,ll - IF(ABS(l1-l2).LE.hybrid%lcutm1(itype)) THEN - DO n2 = 1,hybrid%nindx(l2,itype) - nn = hybrid%nindx(l1,itype) - IF(l1.EQ.l2) nn = n2 - DO n1 = 1,nn - ! Calculate all basis-function hybdat%products to obtain - ! the overlaps with the hybdat%product-basis functions (hybdat%prodm) - basprod(:ng) = (hybdat%bas1(:ng,n1,l1,itype)*hybdat%bas1(:ng,n2,l2,itype) +& - hybdat%bas2(:ng,n1,l1,itype)*hybdat%bas2(:ng,n2,l2,itype)) / atoms%rmsh(:ng,itype) - DO l = ABS(l1-l2),MIN(hybrid%lcutm1(itype),l1+l2) - IF(MOD(l1+l2+l,2).EQ.0) THEN - hybdat%nindxp1(l,itype) = hybdat%nindxp1(l,itype) + 1 - n = hybdat%nindxp1(l,itype) - hybdat%prod(n,l,itype)%l1 = l1 - hybdat%prod(n,l,itype)%l2 = l2 - hybdat%prod(n,l,itype)%n1 = n1 - hybdat%prod(n,l,itype)%n2 = n2 - DO i = 1,hybrid%nindxm1(l,itype) - hybdat%prodm(i,n,l,itype) = intgrf(basprod(:ng)*hybrid%basm1(:ng,i,l,itype),atoms%jri,& - atoms%jmtd,atoms%rmsh,atoms%dx,atoms%ntype,itype,hybdat%gridf) - END DO - END IF + + ALLOCATE (basprod(atoms%jmtd), stat=ok) + IF (ok /= 0) STOP 'eigen_hf: failure allocation basprod' + ALLOCATE (hybdat%prodm(hybrid%maxindxm1, hybrid%maxindxp1, 0:hybrid%maxlcutm1, atoms%ntype), stat=ok) + IF (ok /= 0) STOP 'eigen_hf: failure allocation hybdat%prodm' + ALLOCATE (hybdat%prod(hybrid%maxindxp1, 0:hybrid%maxlcutm1, atoms%ntype), stat=ok) + IF (ok /= 0) STOP 'eigen_hf: failure allocation hybdat%prod' + basprod = 0; hybdat%prodm = 0; hybdat%prod%l1 = 0; hybdat%prod%l2 = 0 + hybdat%prod%n1 = 0; hybdat%prod%n2 = 0 + ALLOCATE (hybdat%nindxp1(0:hybrid%maxlcutm1, atoms%ntype)) + hybdat%nindxp1 = 0 + DO itype = 1, atoms%ntype + ng = atoms%jri(itype) + DO l2 = 0, MIN(atoms%lmax(itype), hybrid%lcutwf(itype)) + ll = l2 + DO l1 = 0, ll + IF (ABS(l1 - l2) <= hybrid%lcutm1(itype)) THEN + DO n2 = 1, hybrid%nindx(l2, itype) + nn = hybrid%nindx(l1, itype) + IF (l1 == l2) nn = n2 + DO n1 = 1, nn + ! Calculate all basis-function hybdat%products to obtain + ! the overlaps with the hybdat%product-basis functions (hybdat%prodm) + basprod(:ng) = (hybdat%bas1(:ng, n1, l1, itype)*hybdat%bas1(:ng, n2, l2, itype) + & + hybdat%bas2(:ng, n1, l1, itype)*hybdat%bas2(:ng, n2, l2, itype))/atoms%rmsh(:ng, itype) + DO l = ABS(l1 - l2), MIN(hybrid%lcutm1(itype), l1 + l2) + IF (MOD(l1 + l2 + l, 2) == 0) THEN + hybdat%nindxp1(l, itype) = hybdat%nindxp1(l, itype) + 1 + n = hybdat%nindxp1(l, itype) + hybdat%prod(n, l, itype)%l1 = l1 + hybdat%prod(n, l, itype)%l2 = l2 + hybdat%prod(n, l, itype)%n1 = n1 + hybdat%prod(n, l, itype)%n2 = n2 + DO i = 1, hybrid%nindxm1(l, itype) + hybdat%prodm(i, n, l, itype) = intgrf(basprod(:ng)*hybrid%basm1(:ng, i, l, itype), atoms%jri, & + atoms%jmtd, atoms%rmsh, atoms%dx, atoms%ntype, itype, hybdat%gridf) + END DO + END IF + END DO END DO END DO - END DO - END IF + END IF + END DO END DO END DO - END DO - DEALLOCATE(basprod) - CALL timestop("gen_bz and gen_wavf") + DEALLOCATE (basprod) + CALL timestop("gen_bz and gen_wavf") - ELSE IF (hybrid%l_hybrid ) THEN ! hybrid%l_calhf is false + ELSE IF (hybrid%l_hybrid) THEN ! hybrid%l_calhf is false + + !DO nk = n_start,kpts%nkpt,n_stride + DO nk = 1, kpts%nkpt, 1 + hybrid%ne_eig(nk) = results%neig(nk, jsp) + hybrid%nobd(nk) = COUNT(results%w_iks(:hybrid%ne_eig(nk), nk, jsp) > 0.0) + END DO - !DO nk = n_start,kpts%nkpt,n_stride - DO nk = 1, kpts%nkpt, 1 - hybrid%ne_eig(nk) = results%neig(nk,jsp) - hybrid%nobd(nk) = COUNT(results%w_iks(:hybrid%ne_eig(nk),nk,jsp) > 0.0) - END DO - - hybrid%maxlmindx = MAXVAL((/ ( SUM( (/ (hybrid%nindx(l,itype)*(2*l+1), l=0,atoms%lmax(itype)) /) ),itype=1,atoms%ntype) /)) - hybrid%nbands = MIN(hybrid%bands1,DIMENSION%neigd) + hybrid%maxlmindx = MAXVAL((/(SUM((/(hybrid%nindx(l, itype)*(2*l + 1), l=0, atoms%lmax(itype))/)), itype=1, atoms%ntype)/)) + hybrid%nbands = MIN(hybrid%bands1, DIMENSION%neigd) - ENDIF ! hybrid%l_calhf + ENDIF ! hybrid%l_calhf -END SUBROUTINE hf_setup + END SUBROUTINE hf_setup END MODULE m_hf_setup diff --git a/hybrid/hsefunctional.F90 b/hybrid/hsefunctional.F90 index f445362612673bf90cc68cb7df32004b16605c32..f8d18ec6b6c53dd55bdbfd3683686f154a3221fa 100644 --- a/hybrid/hsefunctional.F90 +++ b/hybrid/hsefunctional.F90 @@ -8,1071 +8,1069 @@ ! within a FLAPW framework ! Author: M. Schlipf 2009 MODULE m_hsefunctional - USE m_judft - IMPLICIT NONE + USE m_judft + IMPLICIT NONE #ifdef __PGI - REAL,EXTERNAL ::erfc + REAL, EXTERNAL ::erfc #endif - ! Constant omega of the HSE exchange functional + ! Constant omega of the HSE exchange functional REAL, PARAMETER :: omega_HSE = 0.11 + ! Constant for the maximum number of G points + INTEGER, PARAMETER :: maxNoGPts = 50 - ! Constant for the maximum number of G points - INTEGER, PARAMETER :: maxNoGPts = 50 - - ! these arrays are calculated once and then reused - LOGICAL, ALLOCATABLE :: already_known(:) - REAL, ALLOCATABLE :: known_potential(:,:) + ! these arrays are calculated once and then reused + LOGICAL, ALLOCATABLE :: already_known(:) + REAL, ALLOCATABLE :: known_potential(:, :) #ifdef CPP_INVERSION - REAL, ALLOCATABLE :: known_fourier_trafo(:,:,:) + REAL, ALLOCATABLE :: known_fourier_trafo(:, :, :) #else - COMPLEX, ALLOCATABLE :: known_fourier_trafo(:,:,:) + COMPLEX, ALLOCATABLE :: known_fourier_trafo(:, :, :) #endif - ! variables needed for fourier transformation - PRIVATE already_known, known_potential, known_fourier_trafo + ! variables needed for fourier transformation + PRIVATE already_known, known_potential, known_fourier_trafo - ! functions needed internally - PRIVATE calcYlm, calcSphBes, my_dot_product3x1, my_dot_product3x3, my_dot_product4x1, & - my_dot_product4x4, my_sum3d, my_sum4d, gPtsSummation, approximateIntegral, generateIntegrals, & - integrateY1ExpErfc, integrateY3ExpErfc, integrateY5ExpErfc, integrateY7ExpErfc, & - integrateY9ExpErfc, calculateF, calculateG, calculateH + ! functions needed internally + PRIVATE calcYlm, calcSphBes, my_dot_product3x1, my_dot_product3x3, my_dot_product4x1, & + my_dot_product4x4, my_sum3d, my_sum4d, gPtsSummation, approximateIntegral, generateIntegrals, & + integrateY1ExpErfc, integrateY3ExpErfc, integrateY5ExpErfc, integrateY7ExpErfc, & + integrateY9ExpErfc, calculateF, calculateG, calculateH - INTERFACE my_sum - MODULE PROCEDURE my_sum3d, my_sum4d - END INTERFACE + INTERFACE my_sum + MODULE PROCEDURE my_sum3d, my_sum4d + END INTERFACE - INTERFACE my_dot_product - MODULE PROCEDURE my_dot_product4x1, my_dot_product4x4, my_dot_product3x1, my_dot_product3x3 - END INTERFACE + INTERFACE my_dot_product + MODULE PROCEDURE my_dot_product4x1, my_dot_product4x4, my_dot_product3x1, my_dot_product3x3 + END INTERFACE - INTERFACE gPtsSummation - MODULE PROCEDURE crc_gPtsSummation, rrr_gPtsSummation - END INTERFACE + INTERFACE gPtsSummation + MODULE PROCEDURE crc_gPtsSummation, rrr_gPtsSummation + END INTERFACE CONTAINS - ! Calculate the enhancement factor of the HSE03 functional - ! References: - ! [1] Heyd, Scuseria, Ernzerhof: Hybrid functionals based on a screened Coulomb potential, - ! J. Chem. Phys. 118 (2003) 8207-8215 - ! [2] Heyd, Scuseria: Assessment and validation of a screened Coulomb hybrid density - ! functional, J. Chem. Phys. 120 (2004) 7274-7280 - ! [3] Ernzerhof, Perdew: Generalized gradient approximation to the angle- and system- - ! averaged exchange hole, J. Chem. Phys. 109 (1998) 3313-3319 - ! Input: kF - kF = (3 pi^2 rho) ** 1/3 - ! s_inp - reduced gradient = |grad rho| / 2 kF rho - ! Output: F_x - HSE03 enhancement factor - ! dFx_ds - derivative of this factor with respect to s - ! d2Fx_ds2 - second derivative with respect to s - SUBROUTINE calculateEnhancementFactor(kF, s_inp, F_x, dFx_Ds, d2Fx_Ds2, dFx_dkF, d2Fx_dsdkF) - - - IMPLICIT NONE - - REAL, INTENT(IN) :: kF, s_inp - REAL, INTENT(OUT) :: F_x, dFx_ds, d2Fx_ds2 - REAL, INTENT(OUT) :: dFx_dkF, d2Fx_dsdkF - - ! Helper variables - REAL :: r1_kF, & ! 1 / kF - omega_kF,omega_kF_Sqr, & ! omega_HSE / kF, (omega/kF)^2 - s, s2, & ! reduced gradient s and s^2 - s_si2, r2s_si3, r6s_si4, & ! quotient s_chg / s_inp^n (n = 2,3,4) - F, G, H, & ! results of the functions F, G, and H defined in [3] - Hs2, dHs2_ds, d2Hs2_ds2, & ! H * s^2 and derivatives with respect to s - Fs2, dFs2_ds, d2Fs2_ds2, & ! F * s^2 and derivatives with respect to s - dGs2_ds, d2Gs2_ds2, & ! derivatives with respect to s of G s^2 - C_term, dCt_ds, d2Ct_ds2, & ! C * (1 + F(s) s^2) and derivatives with respect to s - E_term, dEt_ds, d2Et_ds2, & ! E * (1 + G(s) s^2) and derivatives with respect to s - D_term ! D + H s^2 - - ! integrals of y^n Exp(-ay^2) Erfc(w/k y) for n = 1, 3, 5, 7, 9 - REAL :: intY1ExpErfc,intY3ExpErfc,intY5ExpErfc,intY7ExpErfc,intY9ExpErfc - ! integrals of 2/sqrt(pi) y^n Exp(-arg*y^2) for n = 2, 4, 6, 8 - REAL :: r1_arg, intY2Gauss, intY4Gauss, intY6Gauss, intY8Gauss - - ! approximation of the not analytical part of the integral and derivatives - REAL :: appInt, dAppInt_ds, d2AppInt_ds2 - REAL :: dAppInt_dkF, d2AppInt_dsdkF - - REAL, PARAMETER :: r8_9 = 8.0/9.0 ! 8/9 - REAL, PARAMETER :: & ! Parameters of the exchange hole as defined in [3] - B = -0.37170836, C = -0.077215461,& - D = 0.57786348, E = -0.051955731 - - REAL, PARAMETER :: & ! Correction of the reduced gradient to ensure Lieb-Oxford bound [2] + ! Calculate the enhancement factor of the HSE03 functional + ! References: + ! [1] Heyd, Scuseria, Ernzerhof: Hybrid functionals based on a screened Coulomb potential, + ! J. Chem. Phys. 118 (2003) 8207-8215 + ! [2] Heyd, Scuseria: Assessment and validation of a screened Coulomb hybrid density + ! functional, J. Chem. Phys. 120 (2004) 7274-7280 + ! [3] Ernzerhof, Perdew: Generalized gradient approximation to the angle- and system- + ! averaged exchange hole, J. Chem. Phys. 109 (1998) 3313-3319 + ! Input: kF - kF = (3 pi^2 rho) ** 1/3 + ! s_inp - reduced gradient = |grad rho| / 2 kF rho + ! Output: F_x - HSE03 enhancement factor + ! dFx_ds - derivative of this factor with respect to s + ! d2Fx_ds2 - second derivative with respect to s + SUBROUTINE calculateEnhancementFactor(kF, s_inp, F_x, dFx_Ds, d2Fx_Ds2, dFx_dkF, d2Fx_dsdkF) + + IMPLICIT NONE + + REAL, INTENT(IN) :: kF, s_inp + REAL, INTENT(OUT) :: F_x, dFx_ds, d2Fx_ds2 + REAL, INTENT(OUT) :: dFx_dkF, d2Fx_dsdkF + + ! Helper variables + REAL :: r1_kF, & ! 1 / kF + omega_kF, omega_kF_Sqr, & ! omega_HSE / kF, (omega/kF)^2 + s, s2, & ! reduced gradient s and s^2 + s_si2, r2s_si3, r6s_si4, & ! quotient s_chg / s_inp^n (n = 2,3,4) + F, G, H, & ! results of the functions F, G, and H defined in [3] + Hs2, dHs2_ds, d2Hs2_ds2, & ! H * s^2 and derivatives with respect to s + Fs2, dFs2_ds, d2Fs2_ds2, & ! F * s^2 and derivatives with respect to s + dGs2_ds, d2Gs2_ds2, & ! derivatives with respect to s of G s^2 + C_term, dCt_ds, d2Ct_ds2, & ! C * (1 + F(s) s^2) and derivatives with respect to s + E_term, dEt_ds, d2Et_ds2, & ! E * (1 + G(s) s^2) and derivatives with respect to s + D_term ! D + H s^2 + + ! integrals of y^n Exp(-ay^2) Erfc(w/k y) for n = 1, 3, 5, 7, 9 + REAL :: intY1ExpErfc, intY3ExpErfc, intY5ExpErfc, intY7ExpErfc, intY9ExpErfc + ! integrals of 2/sqrt(pi) y^n Exp(-arg*y^2) for n = 2, 4, 6, 8 + REAL :: r1_arg, intY2Gauss, intY4Gauss, intY6Gauss, intY8Gauss + + ! approximation of the not analytical part of the integral and derivatives + REAL :: appInt, dAppInt_ds, d2AppInt_ds2 + REAL :: dAppInt_dkF, d2AppInt_dsdkF + + REAL, PARAMETER :: r8_9 = 8.0/9.0 ! 8/9 + REAL, PARAMETER :: & ! Parameters of the exchange hole as defined in [3] + B = -0.37170836, C = -0.077215461, & + D = 0.57786348, E = -0.051955731 + + REAL, PARAMETER :: & ! Correction of the reduced gradient to ensure Lieb-Oxford bound [2] s_thresh = 8.3, s_max = 8.572844, s_chg = 18.796223 - LOGICAL :: correction ! Has the value of s been corrected - - ! If a large value of s would violate the Lieb-Oxford bound, the value of s is reduced, - ! so that this condition is fullfilled - correction = s_inp > s_thresh - IF (correction) THEN - s_si2 = s_chg / (s_inp * s_inp) - s = s_max - s_si2 - ELSE - s = s_inp - END IF - - ! Calculate different helper variables - r1_kF = 1.0 / kF - omega_kF = omega_hse * r1_kF !was omega_VHSE() - omega_kF_Sqr = omega_kF * omega_kF - - ! calculate the functions H and F in [3] and its derivatives - CALL calculateH(s, H, dHs2_ds, d2Hs2_ds2) - CALL calculateF(s, H, dHs2_ds, d2Hs2_ds2, F, dFs2_ds, d2Fs2_ds2) - s2 = s * s - Hs2 = H * s2 - Fs2 = F * s2 - CALL calculateG(s2, Fs2, dFs2_ds, d2Fs2_ds2, Hs2, dHs2_ds, d2Hs2_ds2,& !Input - G, dGs2_ds, d2Gs2_ds2) !Output - - C_term = C * (1 + s2 * F) - dCt_ds = C * dFs2_ds - d2Ct_ds2 = C * d2Fs2_ds2 - E_term = E * (1 + s2 * G) - dEt_ds = E * dGs2_ds - d2Et_ds2 = E * d2Gs2_ds2 - D_term = D + Hs2 - - ! approximate the integral using an expansion of the error function (cf. [2]) - CALL approximateIntegral(omega_kF, Hs2, D_term, dHs2_ds, d2Hs2_ds2,& !Input - appInt, dAppInt_ds, d2AppInt_ds2, dAppInt_dkF, d2AppInt_dsdkF) !Output - - ! Calculate the integrals - ! - ! inf - ! / 2 2 / \ - ! | n -(D+H(s)s ) y | omega | - ! | dy y e Erfc| ----- y | - ! | | k | - ! / \ F / - ! 0 - ! for n = 1, 3, 5, 7, and 9 - ! - intY1ExpErfc = integrateY1ExpErfc(omega_kf, omega_kf_Sqr, D_term) - intY3ExpErfc = integrateY3ExpErfc(omega_kf, omega_kf_Sqr, D_term) - intY5ExpErfc = integrateY5ExpErfc(omega_kf, omega_kf_Sqr, D_term) - intY7ExpErfc = integrateY7ExpErfc(omega_kf, omega_kf_Sqr, D_term) - intY9ExpErfc = integrateY9ExpErfc(omega_kf, omega_kf_Sqr, D_term) - - ! Calculate the integrals - ! - ! inf - ! / / 2 \ - ! 2 | n | 2 2 omega 2 | - ! ----- | dy y Exp| -(D+H(s)s ) y - ------ y | - ! ____ | | k ^2 | - ! V Pi / \ F / - ! 0 - ! for n = 2, 4, 6, 8 - ! - r1_arg = 1.0 / (D_term + omega_kF_Sqr) - intY2Gauss = 0.5 * SQRT(r1_arg) * r1_arg - intY4Gauss = 1.5 * intY2Gauss * r1_arg - intY6Gauss = 2.5 * intY4Gauss * r1_arg - intY8Gauss = 3.5 * intY6Gauss * r1_arg - - ! Calculate the integral - ! inf - ! / / \ - ! | | omega | - ! | dy y J(s,y) Erfc| ----- y | - ! | | k | - ! / \ F / - ! 0 - ! where J(s, y) is the exchange hole defined in [3] - ! the exchange factor is proportional to this integral - F_x = - r8_9 * (appInt + B * intY1ExpErfc + C_term * intY3ExpErfc + E_term * intY5ExpErfc) - - ! Calculate the derivatives with respect to s using that the derivatative of the integral - ! yields higher orders of the same kind of integral intY1 -> -intY3 -> intY5 ... times - ! the derivative of the exponent - dFx_ds = -r8_9 * (dAppInt_ds - (B * intY3ExpErfc + C_term * intY5ExpErfc + E_term * intY7ExpErfc) * dHs2_ds & - + dCt_ds * intY3ExpErfc + dEt_ds * intY5ExpErfc) - d2Fx_ds2 = -r8_9 * (d2AppInt_ds2 + (B * intY5ExpErfc + C_term * intY7ExpErfc + E_term * intY9ExpErfc) * dHs2_ds**2 & - - (B * intY3ExpErfc + C_term * intY5ExpErfc + E_term * intY7ExpErfc) * d2Hs2_ds2 & - - 2.0 * (dCt_ds * intY5ExpErfc + dEt_ds * intY7ExpErfc) * dHs2_ds & - + d2Ct_ds2 * intY3ExpErfc + d2Et_ds2 * intY5ExpErfc) - - dFx_dkF = -r8_9 * r1_kF * (omega_kF * (B * intY2Gauss + C_term * intY4Gauss + E_term * intY6Gauss) + dAppInt_dkF) - d2Fx_dsdkF = -r8_9 * r1_kF * ( d2AppInt_dsdkF + omega_kF * ( dCt_ds * intY4Gauss + dEt_ds * intY6Gauss & - - (B * intY4Gauss + C_term * intY6Gauss + E_term * intY8Gauss) * dHs2_ds ) ) - - ! Correction to the derivatives, if s_inp > s_thresh - IF (correction) THEN - r2s_si3 = 2.0 * s_si2 / s_inp - r6s_si4 = 3.0 * r2s_si3 / s_inp - d2Fx_ds2 = d2Fx_ds2 * r2s_si3**2 - dFx_ds * r6s_si4 - d2Fx_dsdkF = d2Fx_dsdkF * r2s_si3 - dFx_ds = dFx_ds * r2s_si3 - END IF - - END SUBROUTINE calculateEnhancementFactor - - ! Approximation for the first part of the exchange hole integral - ! Calculated using the algorithm described in [2]. - ! Additionally the first and second derivative of this approximation with - ! respect to s are calculated - ! Input: omega_kF - omega / kF - ! Hs2 - H s^2 - ! D_Hs2 - D + H s^2 - ! dHs2_ds - d (H s^2) / ds - ! d2Hs2_ds2 - d^2 (H s^2) / ds^2 - ! Output: appInt - approximation for one part of the exchange hole integral - ! dAppInt_ds - first derivative with respect to s - ! d2AppInt_ds2 - second derivative with respect to s - ! dAppInt_dkF - first derivative with respect to kF - ! d2AppInt_dsdkF - mixed derivative with respect to s and kF - SUBROUTINE approximateIntegral(omega_kF, Hs2, D_Hs2, dHs2_ds, d2Hs2_ds2,& - appInt, dAppInt_ds, d2AppInt_ds2, dAppInt_dkF, d2AppInt_dsdkF) - - USE m_exponential_integral, ONLY: calculateExponentialIntegral, gauss_laguerre - - IMPLICIT NONE - - REAL, INTENT(IN) :: omega_kF, Hs2, D_Hs2, dHs2_ds, d2Hs2_ds2 - REAL, INTENT(OUT) :: appInt, dAppInt_ds, d2AppInt_ds2 - REAL, INTENT(OUT) :: dAppInt_dkF, d2AppInt_dsdkF - - REAL :: w2, bw, r2bw, bw_Hs2, bw_D_Hs2 - ! variables for temporary storage of the integrals, the prefactors and the dot_product - REAL :: integral(0:12), a_omegaI(0:8), aI_omegaI(0:8), dotpr, dotpr2 - INTEGER :: i - - REAL :: r2w2, r4w2, r2w2_Hs2, r2w2_D_Hs2, arg, exp_e1, dAppInt_dh, d2AppInt_dh2 - - ! parameters of the erfc fit as given in [2] - REAL, PARAMETER :: A_2 = 0.5080572, scale = 1.125 / A_2,& - a(1:8) = (/-1.128223946706117, 1.452736265762971, & - -1.243162299390327, 0.971824836115601, & - -0.568861079687373, 0.246880514820192, & - -0.065032363850763, 0.008401793031216 /),& - b = 1.455915450052607, cutoff = 14.0 - - ! Calculate helper variables - w2 = omega_kF**2 - bw = b * w2 - r2bw = 2.0 * bw - bw_Hs2 = bw + Hs2 - bw_D_Hs2 = bw + D_Hs2 - - IF (bw_Hs2 < cutoff) THEN - ! integrate the erfc approximation times the exchange hole - CALL generateIntegrals(bw_Hs2, bw_D_Hs2, integral) - - ! combine the solutions of the integrals with the appropriate prefactors - a_omegaI(0) = 1.0 - a_omegaI(1:8) = a * (/ (omega_kF**i,i=1,8) /) - aI_omegaI = (/ (i * a_omegaI(i),i=0,8) /) - appInt = DOT_PRODUCT(a_omegaI, integral(0: 8)) - dotpr = DOT_PRODUCT(a_omegaI, integral(2:10)) - dAppInt_ds = -dotpr * dHs2_ds - dAppInt_dkF = r2bw * dotpr - DOT_PRODUCT(aI_omegaI, integral(0:8)) - dotpr2 = DOT_PRODUCT(a_omegaI, integral(4:12)) - d2AppInt_ds2 = dotpr2 * dHs2_ds**2 - dotpr * d2Hs2_ds2 - d2AppInt_dsdkF = -(r2bw * dotpr2 - DOT_PRODUCT(aI_omegaI, integral(2:10))) * dHs2_ds - ELSE - r2w2 = 2.0 * w2 - r4w2 = 4.0 * w2 - r2w2_Hs2 = r2w2 + Hs2 - r2w2_D_Hs2 = r2w2 + D_Hs2 - arg = scale * r2w2_Hs2 - exp_e1 = gauss_laguerre(arg) - appInt = A_2 * (LOG(r2w2_Hs2 / r2w2_D_Hs2) + exp_e1) - dAppInt_dh = -A_2 / r2w2_D_Hs2 + 1.125 * exp_e1 - d2AppInt_dh2 = 1.125 / r2w2_Hs2 - A_2 / r2w2_D_Hs2**2 - 1.265625 / A_2 * exp_e1 - dAppInt_ds = dAppInt_dh * dHs2_ds - dAppInt_dkF = -dAppInt_dh * r4w2 - d2AppInt_ds2 = d2AppInt_dh2 * dHs2_ds**2 + dAppInt_dh * d2Hs2_ds2 - d2AppInt_dsdkF = d2AppInt_dh2 * dHs2_ds * r4w2 - END IF - - END SUBROUTINE approximateIntegral - - ! Generate the integrals for n = 0, 1, ..., 12 - ! - ! inf - ! / / 2 \ / \ - ! | n | A -Dy A | | / omega 2\ 2 | - ! | dy y | --- e - -------------- | Exp| - ( b ----- + H s ) y | - ! | | y / 4 2\ | | \ k / | - ! / \ y( 1 + - Ay ) / \ F / - ! 0 \ 9 / - ! - ! Input: bw_Hs2 - b (omega/kF)^2 + H s^2 - ! bw_D_Hs2 - b (omega/kF)^2 + D + H s^2 - ! Output: integral - array with the calculated integrals - ! To simplify the calculation use integral(n+2) = - d(integral(n))/d(b omega/kF) - SUBROUTINE generateIntegrals(bw_Hs2, bw_D_Hs2, integral) - USE m_exponential_integral, ONLY: calculateExponentialIntegral, gauss_laguerre, series_laguerre - USE m_constants - IMPLICIT NONE - - REAL, INTENT(IN) :: bw_Hs2, bw_D_Hs2 - REAL, INTENT(OUT) :: integral(0:12) - - ! Helper variables - REAL :: bw_Hs2_Sqr, bw_Hs2_Cub, sqrt_bw_Hs2,& - bw_D_Hs2_Sqr, bw_D_Hs2_Cub, bw_D_Hs2_Tet, sqrt_bw_D_Hs2, & - arg, sqrt_arg, r1_arg, e1_arg, exp_arg, exp_erfc,& - term1, factor2, term2, arg_n, sum_term, add_term, half_i2_1 - INTEGER :: i - - ! A is an exchange hole parameter [3] and b the fit parameter for erfc [2] - REAL, PARAMETER :: & - A = 1.0161144, A_2 = A / 2.0, scale = 2.25 / A, sqrtA = 1.008025,& !sqrt(A) + LOGICAL :: correction ! Has the value of s been corrected + + ! If a large value of s would violate the Lieb-Oxford bound, the value of s is reduced, + ! so that this condition is fullfilled + correction = s_inp > s_thresh + IF (correction) THEN + s_si2 = s_chg/(s_inp*s_inp) + s = s_max - s_si2 + ELSE + s = s_inp + END IF + + ! Calculate different helper variables + r1_kF = 1.0/kF + omega_kF = omega_hse*r1_kF !was omega_VHSE() + omega_kF_Sqr = omega_kF*omega_kF + + ! calculate the functions H and F in [3] and its derivatives + CALL calculateH(s, H, dHs2_ds, d2Hs2_ds2) + CALL calculateF(s, H, dHs2_ds, d2Hs2_ds2, F, dFs2_ds, d2Fs2_ds2) + s2 = s*s + Hs2 = H*s2 + Fs2 = F*s2 + CALL calculateG(s2, Fs2, dFs2_ds, d2Fs2_ds2, Hs2, dHs2_ds, d2Hs2_ds2, & !Input + G, dGs2_ds, d2Gs2_ds2) !Output + + C_term = C*(1 + s2*F) + dCt_ds = C*dFs2_ds + d2Ct_ds2 = C*d2Fs2_ds2 + E_term = E*(1 + s2*G) + dEt_ds = E*dGs2_ds + d2Et_ds2 = E*d2Gs2_ds2 + D_term = D + Hs2 + + ! approximate the integral using an expansion of the error function (cf. [2]) + CALL approximateIntegral(omega_kF, Hs2, D_term, dHs2_ds, d2Hs2_ds2, & !Input + appInt, dAppInt_ds, d2AppInt_ds2, dAppInt_dkF, d2AppInt_dsdkF) !Output + + ! Calculate the integrals + ! + ! inf + ! / 2 2 / \ + ! | n -(D+H(s)s ) y | omega | + ! | dy y e Erfc| ----- y | + ! | | k | + ! / \ F / + ! 0 + ! for n = 1, 3, 5, 7, and 9 + ! + intY1ExpErfc = integrateY1ExpErfc(omega_kf, omega_kf_Sqr, D_term) + intY3ExpErfc = integrateY3ExpErfc(omega_kf, omega_kf_Sqr, D_term) + intY5ExpErfc = integrateY5ExpErfc(omega_kf, omega_kf_Sqr, D_term) + intY7ExpErfc = integrateY7ExpErfc(omega_kf, omega_kf_Sqr, D_term) + intY9ExpErfc = integrateY9ExpErfc(omega_kf, omega_kf_Sqr, D_term) + + ! Calculate the integrals + ! + ! inf + ! / / 2 \ + ! 2 | n | 2 2 omega 2 | + ! ----- | dy y Exp| -(D+H(s)s ) y - ------ y | + ! ____ | | k ^2 | + ! V Pi / \ F / + ! 0 + ! for n = 2, 4, 6, 8 + ! + r1_arg = 1.0/(D_term + omega_kF_Sqr) + intY2Gauss = 0.5*SQRT(r1_arg)*r1_arg + intY4Gauss = 1.5*intY2Gauss*r1_arg + intY6Gauss = 2.5*intY4Gauss*r1_arg + intY8Gauss = 3.5*intY6Gauss*r1_arg + + ! Calculate the integral + ! inf + ! / / \ + ! | | omega | + ! | dy y J(s,y) Erfc| ----- y | + ! | | k | + ! / \ F / + ! 0 + ! where J(s, y) is the exchange hole defined in [3] + ! the exchange factor is proportional to this integral + F_x = -r8_9*(appInt + B*intY1ExpErfc + C_term*intY3ExpErfc + E_term*intY5ExpErfc) + + ! Calculate the derivatives with respect to s using that the derivatative of the integral + ! yields higher orders of the same kind of integral intY1 -> -intY3 -> intY5 ... times + ! the derivative of the exponent + dFx_ds = -r8_9*(dAppInt_ds - (B*intY3ExpErfc + C_term*intY5ExpErfc + E_term*intY7ExpErfc)*dHs2_ds & + + dCt_ds*intY3ExpErfc + dEt_ds*intY5ExpErfc) + d2Fx_ds2 = -r8_9*(d2AppInt_ds2 + (B*intY5ExpErfc + C_term*intY7ExpErfc + E_term*intY9ExpErfc)*dHs2_ds**2 & + - (B*intY3ExpErfc + C_term*intY5ExpErfc + E_term*intY7ExpErfc)*d2Hs2_ds2 & + - 2.0*(dCt_ds*intY5ExpErfc + dEt_ds*intY7ExpErfc)*dHs2_ds & + + d2Ct_ds2*intY3ExpErfc + d2Et_ds2*intY5ExpErfc) + + dFx_dkF = -r8_9*r1_kF*(omega_kF*(B*intY2Gauss + C_term*intY4Gauss + E_term*intY6Gauss) + dAppInt_dkF) + d2Fx_dsdkF = -r8_9*r1_kF*(d2AppInt_dsdkF + omega_kF*(dCt_ds*intY4Gauss + dEt_ds*intY6Gauss & + - (B*intY4Gauss + C_term*intY6Gauss + E_term*intY8Gauss)*dHs2_ds)) + + ! Correction to the derivatives, if s_inp > s_thresh + IF (correction) THEN + r2s_si3 = 2.0*s_si2/s_inp + r6s_si4 = 3.0*r2s_si3/s_inp + d2Fx_ds2 = d2Fx_ds2*r2s_si3**2 - dFx_ds*r6s_si4 + d2Fx_dsdkF = d2Fx_dsdkF*r2s_si3 + dFx_ds = dFx_ds*r2s_si3 + END IF + + END SUBROUTINE calculateEnhancementFactor + + ! Approximation for the first part of the exchange hole integral + ! Calculated using the algorithm described in [2]. + ! Additionally the first and second derivative of this approximation with + ! respect to s are calculated + ! Input: omega_kF - omega / kF + ! Hs2 - H s^2 + ! D_Hs2 - D + H s^2 + ! dHs2_ds - d (H s^2) / ds + ! d2Hs2_ds2 - d^2 (H s^2) / ds^2 + ! Output: appInt - approximation for one part of the exchange hole integral + ! dAppInt_ds - first derivative with respect to s + ! d2AppInt_ds2 - second derivative with respect to s + ! dAppInt_dkF - first derivative with respect to kF + ! d2AppInt_dsdkF - mixed derivative with respect to s and kF + SUBROUTINE approximateIntegral(omega_kF, Hs2, D_Hs2, dHs2_ds, d2Hs2_ds2, & + appInt, dAppInt_ds, d2AppInt_ds2, dAppInt_dkF, d2AppInt_dsdkF) + + USE m_exponential_integral, ONLY: calculateExponentialIntegral, gauss_laguerre + + IMPLICIT NONE + + REAL, INTENT(IN) :: omega_kF, Hs2, D_Hs2, dHs2_ds, d2Hs2_ds2 + REAL, INTENT(OUT) :: appInt, dAppInt_ds, d2AppInt_ds2 + REAL, INTENT(OUT) :: dAppInt_dkF, d2AppInt_dsdkF + + REAL :: w2, bw, r2bw, bw_Hs2, bw_D_Hs2 + ! variables for temporary storage of the integrals, the prefactors and the dot_product + REAL :: integral(0:12), a_omegaI(0:8), aI_omegaI(0:8), dotpr, dotpr2 + INTEGER :: i + + REAL :: r2w2, r4w2, r2w2_Hs2, r2w2_D_Hs2, arg, exp_e1, dAppInt_dh, d2AppInt_dh2 + + ! parameters of the erfc fit as given in [2] + REAL, PARAMETER :: A_2 = 0.5080572, scale = 1.125/A_2, & + a(1:8) = (/-1.128223946706117, 1.452736265762971, & + -1.243162299390327, 0.971824836115601, & + -0.568861079687373, 0.246880514820192, & + -0.065032363850763, 0.008401793031216/), & + b = 1.455915450052607, cutoff = 14.0 + + ! Calculate helper variables + w2 = omega_kF**2 + bw = b*w2 + r2bw = 2.0*bw + bw_Hs2 = bw + Hs2 + bw_D_Hs2 = bw + D_Hs2 + + IF (bw_Hs2 < cutoff) THEN + ! integrate the erfc approximation times the exchange hole + CALL generateIntegrals(bw_Hs2, bw_D_Hs2, integral) + + ! combine the solutions of the integrals with the appropriate prefactors + a_omegaI(0) = 1.0 + a_omegaI(1:8) = a*(/(omega_kF**i, i=1, 8)/) + aI_omegaI = (/(i*a_omegaI(i), i=0, 8)/) + appInt = DOT_PRODUCT(a_omegaI, integral(0:8)) + dotpr = DOT_PRODUCT(a_omegaI, integral(2:10)) + dAppInt_ds = -dotpr*dHs2_ds + dAppInt_dkF = r2bw*dotpr - DOT_PRODUCT(aI_omegaI, integral(0:8)) + dotpr2 = DOT_PRODUCT(a_omegaI, integral(4:12)) + d2AppInt_ds2 = dotpr2*dHs2_ds**2 - dotpr*d2Hs2_ds2 + d2AppInt_dsdkF = -(r2bw*dotpr2 - DOT_PRODUCT(aI_omegaI, integral(2:10)))*dHs2_ds + ELSE + r2w2 = 2.0*w2 + r4w2 = 4.0*w2 + r2w2_Hs2 = r2w2 + Hs2 + r2w2_D_Hs2 = r2w2 + D_Hs2 + arg = scale*r2w2_Hs2 + exp_e1 = gauss_laguerre(arg) + appInt = A_2*(LOG(r2w2_Hs2/r2w2_D_Hs2) + exp_e1) + dAppInt_dh = -A_2/r2w2_D_Hs2 + 1.125*exp_e1 + d2AppInt_dh2 = 1.125/r2w2_Hs2 - A_2/r2w2_D_Hs2**2 - 1.265625/A_2*exp_e1 + dAppInt_ds = dAppInt_dh*dHs2_ds + dAppInt_dkF = -dAppInt_dh*r4w2 + d2AppInt_ds2 = d2AppInt_dh2*dHs2_ds**2 + dAppInt_dh*d2Hs2_ds2 + d2AppInt_dsdkF = d2AppInt_dh2*dHs2_ds*r4w2 + END IF + + END SUBROUTINE approximateIntegral + + ! Generate the integrals for n = 0, 1, ..., 12 + ! + ! inf + ! / / 2 \ / \ + ! | n | A -Dy A | | / omega 2\ 2 | + ! | dy y | --- e - -------------- | Exp| - ( b ----- + H s ) y | + ! | | y / 4 2\ | | \ k / | + ! / \ y( 1 + - Ay ) / \ F / + ! 0 \ 9 / + ! + ! Input: bw_Hs2 - b (omega/kF)^2 + H s^2 + ! bw_D_Hs2 - b (omega/kF)^2 + D + H s^2 + ! Output: integral - array with the calculated integrals + ! To simplify the calculation use integral(n+2) = - d(integral(n))/d(b omega/kF) + SUBROUTINE generateIntegrals(bw_Hs2, bw_D_Hs2, integral) + USE m_exponential_integral, ONLY: calculateExponentialIntegral, gauss_laguerre, series_laguerre + USE m_constants + IMPLICIT NONE + + REAL, INTENT(IN) :: bw_Hs2, bw_D_Hs2 + REAL, INTENT(OUT) :: integral(0:12) + + ! Helper variables + REAL :: bw_Hs2_Sqr, bw_Hs2_Cub, sqrt_bw_Hs2, & + bw_D_Hs2_Sqr, bw_D_Hs2_Cub, bw_D_Hs2_Tet, sqrt_bw_D_Hs2, & + arg, sqrt_arg, r1_arg, e1_arg, exp_arg, exp_erfc, & + term1, factor2, term2, arg_n, sum_term, add_term, half_i2_1 + INTEGER :: i + + ! A is an exchange hole parameter [3] and b the fit parameter for erfc [2] + REAL, PARAMETER :: & + A = 1.0161144, A_2 = A/2.0, scale = 2.25/A, sqrtA = 1.008025, & !sqrt(A) b = 1.455915450052607 - ! Calculate many helper variables - bw_Hs2_Sqr = bw_Hs2 * bw_Hs2 - bw_Hs2_Cub = bw_Hs2 * bw_Hs2_Sqr - sqrt_bw_Hs2 = SQRT(bw_Hs2) - bw_D_Hs2_Sqr = bw_D_Hs2 * bw_D_Hs2 - bw_D_Hs2_Cub = bw_D_Hs2 * bw_D_Hs2_Sqr - bw_D_Hs2_Tet = bw_D_Hs2_Sqr * bw_D_Hs2_Sqr - sqrt_bw_D_Hs2 = SQRT(bw_D_Hs2) - - ! arg = 9/4 * (b omega/kF + H s^2) / A - arg = scale * bw_Hs2 - sqrt_arg = SQRT(arg) - r1_arg = 1.0 / arg - - ! calculate e^(arg), E1(arg), and erfc(sqrt(arg)) - exp_arg = EXP(arg) - exp_erfc = exp_arg * erfc(sqrt_arg) - - IF (arg > series_laguerre) THEN - term2 = gauss_laguerre(arg) - ELSE - CALL calculateExponentialIntegral(arg, e1_arg) - term2 = exp_arg * e1_arg - END IF - - ! The n = 0 integral is - ! A/2 ( ln((b omega/kF + H s^2) / (b omega/kF + D + H s^2)) - ! + e^(arg) E1(arg) ) - integral(0) = A_2 * (LOG(bw_Hs2 / bw_D_Hs2) + term2) - - ! Calculate now all even n's by successive derivation - ! The log(...) term gives term proportional to 1/(b omega/kF + D + H s^2)^i - ! The e^(arg) E1(arg) term reproduces itself with a prefactor and - ! generates an additional 1/arg term which produces higher 1/arg^i terms - ! when further deriviated - term1 = A_2 / bw_D_Hs2 - factor2 = -1.125 - arg_n = -1.0 / arg - integral(2) = term1 + factor2 * term2 - - DO i = 1, 5 - term1 = term1 / bw_D_Hs2 * REAL(i) - factor2 = -factor2 * scale - term2 = term2 + arg_n - - integral(2*(i+1)) = term1 + factor2 * term2 - - arg_n = -arg_n * REAL(i) / arg - END DO - - ! The n = 1 integral is - ! A/2 ( sqrt(pi) / sqrt( b omega/kF + D + H s2 ) - ! - 3/4 sqrt(A) pi e^(arg) erfc(sqrt(arg)) - term1 = A_2 * SQRT(PI_const) / sqrt_bw_D_Hs2 - term2 = PI_const * exp_erfc - factor2 = -0.75 * sqrtA - - integral(1) = term1 + factor2 * term2 - - ! Calculate now all uneven n's by successive derivation - ! The 1 / sqrt(...) term gives higher orders of 1 / (...)^((2i+1)/2) - ! The e^(arg) erfc(sqrt(arg)) term reproduces itself with a prefactor - ! and generates an additional 1/sqrt(arg) term which produces higher - ! 1/(arg)^((2i+1)/2) terms when further deriviated - sum_term = -1.125 * SQRT(pi_const) / sqrt_bw_Hs2 - add_term = sum_term - half_i2_1 = -0.5 - - DO i = 3, 11, 2 - factor2 = -factor2 * scale - term1 = -term1 * half_i2_1 / bw_D_Hs2 - integral(i) = term1 + term2 * factor2 + sum_term - - add_term = -add_term * half_i2_1 / bw_Hs2 - sum_term = -sum_term * scale + add_term - half_i2_1 = half_i2_1 - 1.0 - ENDDO - - END SUBROUTINE generateIntegrals - - ! Calculate the integral - ! - ! inf - ! / / \ / ________________ \ - ! | -a y^2 | omega | 1 | omega / / / omega \2 | - ! | dy y e Erfc| ----- y | = --- | 1 - ----- / / a + ( ----- ) | - ! | | k | 2 a | k / V \ k / | - ! / \ F / \ F F / - ! 0 - ! - ! Input: omega_kF - omega / kF - ! omega_kF_Sqr - (omega / kF)^2 - ! a - factor of the gaussian function - ! Return: result of the integration - REAL FUNCTION integrateY1ExpErfc(omega_kF, omega_kF_Sqr, a) - IMPLICIT NONE - - REAL, INTENT(IN) :: omega_kF, omega_kF_Sqr, a - - ! helper variable sqrt(a + (omega/kF)^2) - REAL :: sqrt_term - - ! calculate helper variable - sqrt_term = SQRT(a + omega_kF_Sqr) - - ! calculate the integral - integrateY1ExpErfc = 0.5 * (1 - omega_kF / sqrt_term) / a - - END FUNCTION integrateY1ExpErfc - - ! Calculate the integral - ! - ! inf - ! / / \ / ________________ ________________3 \ - ! | 3 -a y^2 | omega | 1 | omega / / / omega \2 omega / / / omega \2 | - ! | dy y e Erfc| ----- y | = ----- | 2 - 2 ----- / / a + ( ----- ) - a ----- / / a + ( ----- ) | - ! | | k | 4 a^2 | k / V \ k / k / V \ k / | - ! / \ F / \ F F F F / - ! 0 - ! - ! Input: omega_kF - omega / kF - ! omega_kF_Sqr - (omega / kF)^2 - ! a - factor of the gaussian function - ! Return: result of the integration - REAL FUNCTION integrateY3ExpErfc(omega_kF, omega_kF_Sqr, a) - IMPLICIT NONE - - REAL, INTENT(IN) :: omega_kF, omega_kF_Sqr, a - - ! helper variables - REAL :: term, sqrt_term, sqrt_term_3 - - ! calculate helper variables - term = a + omega_kF_Sqr - sqrt_term = SQRT(term) - sqrt_term_3 = term * sqrt_term - - ! calculate the integral - integrateY3ExpErfc = 0.25 * (2.0 - a * omega_kF / sqrt_term_3 - 2.0 * omega_kF / sqrt_term) / (a * a) - - END FUNCTION integrateY3ExpErfc - - ! Calculate the integral - ! - ! inf / \ - ! / / \ | / 2\ | - ! | 5 -a y^2 | omega | 1 | omega | a 3 a | | - ! | dy y e Erfc| ----- y | = --- | 1 - ---------- | 1 + --- + ----- | | - ! | | k | a^3 | k sqrt(x) | 2 x 8 x^2 | | - ! / \ F / | F \ / | - ! 0 \ / - ! where - ! / \ 2 - ! | omega | - ! x = a + | ----- | - ! | k | - ! \ F / - ! - ! Input: omega_kF - omega / kF - ! omega_kF_Sqr - (omega / kF)^2 - ! a - factor of the gaussian function - ! Return: result of the integration - REAL FUNCTION integrateY5ExpErfc(omega_kF, omega_kF_Sqr, a) - IMPLICIT NONE - - REAL, INTENT(IN) :: omega_kF, omega_kF_Sqr, a - - ! helper variables - REAL :: term, sqrt_term, a_Sqr - - ! calculate helper variables - term = a + omega_kF_Sqr - sqrt_term = SQRT(term) - a_Sqr = a * a - - ! calculate the integral - integrateY5ExpErfc = (1.0 - (0.375 * a_Sqr / (term * term) + a / (2.0 * term) + 1.0) * omega_kF / sqrt_term) / (a_Sqr * a) - - END FUNCTION integrateY5ExpErfc - - ! Calculate the integral - ! - ! inf / \ - ! / / \ | / 2 3 \ | - ! | 7 -a y^2 | omega | 3 | omega | a 3 a 5 a | | - ! | dy y e Erfc| ----- y | = --- | 1 - ---------- | 1 + --- + ----- + ------ | | - ! | | k | a^4 | k sqrt(x) | 2 x 8 x^2 16 x^3 | | - ! / \ F / | F \ / | - ! 0 \ / - ! where - ! / \ 2 - ! | omega | - ! x = a + | ----- | - ! | k | - ! \ F / - ! - ! Input: omega_kF - omega / kF - ! omega_kF_Sqr - (omega / kF)^2 - ! a - factor of the gaussian function - ! Return: result of the integration - REAL FUNCTION integrateY7ExpErfc(omega_kF, omega_kF_Sqr, a) - IMPLICIT NONE - - REAL, INTENT(IN) :: omega_kF, omega_kF_Sqr, a - - ! helper variables - REAL :: term2, term, sqrt_term, a_Sqr - - ! calculate helper variables - term = a + omega_kF_Sqr - term2 = term * term - sqrt_term = SQRT(term) - a_Sqr = a * a - - ! calculate the integral - integrateY7ExpErfc = 3.0 / (a_Sqr * a_Sqr) * (1.0 - omega_kF / sqrt_term * & - (0.3125 * (a_Sqr * a) / (term2 * term) + 0.375 * a_Sqr / term2 + a / (2.0 * term) + 1.0)) - - END FUNCTION integrateY7ExpErfc - - ! Calculate the integral - ! - ! inf / \ - ! / / \ | / 2 3 \ | - ! | 9 -a y^2 | omega | 12 | omega | a 3 a 5 a 35 a^4 | | - ! | dy y e Erfc| ----- y | = --- | 1 - ---------- | 1 + --- + ----- + ------ + ------- | | - ! | | k | a^5 | k sqrt(x) | 2 x 8 x^2 16 x^3 128 x^4 | | - ! / \ F / | F \ / | - ! 0 \ / - ! where - ! / \ 2 - ! | omega | - ! x = a + | ----- | - ! | k | - ! \ F / - ! - ! Input: omega_kF - omega / kF - ! omega_kF_Sqr - (omega / kF)^2 - ! a - factor of the gaussian function - ! Return: result of the integration - REAL FUNCTION integrateY9ExpErfc(omega_kF, omega_kF_Sqr, a) - IMPLICIT NONE - - REAL, INTENT(IN) :: omega_kF, omega_kF_Sqr, a - - ! helper variables - REAL :: term2, term, sqrt_term, a_Sqr, a_Tet - - ! calculate helper variables - term = a + omega_kF_Sqr - term2 = term * term - sqrt_term = SQRT(term) - a_Sqr = a * a - a_Tet = a_Sqr * a_Sqr - - ! calculate the integral - integrateY9ExpErfc = 12.0 * (1.0 - (0.2734375 * a_Tet / (term2 * term2) + 0.3125 * (a_Sqr * a) / (term2 * term) & - + 0.375 * a_Sqr / term2 + a / (2.0 * term) + 1.0) * omega_kF / sqrt_term) / (a_Tet * a) - - END FUNCTION integrateY9ExpErfc - - ! Calculate the function F(s) given in [3] - ! Input: s - reduced gradient - ! H - value of the function H(s) - ! dHs2_ds - first derivative of H(s)s^2 - ! dsHs2_ds2 - second derivative of H(s)s^2 - ! Output: F - value of the function F - ! dFs2_ds - first derivative of F(s)s^2 - ! d2Fs2_ds2 - second derivative of F(s)s^2 - SUBROUTINE calculateF(s, H, dHs2_ds, d2Hs2_ds2, F, dFs2_ds, d2Fs2_ds2) - IMPLICIT NONE - - REAL, INTENT(IN) :: s, H, dHs2_ds, d2Hs2_ds2 - REAL, INTENT(OUT) :: F, dFs2_ds, d2Fs2_ds2 - - REAL, PARAMETER :: slope = 6.4753871 - REAL, PARAMETER :: shift = 0.4796583 - - ! calculate the function F(s), d(s^2F(s))/ds, and d^2(s^2F(s))/ds^2 - F = slope * H + shift - dFs2_ds = slope * dHs2_ds + 2.0 * s * shift - d2Fs2_ds2 = slope * d2Hs2_ds2 + 2.0 * shift - END SUBROUTINE calculateF - - ! Calculate the function G(s) given in [3] - ! Input: s2 - s^2 where s is the reduced gradient - ! Fs2 - F(s) s^2 - ! dFs2_ds - first derivative of F(s)s^2 with respect to s - ! d2Fs2_ds2 - second derivative of F(s)s^2 - ! Hs2 - H(s) s^2 - ! dHs2_ds - first derivative of H(s)s^2 with respect to s - ! d2Hs2_ds2 - second derivative of H(s)s^2 - ! Output: G - value of the function G - ! dGs2_ds - first derivative of G(s)s^2 with respect to s - ! d2Gs2_ds2 - second derivative of G(s)s^2 - SUBROUTINE calculateG(s2, Fs2, dFs2_ds, d2Fs2_ds2, Hs2, dHs2_ds, d2Hs2_ds2, G, dGs2_ds, d2Gs2_ds2) - IMPLICIT NONE - - REAL, INTENT(IN) :: s2, Fs2, dFs2_ds, d2Fs2_ds2, Hs2, dHs2_ds, d2Hs2_ds2 - REAL, INTENT(OUT) :: G, dGs2_ds, d2Gs2_ds2 - - ! helper variables - REAL :: AHs2_1_2, AHs2_3_2, r1_Fs2, D_Hs2, D_Hs2Sqr, D_Hs2Cub, & - D_Hs2_5_2, D_Hs2_7_2, D_Hs2_9_2, D_Hs2_11_2 - REAL :: part1, dpart1_dh, d2part1_dh2 - REAL :: arg1, arg2, exp_erfc,& - part2, dpart2_dh, d2part2_dh2 - REAL :: alpha, Ebeta, r3Pi_4_alpha, beta_s2, Ebeta_s2,& - dalpha_dh, d2alpha_dh2, dalpha_df, d2alpha_dfdh, dbeta_dh, d2beta_dh2 - - ! parameters of the exchange hole given in [3] - REAL, PARAMETER :: PI_75 = 2.356194490192344929, SQRT_PI = 1.77245385090551602729816748334,& - A = 1.0161144, sqrtA = 1.008025, r9_4A = 2.25 / A,& !sqrt(A), 9/4A - B = -0.37170836,& - C = -0.077215461,& - D = 0.57786348,& - E = -0.051955731 - - ! calculate the helper variables - AHs2_1_2 = sqrtA * SQRT(Hs2) - AHs2_3_2 = AHs2_1_2 * A * Hs2 - r1_Fs2 = 1.0 + Fs2 - D_Hs2 = D + Hs2 - D_Hs2Sqr = D_Hs2 * D_Hs2 - D_Hs2Cub = D_Hs2 * D_Hs2Sqr - D_Hs2_5_2 = D_Hs2Sqr * SQRT(D_Hs2) - D_Hs2_7_2 = D_Hs2_5_2 * D_Hs2 - D_Hs2_9_2 = D_Hs2_5_2 * D_Hs2Sqr - D_Hs2_11_2 = D_Hs2_5_2 * D_Hs2Cub - - ! calculate first part of the term called 'a' in [3] eq. (A2) and its derivatives with respect to H(s)s^2 and F(s)s^2 - ! - ! 2 2 2 2 2 3 - ! __ 15E + 6C(1+Fs )(D+Hs ) + 4B(D+Hs ) + 8A(D+Hs ) - ! part1 = VPi ------------------------------------------------ - ! 2 7/2 - ! 16 ( D + H s ) - ! - part1 = SQRT_PI * (15.0*E + 6.0*C * r1_Fs2 * D_Hs2 + 4.0*B * D_Hs2Sqr + 8.0*A * D_Hs2Cub) / (16.0 * D_Hs2_7_2) - ! - ! 2 2 2 2 2 3 - ! d part1 __ 105E + 30C(1+Fs )(D+Hs ) + 12B(D+Hs ) + 8A(D+Hs ) - ! ------- = -VPi --------------------------------------------------- - ! d(Hs^2) 2 9/2 - ! 32 ( D + H s ) - ! - dpart1_dh = -SQRT_PI * (105.0*E + 30.0*C * r1_Fs2 * D_Hs2 + 12.0*B * D_Hs2Sqr + 8.0*A * D_Hs2Cub) / (32.0 * D_Hs2_9_2) - ! - ! 2 2 2 2 2 2 3 - ! d part1 __ 945E + 210C(1+Fs )(D+Hs ) + 60B(D+Hs ) + 24A(D+Hs ) - ! -------- = VPi ----------------------------------------------------- - ! 2 2 11/2 - ! d(Hs^2) 64 ( D + H s ) - ! - d2part1_dh2 = SQRT_PI * (945.0*E + 210.0*C * r1_Fs2 * D_Hs2 + 60.0*B * D_Hs2Sqr + 24.0*A * D_Hs2Cub) / (64.0 * D_Hs2_11_2) - ! - ! d part1 __ 3 C - ! ------- = VPi ----------------- - ! d(Fs^2) 2 5/2 - ! 8 ( D + H s ) - ! - dalpha_df = SQRT_PI * 0.375 * C / D_Hs2_5_2 - ! - ! 2 - ! d part1 __ 15 C - ! --------------- = -VPi ------------------ - ! d(Fs^2) d(Hs^2) 2 7/2 - ! 16 ( D + H s ) - ! - d2alpha_dfdh = -2.5 * dalpha_df / D_Hs2 - - ! calculate second part of the term called 'a' in [3] eq. (A2) and its derivatives - ! ________ - ! / 2 \ / / 2 \ - ! 3 Pi ___ | 9 H s | | / 9 H s | - ! part2 = ---- V A Exp| ------- | Erfc| / ------- | - ! 4 | 4 A | | V 4 A | - ! \ / \ / - ! - arg1 = r9_4A * Hs2 - arg2 = SQRT(arg1) - exp_erfc = EXP(arg1) * erfc(arg2) - part2 = PI_75 * sqrtA * exp_erfc - ! - ! / \ - ! d part2 3 Pi ___ | 9 3 | - ! ------- = ---- V A | --- exp_erfc - ---------------- | - ! d(Hs^2) 4 | 4 A 2 | - ! \ 2 sqrt(Pi A Hs ) / - ! - dpart2_dh = PI_75 * sqrtA * (r9_4A * exp_erfc - 1.5 / (SQRT_PI * AHs2_1_2) ) - ! - ! 2 / 2 \ - ! d part2 3 Pi ___ | 81 6 A - 27 Hs | - ! -------- = ---- V A | ------ exp_erfc + -------------------- | - ! 2 4 | 16 A^2 2 3/2 | - ! d(Hs^2) \ 8 sqrt(Pi)(A Hs ) / - ! - d2part2_dh2 = PI_75 * sqrtA * (r9_4A**2 * exp_erfc + (6.0*A - 27.0*Hs2) / (8.0 * SQRT_PI * AHs2_3_2) ) - - ! calculate the 'a' and 'b' terms ([3] eq. (A2) and (A3) ) - ! - ! a = part1 - part2 - ! - ! __ 2 - ! 15 VPi s - ! b = ----------------- - ! 2 7/2 - ! 16 (D + H s ) - ! - alpha = part1 - part2 - beta_s2 = 0.9375 * SQRT_PI / D_Hs2_7_2 - Ebeta = E * beta_s2 * s2 - - ! the derivatives of a with respect to Fs^2 and Hs^2 - ! - ! da d part1 d part2 - ! -------- = ------- - ------- - ! d (Hs^2) d(Hs^2) d(Hs^2) - ! - dalpha_dh = dpart1_dh - dpart2_dh - ! - ! 2 2 2 - ! d a d part1 d part2 - ! -------- = -------- - -------- - ! 2 2 2 - ! d(Hs^2) d(Hs^2) d(Hs^2) - ! - d2alpha_dh2 = d2part1_dh2 - d2part2_dh2 - ! - ! da d part1 - ! -------- = ------- - ! d (Fs^2) d(Fs^2) - ! - ! 2 2 - ! d a d part1 - ! --------------- = --------------- - ! d(Fs^2) d(Hs^2) d(Fs^2) d(Hs^2) - ! - ! (this expressions are already defined earlier) - ! - ! and the derivatives of b/s^2 with respect to Hs^2 - ! __ - ! d(b/s^2) 105 VPi 7 b / s^2 - ! -------- = - ----------------- = - - -------- - ! d (Hs^2) 2 9/2 2 2 - ! 32 (D + H s ) D + H s - ! - dbeta_dh = -3.5 * beta_s2 / D_Hs2 - ! - ! 2 __ - ! d (b/s^2) 945 VPi 9 d(b/s^2) - ! --------- = ------------------ = - - -------- - ! 2 2 11/2 2 d (Hs^2) - ! d (Hs^2) 64 (D + H s ) - ! - d2beta_dh2 = -4.5 * dbeta_dh / D_Hs2 - - ! calculate the function G(s) and its derivatives - ! - ! 3Pi/4 + a - ! G = - --------- - ! E b - ! - r3Pi_4_alpha = PI_75 + alpha - Ebeta_s2 = E * beta_s2 - G = - r3Pi_4_alpha / Ebeta - ! - ! / /3 Pi \ d(b/s^2) / d a \ d(Hs^2) d a d(Fs^2) - ! < ( ---- + a ) ------- / b/s^2 - ------- > ------- - ------- ------- - ! d (Gs^2) \ \ 4 / d(Hs^2) / d(Hs^2) / d s d(Fs^2) ds - ! -------- = ---------------------------------------------------------------------------- - ! ds E b/s^2 - ! - dGs2_ds = ( (r3Pi_4_alpha * dbeta_dh / beta_s2 - dalpha_dh) * dHs2_ds - dalpha_df * dFs2_ds ) / Ebeta_s2 - ! - ! /3Pi \ / 2\ / \ - ! ( --- + a )( b h" + b h' ) + 2b h'( f'a + h'a ) + ... - ! 2 \ 4 / \ h hh / h \ f h/ - ! 2 -f" a - h" a - 2 f' h' a - h' a + ----------------------------------------------------------- - ! d (Gs^2) f h fh hh b/s^2 - ! -------- = --------------------------------------------------------------------------------------------------- - ! ds^2 E b/s^2 - ! - ! /3Pi \ 2 2 - ! ( --- + a ) b h' - ! \ 4 / h - ! ... = - 2 ----------------- - ! b/s^2 - ! - ! where the primes indicate derivative with respect to s and the subscripts derivatives with respect to the subscript - ! and f and h are abbrevations for f = Fs^2 and h = Hs^2 - ! - d2Gs2_ds2 = (-d2Fs2_ds2 * dalpha_df - d2Hs2_ds2 * dalpha_dh & - - 2.0 * dFs2_ds * dHs2_ds * d2alpha_dfdh - dHs2_ds**2 * d2alpha_dh2 & - + ( r3Pi_4_alpha * (dbeta_dh * d2Hs2_ds2 + d2beta_dh2 * dHs2_ds**2) & - + 2.0 * dbeta_dh * dHs2_ds * (dFs2_ds * dalpha_df + dHs2_ds * dalpha_dh) & - - 2.0 * r3Pi_4_alpha * (dbeta_dh*dHs2_ds)**2 / beta_s2 ) / beta_s2 ) / Ebeta_s2 - END SUBROUTINE calculateG - - ! Calculate the function H(s) given in [3] - ! Input: s - reduced gradient - ! Output: H - value of the function H - ! dHs2_ds - first derivative d(s^2*H(s))/ds - ! d2Hs2_ds2 - second derivative d^2(s^2H(s))/ds^2 - SUBROUTINE calculateH(s,H,dHs2_ds,d2Hs2_ds2) - IMPLICIT NONE - - REAL, INTENT(IN) :: s - REAL, INTENT(OUT) :: H, dHs2_ds, d2Hs2_ds2 - - ! helper variables - REAL :: s2, s3, s4, s5, s6 - REAL :: numer, denom - REAL :: dnum_ds, dden_ds - REAL :: d2num_ds2, d2den_ds2 - - ! parameters given in [3] - REAL, PARAMETER :: & - a1 = 0.00979681,& - a2 = 0.0410834,& - a3 = 0.187440,& - a4 = 0.00120824,& + ! Calculate many helper variables + bw_Hs2_Sqr = bw_Hs2*bw_Hs2 + bw_Hs2_Cub = bw_Hs2*bw_Hs2_Sqr + sqrt_bw_Hs2 = SQRT(bw_Hs2) + bw_D_Hs2_Sqr = bw_D_Hs2*bw_D_Hs2 + bw_D_Hs2_Cub = bw_D_Hs2*bw_D_Hs2_Sqr + bw_D_Hs2_Tet = bw_D_Hs2_Sqr*bw_D_Hs2_Sqr + sqrt_bw_D_Hs2 = SQRT(bw_D_Hs2) + + ! arg = 9/4 * (b omega/kF + H s^2) / A + arg = scale*bw_Hs2 + sqrt_arg = SQRT(arg) + r1_arg = 1.0/arg + + ! calculate e^(arg), E1(arg), and erfc(sqrt(arg)) + exp_arg = EXP(arg) + exp_erfc = exp_arg*erfc(sqrt_arg) + + IF (arg > series_laguerre) THEN + term2 = gauss_laguerre(arg) + ELSE + CALL calculateExponentialIntegral(arg, e1_arg) + term2 = exp_arg*e1_arg + END IF + + ! The n = 0 integral is + ! A/2 ( ln((b omega/kF + H s^2) / (b omega/kF + D + H s^2)) + ! + e^(arg) E1(arg) ) + integral(0) = A_2*(LOG(bw_Hs2/bw_D_Hs2) + term2) + + ! Calculate now all even n's by successive derivation + ! The log(...) term gives term proportional to 1/(b omega/kF + D + H s^2)^i + ! The e^(arg) E1(arg) term reproduces itself with a prefactor and + ! generates an additional 1/arg term which produces higher 1/arg^i terms + ! when further deriviated + term1 = A_2/bw_D_Hs2 + factor2 = -1.125 + arg_n = -1.0/arg + integral(2) = term1 + factor2*term2 + + DO i = 1, 5 + term1 = term1/bw_D_Hs2*REAL(i) + factor2 = -factor2*scale + term2 = term2 + arg_n + + integral(2*(i + 1)) = term1 + factor2*term2 + + arg_n = -arg_n*REAL(i)/arg + END DO + + ! The n = 1 integral is + ! A/2 ( sqrt(pi) / sqrt( b omega/kF + D + H s2 ) + ! - 3/4 sqrt(A) pi e^(arg) erfc(sqrt(arg)) + term1 = A_2*SQRT(PI_const)/sqrt_bw_D_Hs2 + term2 = PI_const*exp_erfc + factor2 = -0.75*sqrtA + + integral(1) = term1 + factor2*term2 + + ! Calculate now all uneven n's by successive derivation + ! The 1 / sqrt(...) term gives higher orders of 1 / (...)^((2i+1)/2) + ! The e^(arg) erfc(sqrt(arg)) term reproduces itself with a prefactor + ! and generates an additional 1/sqrt(arg) term which produces higher + ! 1/(arg)^((2i+1)/2) terms when further deriviated + sum_term = -1.125*SQRT(pi_const)/sqrt_bw_Hs2 + add_term = sum_term + half_i2_1 = -0.5 + + DO i = 3, 11, 2 + factor2 = -factor2*scale + term1 = -term1*half_i2_1/bw_D_Hs2 + integral(i) = term1 + term2*factor2 + sum_term + + add_term = -add_term*half_i2_1/bw_Hs2 + sum_term = -sum_term*scale + add_term + half_i2_1 = half_i2_1 - 1.0 + ENDDO + + END SUBROUTINE generateIntegrals + + ! Calculate the integral + ! + ! inf + ! / / \ / ________________ \ + ! | -a y^2 | omega | 1 | omega / / / omega \2 | + ! | dy y e Erfc| ----- y | = --- | 1 - ----- / / a + ( ----- ) | + ! | | k | 2 a | k / V \ k / | + ! / \ F / \ F F / + ! 0 + ! + ! Input: omega_kF - omega / kF + ! omega_kF_Sqr - (omega / kF)^2 + ! a - factor of the gaussian function + ! Return: result of the integration + REAL FUNCTION integrateY1ExpErfc(omega_kF, omega_kF_Sqr, a) + IMPLICIT NONE + + REAL, INTENT(IN) :: omega_kF, omega_kF_Sqr, a + + ! helper variable sqrt(a + (omega/kF)^2) + REAL :: sqrt_term + + ! calculate helper variable + sqrt_term = SQRT(a + omega_kF_Sqr) + + ! calculate the integral + integrateY1ExpErfc = 0.5*(1 - omega_kF/sqrt_term)/a + + END FUNCTION integrateY1ExpErfc + + ! Calculate the integral + ! + ! inf + ! / / \ / ________________ ________________3 \ + ! | 3 -a y^2 | omega | 1 | omega / / / omega \2 omega / / / omega \2 | + ! | dy y e Erfc| ----- y | = ----- | 2 - 2 ----- / / a + ( ----- ) - a ----- / / a + ( ----- ) | + ! | | k | 4 a^2 | k / V \ k / k / V \ k / | + ! / \ F / \ F F F F / + ! 0 + ! + ! Input: omega_kF - omega / kF + ! omega_kF_Sqr - (omega / kF)^2 + ! a - factor of the gaussian function + ! Return: result of the integration + REAL FUNCTION integrateY3ExpErfc(omega_kF, omega_kF_Sqr, a) + IMPLICIT NONE + + REAL, INTENT(IN) :: omega_kF, omega_kF_Sqr, a + + ! helper variables + REAL :: term, sqrt_term, sqrt_term_3 + + ! calculate helper variables + term = a + omega_kF_Sqr + sqrt_term = SQRT(term) + sqrt_term_3 = term*sqrt_term + + ! calculate the integral + integrateY3ExpErfc = 0.25*(2.0 - a*omega_kF/sqrt_term_3 - 2.0*omega_kF/sqrt_term)/(a*a) + + END FUNCTION integrateY3ExpErfc + + ! Calculate the integral + ! + ! inf / \ + ! / / \ | / 2\ | + ! | 5 -a y^2 | omega | 1 | omega | a 3 a | | + ! | dy y e Erfc| ----- y | = --- | 1 - ---------- | 1 + --- + ----- | | + ! | | k | a^3 | k sqrt(x) | 2 x 8 x^2 | | + ! / \ F / | F \ / | + ! 0 \ / + ! where + ! / \ 2 + ! | omega | + ! x = a + | ----- | + ! | k | + ! \ F / + ! + ! Input: omega_kF - omega / kF + ! omega_kF_Sqr - (omega / kF)^2 + ! a - factor of the gaussian function + ! Return: result of the integration + REAL FUNCTION integrateY5ExpErfc(omega_kF, omega_kF_Sqr, a) + IMPLICIT NONE + + REAL, INTENT(IN) :: omega_kF, omega_kF_Sqr, a + + ! helper variables + REAL :: term, sqrt_term, a_Sqr + + ! calculate helper variables + term = a + omega_kF_Sqr + sqrt_term = SQRT(term) + a_Sqr = a*a + + ! calculate the integral + integrateY5ExpErfc = (1.0 - (0.375*a_Sqr/(term*term) + a/(2.0*term) + 1.0)*omega_kF/sqrt_term)/(a_Sqr*a) + + END FUNCTION integrateY5ExpErfc + + ! Calculate the integral + ! + ! inf / \ + ! / / \ | / 2 3 \ | + ! | 7 -a y^2 | omega | 3 | omega | a 3 a 5 a | | + ! | dy y e Erfc| ----- y | = --- | 1 - ---------- | 1 + --- + ----- + ------ | | + ! | | k | a^4 | k sqrt(x) | 2 x 8 x^2 16 x^3 | | + ! / \ F / | F \ / | + ! 0 \ / + ! where + ! / \ 2 + ! | omega | + ! x = a + | ----- | + ! | k | + ! \ F / + ! + ! Input: omega_kF - omega / kF + ! omega_kF_Sqr - (omega / kF)^2 + ! a - factor of the gaussian function + ! Return: result of the integration + REAL FUNCTION integrateY7ExpErfc(omega_kF, omega_kF_Sqr, a) + IMPLICIT NONE + + REAL, INTENT(IN) :: omega_kF, omega_kF_Sqr, a + + ! helper variables + REAL :: term2, term, sqrt_term, a_Sqr + + ! calculate helper variables + term = a + omega_kF_Sqr + term2 = term*term + sqrt_term = SQRT(term) + a_Sqr = a*a + + ! calculate the integral + integrateY7ExpErfc = 3.0/(a_Sqr*a_Sqr)*(1.0 - omega_kF/sqrt_term* & + (0.3125*(a_Sqr*a)/(term2*term) + 0.375*a_Sqr/term2 + a/(2.0*term) + 1.0)) + + END FUNCTION integrateY7ExpErfc + + ! Calculate the integral + ! + ! inf / \ + ! / / \ | / 2 3 \ | + ! | 9 -a y^2 | omega | 12 | omega | a 3 a 5 a 35 a^4 | | + ! | dy y e Erfc| ----- y | = --- | 1 - ---------- | 1 + --- + ----- + ------ + ------- | | + ! | | k | a^5 | k sqrt(x) | 2 x 8 x^2 16 x^3 128 x^4 | | + ! / \ F / | F \ / | + ! 0 \ / + ! where + ! / \ 2 + ! | omega | + ! x = a + | ----- | + ! | k | + ! \ F / + ! + ! Input: omega_kF - omega / kF + ! omega_kF_Sqr - (omega / kF)^2 + ! a - factor of the gaussian function + ! Return: result of the integration + REAL FUNCTION integrateY9ExpErfc(omega_kF, omega_kF_Sqr, a) + IMPLICIT NONE + + REAL, INTENT(IN) :: omega_kF, omega_kF_Sqr, a + + ! helper variables + REAL :: term2, term, sqrt_term, a_Sqr, a_Tet + + ! calculate helper variables + term = a + omega_kF_Sqr + term2 = term*term + sqrt_term = SQRT(term) + a_Sqr = a*a + a_Tet = a_Sqr*a_Sqr + + ! calculate the integral + integrateY9ExpErfc = 12.0*(1.0 - (0.2734375*a_Tet/(term2*term2) + 0.3125*(a_Sqr*a)/(term2*term) & + + 0.375*a_Sqr/term2 + a/(2.0*term) + 1.0)*omega_kF/sqrt_term)/(a_Tet*a) + + END FUNCTION integrateY9ExpErfc + + ! Calculate the function F(s) given in [3] + ! Input: s - reduced gradient + ! H - value of the function H(s) + ! dHs2_ds - first derivative of H(s)s^2 + ! dsHs2_ds2 - second derivative of H(s)s^2 + ! Output: F - value of the function F + ! dFs2_ds - first derivative of F(s)s^2 + ! d2Fs2_ds2 - second derivative of F(s)s^2 + SUBROUTINE calculateF(s, H, dHs2_ds, d2Hs2_ds2, F, dFs2_ds, d2Fs2_ds2) + IMPLICIT NONE + + REAL, INTENT(IN) :: s, H, dHs2_ds, d2Hs2_ds2 + REAL, INTENT(OUT) :: F, dFs2_ds, d2Fs2_ds2 + + REAL, PARAMETER :: slope = 6.4753871 + REAL, PARAMETER :: shift = 0.4796583 + + ! calculate the function F(s), d(s^2F(s))/ds, and d^2(s^2F(s))/ds^2 + F = slope*H + shift + dFs2_ds = slope*dHs2_ds + 2.0*s*shift + d2Fs2_ds2 = slope*d2Hs2_ds2 + 2.0*shift + END SUBROUTINE calculateF + + ! Calculate the function G(s) given in [3] + ! Input: s2 - s^2 where s is the reduced gradient + ! Fs2 - F(s) s^2 + ! dFs2_ds - first derivative of F(s)s^2 with respect to s + ! d2Fs2_ds2 - second derivative of F(s)s^2 + ! Hs2 - H(s) s^2 + ! dHs2_ds - first derivative of H(s)s^2 with respect to s + ! d2Hs2_ds2 - second derivative of H(s)s^2 + ! Output: G - value of the function G + ! dGs2_ds - first derivative of G(s)s^2 with respect to s + ! d2Gs2_ds2 - second derivative of G(s)s^2 + SUBROUTINE calculateG(s2, Fs2, dFs2_ds, d2Fs2_ds2, Hs2, dHs2_ds, d2Hs2_ds2, G, dGs2_ds, d2Gs2_ds2) + IMPLICIT NONE + + REAL, INTENT(IN) :: s2, Fs2, dFs2_ds, d2Fs2_ds2, Hs2, dHs2_ds, d2Hs2_ds2 + REAL, INTENT(OUT) :: G, dGs2_ds, d2Gs2_ds2 + + ! helper variables + REAL :: AHs2_1_2, AHs2_3_2, r1_Fs2, D_Hs2, D_Hs2Sqr, D_Hs2Cub, & + D_Hs2_5_2, D_Hs2_7_2, D_Hs2_9_2, D_Hs2_11_2 + REAL :: part1, dpart1_dh, d2part1_dh2 + REAL :: arg1, arg2, exp_erfc, & + part2, dpart2_dh, d2part2_dh2 + REAL :: alpha, Ebeta, r3Pi_4_alpha, beta_s2, Ebeta_s2, & + dalpha_dh, d2alpha_dh2, dalpha_df, d2alpha_dfdh, dbeta_dh, d2beta_dh2 + + ! parameters of the exchange hole given in [3] + REAL, PARAMETER :: PI_75 = 2.356194490192344929, SQRT_PI = 1.77245385090551602729816748334, & + A = 1.0161144, sqrtA = 1.008025, r9_4A = 2.25/A, & !sqrt(A), 9/4A + B = -0.37170836, & + C = -0.077215461, & + D = 0.57786348, & + E = -0.051955731 + + ! calculate the helper variables + AHs2_1_2 = sqrtA*SQRT(Hs2) + AHs2_3_2 = AHs2_1_2*A*Hs2 + r1_Fs2 = 1.0 + Fs2 + D_Hs2 = D + Hs2 + D_Hs2Sqr = D_Hs2*D_Hs2 + D_Hs2Cub = D_Hs2*D_Hs2Sqr + D_Hs2_5_2 = D_Hs2Sqr*SQRT(D_Hs2) + D_Hs2_7_2 = D_Hs2_5_2*D_Hs2 + D_Hs2_9_2 = D_Hs2_5_2*D_Hs2Sqr + D_Hs2_11_2 = D_Hs2_5_2*D_Hs2Cub + + ! calculate first part of the term called 'a' in [3] eq. (A2) and its derivatives with respect to H(s)s^2 and F(s)s^2 + ! + ! 2 2 2 2 2 3 + ! __ 15E + 6C(1+Fs )(D+Hs ) + 4B(D+Hs ) + 8A(D+Hs ) + ! part1 = VPi ------------------------------------------------ + ! 2 7/2 + ! 16 ( D + H s ) + ! + part1 = SQRT_PI*(15.0*E + 6.0*C*r1_Fs2*D_Hs2 + 4.0*B*D_Hs2Sqr + 8.0*A*D_Hs2Cub)/(16.0*D_Hs2_7_2) + ! + ! 2 2 2 2 2 3 + ! d part1 __ 105E + 30C(1+Fs )(D+Hs ) + 12B(D+Hs ) + 8A(D+Hs ) + ! ------- = -VPi --------------------------------------------------- + ! d(Hs^2) 2 9/2 + ! 32 ( D + H s ) + ! + dpart1_dh = -SQRT_PI*(105.0*E + 30.0*C*r1_Fs2*D_Hs2 + 12.0*B*D_Hs2Sqr + 8.0*A*D_Hs2Cub)/(32.0*D_Hs2_9_2) + ! + ! 2 2 2 2 2 2 3 + ! d part1 __ 945E + 210C(1+Fs )(D+Hs ) + 60B(D+Hs ) + 24A(D+Hs ) + ! -------- = VPi ----------------------------------------------------- + ! 2 2 11/2 + ! d(Hs^2) 64 ( D + H s ) + ! + d2part1_dh2 = SQRT_PI*(945.0*E + 210.0*C*r1_Fs2*D_Hs2 + 60.0*B*D_Hs2Sqr + 24.0*A*D_Hs2Cub)/(64.0*D_Hs2_11_2) + ! + ! d part1 __ 3 C + ! ------- = VPi ----------------- + ! d(Fs^2) 2 5/2 + ! 8 ( D + H s ) + ! + dalpha_df = SQRT_PI*0.375*C/D_Hs2_5_2 + ! + ! 2 + ! d part1 __ 15 C + ! --------------- = -VPi ------------------ + ! d(Fs^2) d(Hs^2) 2 7/2 + ! 16 ( D + H s ) + ! + d2alpha_dfdh = -2.5*dalpha_df/D_Hs2 + + ! calculate second part of the term called 'a' in [3] eq. (A2) and its derivatives + ! ________ + ! / 2 \ / / 2 \ + ! 3 Pi ___ | 9 H s | | / 9 H s | + ! part2 = ---- V A Exp| ------- | Erfc| / ------- | + ! 4 | 4 A | | V 4 A | + ! \ / \ / + ! + arg1 = r9_4A*Hs2 + arg2 = SQRT(arg1) + exp_erfc = EXP(arg1)*erfc(arg2) + part2 = PI_75*sqrtA*exp_erfc + ! + ! / \ + ! d part2 3 Pi ___ | 9 3 | + ! ------- = ---- V A | --- exp_erfc - ---------------- | + ! d(Hs^2) 4 | 4 A 2 | + ! \ 2 sqrt(Pi A Hs ) / + ! + dpart2_dh = PI_75*sqrtA*(r9_4A*exp_erfc - 1.5/(SQRT_PI*AHs2_1_2)) + ! + ! 2 / 2 \ + ! d part2 3 Pi ___ | 81 6 A - 27 Hs | + ! -------- = ---- V A | ------ exp_erfc + -------------------- | + ! 2 4 | 16 A^2 2 3/2 | + ! d(Hs^2) \ 8 sqrt(Pi)(A Hs ) / + ! + d2part2_dh2 = PI_75*sqrtA*(r9_4A**2*exp_erfc + (6.0*A - 27.0*Hs2)/(8.0*SQRT_PI*AHs2_3_2)) + + ! calculate the 'a' and 'b' terms ([3] eq. (A2) and (A3) ) + ! + ! a = part1 - part2 + ! + ! __ 2 + ! 15 VPi s + ! b = ----------------- + ! 2 7/2 + ! 16 (D + H s ) + ! + alpha = part1 - part2 + beta_s2 = 0.9375*SQRT_PI/D_Hs2_7_2 + Ebeta = E*beta_s2*s2 + + ! the derivatives of a with respect to Fs^2 and Hs^2 + ! + ! da d part1 d part2 + ! -------- = ------- - ------- + ! d (Hs^2) d(Hs^2) d(Hs^2) + ! + dalpha_dh = dpart1_dh - dpart2_dh + ! + ! 2 2 2 + ! d a d part1 d part2 + ! -------- = -------- - -------- + ! 2 2 2 + ! d(Hs^2) d(Hs^2) d(Hs^2) + ! + d2alpha_dh2 = d2part1_dh2 - d2part2_dh2 + ! + ! da d part1 + ! -------- = ------- + ! d (Fs^2) d(Fs^2) + ! + ! 2 2 + ! d a d part1 + ! --------------- = --------------- + ! d(Fs^2) d(Hs^2) d(Fs^2) d(Hs^2) + ! + ! (this expressions are already defined earlier) + ! + ! and the derivatives of b/s^2 with respect to Hs^2 + ! __ + ! d(b/s^2) 105 VPi 7 b / s^2 + ! -------- = - ----------------- = - - -------- + ! d (Hs^2) 2 9/2 2 2 + ! 32 (D + H s ) D + H s + ! + dbeta_dh = -3.5*beta_s2/D_Hs2 + ! + ! 2 __ + ! d (b/s^2) 945 VPi 9 d(b/s^2) + ! --------- = ------------------ = - - -------- + ! 2 2 11/2 2 d (Hs^2) + ! d (Hs^2) 64 (D + H s ) + ! + d2beta_dh2 = -4.5*dbeta_dh/D_Hs2 + + ! calculate the function G(s) and its derivatives + ! + ! 3Pi/4 + a + ! G = - --------- + ! E b + ! + r3Pi_4_alpha = PI_75 + alpha + Ebeta_s2 = E*beta_s2 + G = -r3Pi_4_alpha/Ebeta + ! + ! / /3 Pi \ d(b/s^2) / d a \ d(Hs^2) d a d(Fs^2) + ! < ( ---- + a ) ------- / b/s^2 - ------- > ------- - ------- ------- + ! d (Gs^2) \ \ 4 / d(Hs^2) / d(Hs^2) / d s d(Fs^2) ds + ! -------- = ---------------------------------------------------------------------------- + ! ds E b/s^2 + ! + dGs2_ds = ((r3Pi_4_alpha*dbeta_dh/beta_s2 - dalpha_dh)*dHs2_ds - dalpha_df*dFs2_ds)/Ebeta_s2 + ! + ! /3Pi \ / 2\ / \ + ! ( --- + a )( b h" + b h' ) + 2b h'( f'a + h'a ) + ... + ! 2 \ 4 / \ h hh / h \ f h/ + ! 2 -f" a - h" a - 2 f' h' a - h' a + ----------------------------------------------------------- + ! d (Gs^2) f h fh hh b/s^2 + ! -------- = --------------------------------------------------------------------------------------------------- + ! ds^2 E b/s^2 + ! + ! /3Pi \ 2 2 + ! ( --- + a ) b h' + ! \ 4 / h + ! ... = - 2 ----------------- + ! b/s^2 + ! + ! where the primes indicate derivative with respect to s and the subscripts derivatives with respect to the subscript + ! and f and h are abbrevations for f = Fs^2 and h = Hs^2 + ! + d2Gs2_ds2 = (-d2Fs2_ds2*dalpha_df - d2Hs2_ds2*dalpha_dh & + - 2.0*dFs2_ds*dHs2_ds*d2alpha_dfdh - dHs2_ds**2*d2alpha_dh2 & + + (r3Pi_4_alpha*(dbeta_dh*d2Hs2_ds2 + d2beta_dh2*dHs2_ds**2) & + + 2.0*dbeta_dh*dHs2_ds*(dFs2_ds*dalpha_df + dHs2_ds*dalpha_dh) & + - 2.0*r3Pi_4_alpha*(dbeta_dh*dHs2_ds)**2/beta_s2)/beta_s2)/Ebeta_s2 + END SUBROUTINE calculateG + + ! Calculate the function H(s) given in [3] + ! Input: s - reduced gradient + ! Output: H - value of the function H + ! dHs2_ds - first derivative d(s^2*H(s))/ds + ! d2Hs2_ds2 - second derivative d^2(s^2H(s))/ds^2 + SUBROUTINE calculateH(s, H, dHs2_ds, d2Hs2_ds2) + IMPLICIT NONE + + REAL, INTENT(IN) :: s + REAL, INTENT(OUT) :: H, dHs2_ds, d2Hs2_ds2 + + ! helper variables + REAL :: s2, s3, s4, s5, s6 + REAL :: numer, denom + REAL :: dnum_ds, dden_ds + REAL :: d2num_ds2, d2den_ds2 + + ! parameters given in [3] + REAL, PARAMETER :: & + a1 = 0.00979681, & + a2 = 0.0410834, & + a3 = 0.187440, & + a4 = 0.00120824, & a5 = 0.0347188 - ! calculate helper variables - s2 = s * s - s3 = s2 * s - s4 = s2 * s2 - s5 = s3 * s2 - s6 = s4 * s2 - - ! calculate function H(s) with [3] eq. (A5) - ! - ! 2 4 - ! a s + a s - ! 1 2 - ! H = ------------------------- - ! 4 5 6 - ! 1 + a s + a s + a s - ! 3 4 5 - ! - numer = a1 * s2 + a2 * s4 - denom = 1.0 + a3 * s4 + a4 * s5 + a5 * s6 - H = numer / denom - - ! calculate the first derivative of s^2 H(s) - ! - ! / \ - ! d | f(x) | f'(x) - f(x)g'(x) / g(x) - ! -- | ---- | = ------------------------ - ! dx | g(x) | g(x) - ! \ / - ! - numer = numer * s2 - dnum_ds = 4.0 * s3 * a1 + 6.0 * s5 * a2 - dden_ds = 4.0 * s3 * a3 + 5.0 * s4 * a4 + 6.0 * s5 * a5 - dHs2_ds = ( dnum_ds - (dden_ds * numer)/denom ) / denom - - ! calculate the second derivative of s^2 H(s) - ! - ! 2 - ! 2 f'(x)g'(x) + f(x)g"(x) - 2 f(x)g'(x) /g(x) - ! 2 / \ f"(x) - -------------------------------------------- - ! d | f(x) | g(x) - ! ---- | ---- | = ---------------------------------------------------- - ! dx^2 | g(x) | g(x) - ! \ / - ! - d2num_ds2 = 12.0 * s2 * a1 + 30.0 * s4 * a2 - d2den_ds2 = 12.0 * s2 * a3 + 20.0 * s3 * a4 + 30.0 * s4 * a5 - d2Hs2_ds2 = ( d2num_ds2 - ( 2.0*dnum_ds*dden_ds + numer*d2den_ds2 - 2.0*numer*dden_ds**2/denom ) / denom ) / denom - END SUBROUTINE calculateH - - ! Calculate several Fourier transformations - ! a) the Fourier transformed potential - ! / \ - ! / | erf | \ 4 Pi | |k+G|^2 | - ! V (k) = ( k + G | --- | k + G ) = ------- Exp| - ------- | [1] - ! G \ | r | / |k+G|^2 | 4 w^2 | - ! \ / - ! - ! b) muffin-tin basis function - ! R - ! -L / - ! / | \ 4 Pi i ^ -i G R | 2 - ! MT (k) = ( k + G | M ) = ---------- Y ( k+G ) e | dr r Phi(r) j ( |k+G| r ) [2] - ! G,I \ | k,I / Sqrt(Om) LM | L - ! / - ! 0 - ! - ! c) interstitial basis function - ! ----- - ! / | \ 4 Pi \ -i(G - G_I)R_a Sin(|G_I - G| R_a) - |G_I - G| R_a Cos(|G_I - G| R_a) - ! IN = ( k + G | M ) = kronecker(G,G ) - ------ ) e ------------------------------------------------------- [3] - ! G,I \ | k,I / I Om / |G_I - G|^3 - ! ----- - ! a - ! \_________________________ ___________________________/ - ! V - ! I_a - ! - ! In the code: - ! V_G(k): potential - ! MT_G(k): muffintin - ! IN_G: interstitial - ! I_a: inter_atom - ! - ! Input: - ! rmsh - array of radial mesh points - ! rmt - radius of the muffin tin - ! dx - logarithmic increment of radial mesh - ! jri - number of radial mesh points - ! jmtd - dimension of radial mesh points - ! bk - one(!) k-vector for which FT is calculated - ! bmat - reciprocal lattice vector for all directions - ! vol - volume of the unit cell - ! ntype - number of atom types - ! neq - number of symmetry-equivalent atoms of atom type i - ! natd - dimesion of atoms in unit cell - ! taual - vector of atom positions (internal coordinates) - ! lcutm - l cutoff for mixed basis - ! maxlcutm - maximum of all these l cutoffs - ! nindxm - number of radial functions of mixed basis - ! maxindxm - maximum of these numbers - ! gptm - reciprocal lattice vectors of the mixed basis (internal coord.) - ! ngptm - number of vectors (for treated k-vector) - ! pgptm - pointer to the appropriate g-vector (for treated k-vector) - ! gptmd - dimension of gptm - ! basm - mixed basis functions (mt + inter) for treated k-vector - ! lexp - cutoff of spherical harmonics expansion of plane wave - ! noGPts - no g-vectors used for Fourier trafo - ! Output: - ! potential - Fourier transformation of the potential - ! muffintin - Fourier transformation of all MT functions - ! interstital - Fourier transformation of all IR functions - SUBROUTINE calculate_fourier_transform( & + ! calculate helper variables + s2 = s*s + s3 = s2*s + s4 = s2*s2 + s5 = s3*s2 + s6 = s4*s2 + + ! calculate function H(s) with [3] eq. (A5) + ! + ! 2 4 + ! a s + a s + ! 1 2 + ! H = ------------------------- + ! 4 5 6 + ! 1 + a s + a s + a s + ! 3 4 5 + ! + numer = a1*s2 + a2*s4 + denom = 1.0 + a3*s4 + a4*s5 + a5*s6 + H = numer/denom + + ! calculate the first derivative of s^2 H(s) + ! + ! / \ + ! d | f(x) | f'(x) - f(x)g'(x) / g(x) + ! -- | ---- | = ------------------------ + ! dx | g(x) | g(x) + ! \ / + ! + numer = numer*s2 + dnum_ds = 4.0*s3*a1 + 6.0*s5*a2 + dden_ds = 4.0*s3*a3 + 5.0*s4*a4 + 6.0*s5*a5 + dHs2_ds = (dnum_ds - (dden_ds*numer)/denom)/denom + + ! calculate the second derivative of s^2 H(s) + ! + ! 2 + ! 2 f'(x)g'(x) + f(x)g"(x) - 2 f(x)g'(x) /g(x) + ! 2 / \ f"(x) - -------------------------------------------- + ! d | f(x) | g(x) + ! ---- | ---- | = ---------------------------------------------------- + ! dx^2 | g(x) | g(x) + ! \ / + ! + d2num_ds2 = 12.0*s2*a1 + 30.0*s4*a2 + d2den_ds2 = 12.0*s2*a3 + 20.0*s3*a4 + 30.0*s4*a5 + d2Hs2_ds2 = (d2num_ds2 - (2.0*dnum_ds*dden_ds + numer*d2den_ds2 - 2.0*numer*dden_ds**2/denom)/denom)/denom + END SUBROUTINE calculateH + + ! Calculate several Fourier transformations + ! a) the Fourier transformed potential + ! / \ + ! / | erf | \ 4 Pi | |k+G|^2 | + ! V (k) = ( k + G | --- | k + G ) = ------- Exp| - ------- | [1] + ! G \ | r | / |k+G|^2 | 4 w^2 | + ! \ / + ! + ! b) muffin-tin basis function + ! R + ! -L / + ! / | \ 4 Pi i ^ -i G R | 2 + ! MT (k) = ( k + G | M ) = ---------- Y ( k+G ) e | dr r Phi(r) j ( |k+G| r ) [2] + ! G,I \ | k,I / Sqrt(Om) LM | L + ! / + ! 0 + ! + ! c) interstitial basis function + ! ----- + ! / | \ 4 Pi \ -i(G - G_I)R_a Sin(|G_I - G| R_a) - |G_I - G| R_a Cos(|G_I - G| R_a) + ! IN = ( k + G | M ) = kronecker(G,G ) - ------ ) e ------------------------------------------------------- [3] + ! G,I \ | k,I / I Om / |G_I - G|^3 + ! ----- + ! a + ! \_________________________ ___________________________/ + ! V + ! I_a + ! + ! In the code: + ! V_G(k): potential + ! MT_G(k): muffintin + ! IN_G: interstitial + ! I_a: inter_atom + ! + ! Input: + ! rmsh - array of radial mesh points + ! rmt - radius of the muffin tin + ! dx - logarithmic increment of radial mesh + ! jri - number of radial mesh points + ! jmtd - dimension of radial mesh points + ! bk - one(!) k-vector for which FT is calculated + ! bmat - reciprocal lattice vector for all directions + ! vol - volume of the unit cell + ! ntype - number of atom types + ! neq - number of symmetry-equivalent atoms of atom type i + ! natd - dimesion of atoms in unit cell + ! taual - vector of atom positions (internal coordinates) + ! lcutm - l cutoff for mixed basis + ! maxlcutm - maximum of all these l cutoffs + ! nindxm - number of radial functions of mixed basis + ! maxindxm - maximum of these numbers + ! gptm - reciprocal lattice vectors of the mixed basis (internal coord.) + ! ngptm - number of vectors (for treated k-vector) + ! pgptm - pointer to the appropriate g-vector (for treated k-vector) + ! gptmd - dimension of gptm + ! basm - mixed basis functions (mt + inter) for treated k-vector + ! lexp - cutoff of spherical harmonics expansion of plane wave + ! noGPts - no g-vectors used for Fourier trafo + ! Output: + ! potential - Fourier transformation of the potential + ! muffintin - Fourier transformation of all MT functions + ! interstital - Fourier transformation of all IR functions + SUBROUTINE calculate_fourier_transform( & ! Input - rmsh,rmt,dx,jri,jmtd,bk,& - bmat,vol,ntype,neq,natd,taual,lcutm,maxlcutm,& - nindxm,maxindxm,gptm,ngptm,pgptm,gptmd,& - basm,noGPts,irank,& + rmsh, rmt, dx, jri, jmtd, bk, & + bmat, vol, ntype, neq, natd, taual, lcutm, maxlcutm, & + nindxm, maxindxm, gptm, ngptm, pgptm, gptmd, & + basm, noGPts, irank, & ! Output - potential,muffintin,interstitial) - - USE m_constants - USE m_olap, ONLY : gptnorm - USE m_util, ONLY : sphbessel,pure_intgrf,intgrf_init,intgrf_out,NEGATIVE_EXPONENT_WARNING,NEGATIVE_EXPONENT_ERROR - - IMPLICIT NONE - - ! scalar input - INTEGER, INTENT(IN) :: natd,ntype,maxlcutm - INTEGER, INTENT(IN) :: jmtd,irank - INTEGER, INTENT(IN) :: maxindxm - INTEGER, INTENT(IN) :: gptmd, noGPts - REAL, INTENT(IN) :: vol - - ! array input - INTEGER, INTENT(IN) :: lcutm(ntype) - INTEGER, INTENT(IN) :: nindxm(0:maxlcutm,ntype),neq(ntype) - INTEGER, INTENT(IN) :: jri(ntype) - INTEGER, INTENT(IN) :: gptm(3,gptmd) - INTEGER, INTENT(IN) :: ngptm - INTEGER, INTENT(IN) :: pgptm(ngptm) - - REAL, INTENT(IN) :: bk(3) - REAL, INTENT(IN) :: rmsh(jmtd,ntype),rmt(ntype),dx(ntype) - REAL, INTENT(IN) :: basm(jmtd,maxindxm,0:maxlcutm,ntype) - REAL, INTENT(IN) :: bmat(3,3)!,amat(3,3) - REAL, INTENT(IN) :: taual(3,natd) - - ! array output - REAL, INTENT(OUT) :: potential(noGPts) ! Fourier transformed potential - COMPLEX, INTENT(OUT) :: muffintin(noGPts,maxindxm,& ! muffin-tin overlap integral - (maxlcutm+1)**2,ntype,MAXVAL(neq)) - COMPLEX, INTENT(OUT) :: interstitial(noGPts,gptmd) ! interstistial overlap intergral - - ! private scalars - INTEGER :: cg,cg2,ci,cl,cn,cr ! counter variables - REAL :: r2Pi, r4Pi, pi_omega2 ! 2*Pi, 4*Pi, Pi/omega^2 - REAL :: sVol, r4Pi_sVol, r4Pi_Vol ! sqrt(vol), 4*Pi/sqrt(Vol), 4*Pi/Vol - REAL :: omega, r1_omega2, r1_4omega2 + potential, muffintin, interstitial) + + USE m_constants + USE m_olap, ONLY: gptnorm + USE m_util, ONLY: sphbessel, pure_intgrf, intgrf_init, intgrf_out, NEGATIVE_EXPONENT_WARNING, NEGATIVE_EXPONENT_ERROR + + IMPLICIT NONE + + ! scalar input + INTEGER, INTENT(IN) :: natd, ntype, maxlcutm + INTEGER, INTENT(IN) :: jmtd, irank + INTEGER, INTENT(IN) :: maxindxm + INTEGER, INTENT(IN) :: gptmd, noGPts + REAL, INTENT(IN) :: vol + + ! array input + INTEGER, INTENT(IN) :: lcutm(ntype) + INTEGER, INTENT(IN) :: nindxm(0:maxlcutm, ntype), neq(ntype) + INTEGER, INTENT(IN) :: jri(ntype) + INTEGER, INTENT(IN) :: gptm(3, gptmd) + INTEGER, INTENT(IN) :: ngptm + INTEGER, INTENT(IN) :: pgptm(ngptm) + + REAL, INTENT(IN) :: bk(3) + REAL, INTENT(IN) :: rmsh(jmtd, ntype), rmt(ntype), dx(ntype) + REAL, INTENT(IN) :: basm(jmtd, maxindxm, 0:maxlcutm, ntype) + REAL, INTENT(IN) :: bmat(3, 3)!,amat(3,3) + REAL, INTENT(IN) :: taual(3, natd) + + ! array output + REAL, INTENT(OUT) :: potential(noGPts) ! Fourier transformed potential + COMPLEX, INTENT(OUT) :: muffintin(noGPts, maxindxm, & ! muffin-tin overlap integral + (maxlcutm + 1)**2, ntype, MAXVAL(neq)) + COMPLEX, INTENT(OUT) :: interstitial(noGPts, gptmd) ! interstistial overlap intergral + + ! private scalars + INTEGER :: cg, cg2, ci, cl, cn, cr ! counter variables + REAL :: r2Pi, r4Pi, pi_omega2 ! 2*Pi, 4*Pi, Pi/omega^2 + REAL :: sVol, r4Pi_sVol, r4Pi_Vol ! sqrt(vol), 4*Pi/sqrt(Vol), 4*Pi/Vol + REAL :: omega, r1_omega2, r1_4omega2 ! REAL, PARAMETER :: omega = omega_VHSE() ! omega of the HSE functional ! REAL, PARAMETER :: r1_omega2 = 1.0 / omega**2 ! 1/omega^2 ! REAL, PARAMETER :: r1_4omega2 = 0.25 * r1_omega2 ! 1/(4 omega^2) - COMPLEX, PARAMETER :: img = (0.0,1.0) ! i - - ! private arrays - INTEGER :: gPts(3,noGPts) ! g vectors (internal units) - INTEGER :: gPts_gptm(3,noGpts,gptmd) ! gPts - gptm - INTEGER :: natdPtr(ntype+1) ! pointer to all atoms of one type - REAL, ALLOCATABLE :: gridf(:,:) ! grid for radial integration - REAL :: k_G(3,noGPts) ! k + G - REAL :: AbsK_G(noGPts),AbsK_G2(noGPts) ! abs(k+G), abs(k+G)^2 - REAL :: arg(noGPts) ! abs(k+G)^2 / (4*omega^2) - REAL :: sphbesK_Gr(noGPts,jmtd,0:maxlcutm,ntype) ! spherical bessel function of abs(k+G)r - TYPE(intgrf_out) :: intgrMT(noGPts,maxindxm,0:maxlcutm,ntype) ! integration in muffin-tin - REAL :: abs_dg(noGpts,gptmd) ! abs(gPts - gptm) - COMPLEX :: imgl(0:maxlcutm) ! i^l - COMPLEX :: Ylm(noGPts,(maxlcutm+1)**2) ! spherical harmonics for k+G and all lm - COMPLEX :: expIGR(noGPts,ntype,MAXVAL(neq)) ! exp(-iGR) for all atom types - COMPLEX :: sumInter_atom(noGpts,gptmd) ! sum over inter-atom factors - - ! Calculate helper variables - r2Pi = 2.0 * pi_const - r4Pi = 4.0 * pi_const - sVol = SQRT(vol) - r4Pi_sVol = r4Pi / sVol - r4Pi_Vol = r4Pi / Vol - omega = omega_hse!omega_VHSE() - r1_omega2 = 1.0 / omega**2 - r1_4omega2 = 0.25 * r1_omega2 - pi_omega2 = pi_const * r1_omega2 - - ! calculate pointers for all atom-types to all atoms - natdPtr(ntype+1) = natd - DO cn=ntype,1,-1 - natdPtr(cn) = natdPtr(cn+1) - neq(cn) - END DO - - ! Define imgl(l) = img**l - imgl(0) = 1.0 - DO ci=1,maxlcutm - imgl(ci) = imgl(ci-1) * img - END DO - - ! generate grid for fast radial integration - CALL intgrf_init(ntype,jmtd,jri,dx,rmsh,gridf) - - ! Set all arrays to 0 - gPts = 0 - k_G = 0 - AbsK_G = 0 - arg = 0 - sphbesK_Gr = 0 - intgrMT%value = 0 - intgrMT%ierror = 0 - Ylm = 0 - expIGR = 0 - gPts_gptm = 0 - abs_dg = 0 - sumInter_atom = 0 - potential = 0 - muffintin = 0 - interstitial = 0 + COMPLEX, PARAMETER :: img = (0.0, 1.0) ! i + + ! private arrays + INTEGER :: gPts(3, noGPts) ! g vectors (internal units) + INTEGER :: gPts_gptm(3, noGpts, gptmd) ! gPts - gptm + INTEGER :: natdPtr(ntype + 1) ! pointer to all atoms of one type + REAL, ALLOCATABLE :: gridf(:, :) ! grid for radial integration + REAL :: k_G(3, noGPts) ! k + G + REAL :: AbsK_G(noGPts), AbsK_G2(noGPts) ! abs(k+G), abs(k+G)^2 + REAL :: arg(noGPts) ! abs(k+G)^2 / (4*omega^2) + REAL :: sphbesK_Gr(noGPts, jmtd, 0:maxlcutm, ntype) ! spherical bessel function of abs(k+G)r + TYPE(intgrf_out) :: intgrMT(noGPts, maxindxm, 0:maxlcutm, ntype) ! integration in muffin-tin + REAL :: abs_dg(noGpts, gptmd) ! abs(gPts - gptm) + COMPLEX :: imgl(0:maxlcutm) ! i^l + COMPLEX :: Ylm(noGPts, (maxlcutm + 1)**2) ! spherical harmonics for k+G and all lm + COMPLEX :: expIGR(noGPts, ntype, MAXVAL(neq)) ! exp(-iGR) for all atom types + COMPLEX :: sumInter_atom(noGpts, gptmd) ! sum over inter-atom factors + + ! Calculate helper variables + r2Pi = 2.0*pi_const + r4Pi = 4.0*pi_const + sVol = SQRT(vol) + r4Pi_sVol = r4Pi/sVol + r4Pi_Vol = r4Pi/Vol + omega = omega_hse!omega_VHSE() + r1_omega2 = 1.0/omega**2 + r1_4omega2 = 0.25*r1_omega2 + pi_omega2 = pi_const*r1_omega2 + + ! calculate pointers for all atom-types to all atoms + natdPtr(ntype + 1) = natd + DO cn = ntype, 1, -1 + natdPtr(cn) = natdPtr(cn + 1) - neq(cn) + END DO + + ! Define imgl(l) = img**l + imgl(0) = 1.0 + DO ci = 1, maxlcutm + imgl(ci) = imgl(ci - 1)*img + END DO + + ! generate grid for fast radial integration + CALL intgrf_init(ntype, jmtd, jri, dx, rmsh, gridf) + + ! Set all arrays to 0 + gPts = 0 + k_G = 0 + AbsK_G = 0 + arg = 0 + sphbesK_Gr = 0 + intgrMT%value = 0 + intgrMT%ierror = 0 + Ylm = 0 + expIGR = 0 + gPts_gptm = 0 + abs_dg = 0 + sumInter_atom = 0 + potential = 0 + muffintin = 0 + interstitial = 0 ! Calculate the muffin-tin basis function overlap integral ! R @@ -1082,61 +1080,61 @@ CONTAINS ! G,I \ | k,I / Sqrt(Om) LM | L ! / ! 0 - IF (ngptm < noGpts) STOP 'hsefunctional: error calculating Fourier coefficients, noGpts too large' + IF (ngptm < noGpts) STOP 'hsefunctional: error calculating Fourier coefficients, noGpts too large' - gPts(:,:) = gptm(:,pgptm(1:noGPts)) -#ifndef __PGI + gPts(:, :) = gptm(:, pgptm(1:noGPts)) +#ifndef __PGI - gpoints: FORALL ( cg=1:noGPts ) - ntypesA: FORALL ( cn=1:ntype ) - ! Calculate the phase factor exp(-iGR) for all atoms - FORALL ( ci=1:neq(cn) ) - expIGR(cg,cn,ci) = EXP( -r2Pi * img * DOT_PRODUCT(taual(:,natdPtr(cn)+ci),gPts(:,cg)) ) - muffintin(cg,:,:,cn,ci) = r4Pi_sVol * expIGR(cg,cn,ci) - END FORALL + gpoints:FORALL (cg=1:noGPts) + ntypesA:FORALL (cn=1:ntype) + ! Calculate the phase factor exp(-iGR) for all atoms + FORALL (ci=1:neq(cn)) + expIGR(cg, cn, ci) = EXP(-r2Pi*img*DOT_PRODUCT(taual(:, natdPtr(cn) + ci), gPts(:, cg))) + muffintin(cg, :, :, cn, ci) = r4Pi_sVol*expIGR(cg, cn, ci) + END FORALL - ! Multiplication with i^-L - FORALL ( cl=0:lcutm(cn) ) - muffintin(cg,:,cl*cl+1:(cl+1)*(cl+1),cn,:) = muffintin(cg,:,cl*cl+1:(cl+1)*(cl+1),cn,:) / imgl(cl) - END FORALL + ! Multiplication with i^-L + FORALL (cl=0:lcutm(cn)) + muffintin(cg, :, cl*cl + 1:(cl + 1)*(cl + 1), cn, :) = muffintin(cg, :, cl*cl + 1:(cl + 1)*(cl + 1), cn, :)/imgl(cl) + END FORALL END FORALL ntypesA ! Calculate the k+G, abs(k+G), and abs(k+G)^2 - k_G(:,cg) = MATMUL( gPts(:,cg)+bk(:), bmat(:,:) ) - AbsK_G2(cg) = SUM( k_G(:,cg)**2 ) - AbsK_G(cg) = SQRT(AbsK_G2(cg)) + k_G(:, cg) = MATMUL(gPts(:, cg) + bk(:), bmat(:, :)) + AbsK_G2(cg) = SUM(k_G(:, cg)**2) + AbsK_G(cg) = SQRT(AbsK_G2(cg)) ! Spherical harmonics are calculated for all lm's and k+G's - Ylm(cg,:) = calcYlm(k_G(:,cg),maxlcutm) + Ylm(cg, :) = calcYlm(k_G(:, cg), maxlcutm) ! Perform the integration in eq.[2] for all muffin-tins - ntypesB: FORALL ( cn=1:ntype ) - - ! Multiplication with the spherical harmonic - FORALL ( cl=1:(lcutm(cn)+1)**2 ) - muffintin(cg,:,cl,cn,:) = muffintin(cg,:,cl,cn,:) * Ylm(cg,cl) - END FORALL - - ! Calculate the spherical bessel function - FORALL ( cr=1:jri(cn) ) - sphbesK_Gr(cg,cr,:,cn) = calcSphBes(AbsK_G(cg)*rmsh(cr,cn),maxlcutm) - END FORALL - ! integrate the function and multiplicate to the result - FORALL ( cl=0:lcutm(cn) ) - FORALL ( ci=1:nindxm(cl,cn) ) - intgrMT(cg,ci,cl,cn) = pure_intgrf(rmsh(:,cn) * basm(:,ci,cl,cn) * & - sphbesK_Gr(cg,:,cl,cn),jri,jmtd,rmsh,dx,ntype,cn,gridf) - muffintin(cg,ci,cl*cl+1:(cl+1)*(cl+1),cn,:) = & - muffintin(cg,ci,cl*cl+1:(cl+1)*(cl+1),cn,:) * intgrMT(cg,ci,cl,cn)%value - END FORALL - END FORALL + ntypesB:FORALL (cn=1:ntype) + + ! Multiplication with the spherical harmonic + FORALL (cl=1:(lcutm(cn) + 1)**2) + muffintin(cg, :, cl, cn, :) = muffintin(cg, :, cl, cn, :)*Ylm(cg, cl) + END FORALL + + ! Calculate the spherical bessel function + FORALL (cr=1:jri(cn)) + sphbesK_Gr(cg, cr, :, cn) = calcSphBes(AbsK_G(cg)*rmsh(cr, cn), maxlcutm) + END FORALL + ! integrate the function and multiplicate to the result + FORALL (cl=0:lcutm(cn)) + FORALL (ci=1:nindxm(cl, cn)) + intgrMT(cg, ci, cl, cn) = pure_intgrf(rmsh(:, cn)*basm(:, ci, cl, cn)* & + sphbesK_Gr(cg, :, cl, cn), jri, jmtd, rmsh, dx, ntype, cn, gridf) + muffintin(cg, ci, cl*cl + 1:(cl + 1)*(cl + 1), cn, :) = & + muffintin(cg, ci, cl*cl + 1:(cl + 1)*(cl + 1), cn, :)*intgrMT(cg, ci, cl, cn)%value + END FORALL + END FORALL END FORALL ntypesB ! calculate the overlap with the interstitial basis function ! ----- -! / | \ 4 Pi \ -i(G - G_I)R_a Sin(|G_I - G| R_a) - |G_I - G| R_a Cos(|G_I - G| R_a) +! / | \ 4 Pi \ -i(G - G_I)R_a Sin(|G_I - G| R_a) - |G_I - G| R_a Cos(|G_I - G| R_a) ! IN = ( k + G | M ) = kronecker(G,G ) - ------ ) e ------------------------------------------------------- [3] ! G,I \ | k,I / I Om / |G_I - G|^3 ! ----- @@ -1145,36 +1143,36 @@ CONTAINS ! V ! I_a ! Calculate the difference of the G vectors and its absolute value - FORALL ( cg2=1:gptmd ) + FORALL (cg2=1:gptmd) - gPts_gptm(:,cg,cg2) = gPts(:,cg) - gptm(:,cg2) - abs_dg(cg,cg2) = gptnorm( gPts_gptm(:,cg,cg2),bmat ) + gPts_gptm(:, cg, cg2) = gPts(:, cg) - gptm(:, cg2) + abs_dg(cg, cg2) = gptnorm(gPts_gptm(:, cg, cg2), bmat) END FORALL - END FORALL gpoints - - ! Check if any of the integrations failed and abort if one did - IF ( ANY( intgrMT%ierror == NEGATIVE_EXPONENT_ERROR ) ) THEN - IF ( irank == 0 ) WRITE(6,*) 'intgrf: Warning! Negative exponent x in extrapolation a+c*r**x' - ELSEIF ( ANY( intgrMT%ierror == NEGATIVE_EXPONENT_WARNING ) ) THEN - IF ( irank == 0 ) WRITE(6,*) 'intgrf: Negative exponent x in extrapolation a+c*r**x' - STOP 'intgrf: Negative exponent x in extrapolation a+c*r**x' - END IF - - ! Calculate the interstitial value with eq.[3] using the limit - ! 3 - ! R_a - ! I_a = ------ - ! 3 - ! if there's no difference of the two G vectors - WHERE ( abs_dg == 0 ) - sumInter_atom = DOT_PRODUCT(rmt**3, neq) / 3.0 - interstitial = 1.0 - r4Pi_Vol * sumInter_atom - ELSEWHERE - sumInter_atom = calculateSummation(abs_dg,gPts_gptm) - interstitial = -r4Pi_Vol * sumInter_atom - END WHERE + END FORALL gpoints + + ! Check if any of the integrations failed and abort if one did + IF (ANY(intgrMT%ierror == NEGATIVE_EXPONENT_ERROR)) THEN + IF (irank == 0) WRITE (6, *) 'intgrf: Warning! Negative exponent x in extrapolation a+c*r**x' + ELSEIF (ANY(intgrMT%ierror == NEGATIVE_EXPONENT_WARNING)) THEN + IF (irank == 0) WRITE (6, *) 'intgrf: Negative exponent x in extrapolation a+c*r**x' + STOP 'intgrf: Negative exponent x in extrapolation a+c*r**x' + END IF + + ! Calculate the interstitial value with eq.[3] using the limit + ! 3 + ! R_a + ! I_a = ------ + ! 3 + ! if there's no difference of the two G vectors + WHERE (abs_dg == 0) + sumInter_atom = DOT_PRODUCT(rmt**3, neq)/3.0 + interstitial = 1.0 - r4Pi_Vol*sumInter_atom + ELSEWHERE + sumInter_atom = calculateSummation(abs_dg, gPts_gptm) + interstitial = -r4Pi_Vol*sumInter_atom + END WHERE ! Calculate the Fourier transformed potential ! / \ @@ -1182,12 +1180,12 @@ CONTAINS ! V (k) = ( k + G | --- | k + G' ) = ------- Exp| - ------- | kronecker(G,G') [1] ! G \ | r | / |k+G|^2 | 4 w^2 | ! \ / - WHERE ( absK_G.NE.0 ) + WHERE (absK_G /= 0) ! Calculate (k+G)^2 / 4*w^2 - arg = -r1_4omega2 * AbsK_G2 + arg = -r1_4omega2*AbsK_G2 ! The potential is calculated using eq.[1] - potential = r4Pi / AbsK_G2 * EXP(arg) + potential = r4Pi/AbsK_G2*EXP(arg) ! Calculate the Fourier transformed potential for the full(!) potential ! @@ -1195,242 +1193,242 @@ CONTAINS ! V (k) = ( k + G = 0 | ---- | k + G = 0 ) = ----- ! G \ | r | / w^2 ! - ELSEWHERE + ELSEWHERE ! the negative sign is added to compensate the sign when the ! contribution is added to the Coulomb matrix potential = -pi_omega2 - endwhere + endwhere - DEALLOCATE( gridf ) + DEALLOCATE (gridf) #else - call judft_error("hsefunctional not implemented for PGI") + call judft_error("hsefunctional not implemented for PGI") #endif - CONTAINS - - ! Calculates the inter-atom parts and the summation over all atoms: - ! ----- - ! \ -i(G - G_I)R_a Sin(|G_I - G| R_a) - |G_I - G| R_a Cos(|G_I - G| R_a) - ! ) e ------------------------------------------------------- - ! / |G_I - G|^3 - ! ----- - ! a - ! Input: abs_dg - absolute value |G_I - G| - ! gPts_gptm - vector G - G_I - PURE FUNCTION calculateSummation(abs_dg,gPts_gptm) - IMPLICIT NONE - INTEGER, INTENT(IN) :: gPts_gptm(3,noGPts,gptmd) - REAL, INTENT(IN) :: abs_dg(noGPts,gptmd) - COMPLEX :: calculateSummation(noGPts,gptmd) - INTEGER :: cn,ci ! counter variables - REAL :: abs_dgR(noGPts,gptmd,ntype) ! abs(gPts - gptm)*R (R: radius MT) - REAL :: inter_atom(noGPts,gptmd,ntype) ! inter-atom interaction for interstitial - COMPLEX :: expIdGR(noGPts,gptmd,ntype,MAXVAL(neq)) ! exp(-i(gPts-gptm)R) - COMPLEX :: sumExpIdGR(noGPts,gptmd,ntype) ! sum over atom of same type - - atoms: FORALL ( cn=1:ntype ) - ! -i(G-G_I)R_a - ! Calculate for all similar atoms (same type) the factor e - ! use that the G vectors and atomic positions are given in internal units - FORALL ( ci=1:neq(cn) ) - expIdGR(:,:,cn,ci) = EXP( -r2pi * img * my_dot_product( gPts_gptm(:,:,:),taual(:,natdPtr(cn)+ci) ) ) - END FORALL - ! Add all factors for atoms of the same type - sumExpIdGR(:,:,cn) = my_sum(expIdGR(:,:,cn,:)) - - ! Calculate the inter-atom factor which is the same for all atoms of the same type - abs_dgR(:,:,cn) = abs_dg * rmt(cn) - inter_atom(:,:,cn) = ( SIN(abs_dgR(:,:,cn)) - abs_dgR(:,:,cn) * COS(abs_dgR(:,:,cn)) ) / abs_dg**3 - END FORALL atoms - - ! Add the factors of all atoms together - calculateSummation = my_dot_product(sumExpIdGR, inter_atom) - END FUNCTION calculateSummation - - END SUBROUTINE calculate_fourier_transform - - ! Calculate several Fourier transformations - ! a) the Fourier transformed potential - ! / \ - ! / | erf | \ 4 Pi | |k+G|^2 | - ! V (k) = ( k + G | --- | k + G ) = ------- Exp| - ------- | [1] - ! G \ | r | / |k+G|^2 | 4 w^2 | - ! \ / - ! - ! b) muffin-tin basis function - ! R - ! -L / - ! / | \ 4 Pi i ^ -i G R | 2 - ! MT (k) = ( k + G | M ) = ---------- Y ( k+G ) e | dr r Phi(r) j ( |k+G| r ) [2] - ! G,I \ | k,I / Sqrt(Om) LM | L - ! / - ! 0 - ! - ! In the code: - ! V_G(k): potential - ! MT_G(k): muffintin - ! - ! Input: - ! rmsh - array of radial mesh points - ! rmt - radius of the muffin tin - ! dx - logarithmic increment of radial mesh - ! jri - number of radial mesh points - ! jmtd - dimension of radial mesh points - ! bk - one(!) k-vector for which FT is calculated - ! bmat - reciprocal lattice vector for all directions - ! vol - volume of the unit cell - ! ntype - number of atom types - ! neq - number of symmetry-equivalent atoms of atom type i - ! natd - dimesion of atoms in unit cell - ! taual - vector of atom positions (internal coordinates) - ! lcutm - l cutoff for mixed basis - ! maxlcutm - maximum of all these l cutoffs - ! nindxm - number of radial functions of mixed basis - ! maxindxm - maximum of these numbers - ! gptm - reciprocal lattice vectors of the mixed basis (internal coord.) - ! ngptm - number of vectors (for treated k-vector) - ! pgptm - pointer to the appropriate g-vector (for treated k-vector) - ! gptmd - dimension of gptm - ! basm - mixed basis functions (mt + inter) for treated k-vector - ! lexp - cutoff of spherical harmonics expansion of plane wave - ! noGPts - no g-vectors used for Fourier trafo - ! Output: - ! potential - Fourier transformation of the potential - ! muffintin - Fourier transformation of all MT functions - SUBROUTINE calculate_fourier_transform_once( & + CONTAINS + + ! Calculates the inter-atom parts and the summation over all atoms: + ! ----- + ! \ -i(G - G_I)R_a Sin(|G_I - G| R_a) - |G_I - G| R_a Cos(|G_I - G| R_a) + ! ) e ------------------------------------------------------- + ! / |G_I - G|^3 + ! ----- + ! a + ! Input: abs_dg - absolute value |G_I - G| + ! gPts_gptm - vector G - G_I + PURE FUNCTION calculateSummation(abs_dg, gPts_gptm) + IMPLICIT NONE + INTEGER, INTENT(IN) :: gPts_gptm(3, noGPts, gptmd) + REAL, INTENT(IN) :: abs_dg(noGPts, gptmd) + COMPLEX :: calculateSummation(noGPts, gptmd) + INTEGER :: cn, ci ! counter variables + REAL :: abs_dgR(noGPts, gptmd, ntype) ! abs(gPts - gptm)*R (R: radius MT) + REAL :: inter_atom(noGPts, gptmd, ntype) ! inter-atom interaction for interstitial + COMPLEX :: expIdGR(noGPts, gptmd, ntype, MAXVAL(neq)) ! exp(-i(gPts-gptm)R) + COMPLEX :: sumExpIdGR(noGPts, gptmd, ntype) ! sum over atom of same type + + atoms:FORALL (cn=1:ntype) + ! -i(G-G_I)R_a + ! Calculate for all similar atoms (same type) the factor e + ! use that the G vectors and atomic positions are given in internal units + FORALL (ci=1:neq(cn)) + expIdGR(:, :, cn, ci) = EXP(-r2pi*img*my_dot_product(gPts_gptm(:, :, :), taual(:, natdPtr(cn) + ci))) + END FORALL + ! Add all factors for atoms of the same type + sumExpIdGR(:, :, cn) = my_sum(expIdGR(:, :, cn, :)) + + ! Calculate the inter-atom factor which is the same for all atoms of the same type + abs_dgR(:, :, cn) = abs_dg*rmt(cn) + inter_atom(:, :, cn) = (SIN(abs_dgR(:, :, cn)) - abs_dgR(:, :, cn)*COS(abs_dgR(:, :, cn)))/abs_dg**3 + END FORALL atoms + + ! Add the factors of all atoms together + calculateSummation = my_dot_product(sumExpIdGR, inter_atom) + END FUNCTION calculateSummation + + END SUBROUTINE calculate_fourier_transform + + ! Calculate several Fourier transformations + ! a) the Fourier transformed potential + ! / \ + ! / | erf | \ 4 Pi | |k+G|^2 | + ! V (k) = ( k + G | --- | k + G ) = ------- Exp| - ------- | [1] + ! G \ | r | / |k+G|^2 | 4 w^2 | + ! \ / + ! + ! b) muffin-tin basis function + ! R + ! -L / + ! / | \ 4 Pi i ^ -i G R | 2 + ! MT (k) = ( k + G | M ) = ---------- Y ( k+G ) e | dr r Phi(r) j ( |k+G| r ) [2] + ! G,I \ | k,I / Sqrt(Om) LM | L + ! / + ! 0 + ! + ! In the code: + ! V_G(k): potential + ! MT_G(k): muffintin + ! + ! Input: + ! rmsh - array of radial mesh points + ! rmt - radius of the muffin tin + ! dx - logarithmic increment of radial mesh + ! jri - number of radial mesh points + ! jmtd - dimension of radial mesh points + ! bk - one(!) k-vector for which FT is calculated + ! bmat - reciprocal lattice vector for all directions + ! vol - volume of the unit cell + ! ntype - number of atom types + ! neq - number of symmetry-equivalent atoms of atom type i + ! natd - dimesion of atoms in unit cell + ! taual - vector of atom positions (internal coordinates) + ! lcutm - l cutoff for mixed basis + ! maxlcutm - maximum of all these l cutoffs + ! nindxm - number of radial functions of mixed basis + ! maxindxm - maximum of these numbers + ! gptm - reciprocal lattice vectors of the mixed basis (internal coord.) + ! ngptm - number of vectors (for treated k-vector) + ! pgptm - pointer to the appropriate g-vector (for treated k-vector) + ! gptmd - dimension of gptm + ! basm - mixed basis functions (mt + inter) for treated k-vector + ! lexp - cutoff of spherical harmonics expansion of plane wave + ! noGPts - no g-vectors used for Fourier trafo + ! Output: + ! potential - Fourier transformation of the potential + ! muffintin - Fourier transformation of all MT functions + SUBROUTINE calculate_fourier_transform_once( & ! Input - rmsh,rmt,dx,jri,jmtd,bk,ikpt,nkptf, & - bmat,vol,ntype,neq,natd,taual,lcutm,maxlcutm, & - nindxm,maxindxm,gptm,ngptm,pgptm,gptmd, & - nbasp,basm,noGPts,invsat,invsatnr,irank, & + rmsh, rmt, dx, jri, jmtd, bk, ikpt, nkptf, & + bmat, vol, ntype, neq, natd, taual, lcutm, maxlcutm, & + nindxm, maxindxm, gptm, ngptm, pgptm, gptmd, & + nbasp, basm, noGPts, invsat, invsatnr, irank, & ! Output potential, fourier_trafo) - USE m_constants - USE m_util, ONLY : sphbessel,pure_intgrf,intgrf_init,intgrf_out,NEGATIVE_EXPONENT_WARNING,NEGATIVE_EXPONENT_ERROR - USE m_trafo, ONLY : symmetrize - - IMPLICIT NONE - - ! scalar input - INTEGER, INTENT(IN) :: natd,ntype,maxlcutm - INTEGER, INTENT(IN) :: ikpt,nkptf,jmtd - INTEGER, INTENT(IN) :: maxindxm,irank - INTEGER, INTENT(IN) :: gptmd,noGPts - REAL, INTENT(IN) :: vol - - ! array input - INTEGER, INTENT(IN) :: lcutm(ntype) - INTEGER, INTENT(IN) :: nindxm(0:maxlcutm,ntype),neq(ntype) - INTEGER, INTENT(IN) :: jri(ntype) - INTEGER, INTENT(IN) :: gptm(3,gptmd) - INTEGER, INTENT(IN) :: ngptm,nbasp - INTEGER, INTENT(IN) :: pgptm(ngptm) - INTEGER, INTENT(IN) :: invsat(natd),invsatnr(natd) - - REAL, INTENT(IN) :: bk(3) - REAL, INTENT(IN) :: rmsh(jmtd,ntype),rmt(ntype),dx(ntype) - REAL, INTENT(IN) :: basm(jmtd,maxindxm,0:maxlcutm,ntype) - REAL, INTENT(IN) :: bmat(3,3) - REAL, INTENT(IN) :: taual(3,natd) - - ! array output - REAL, INTENT(OUT) :: potential(noGPts) ! Fourier transformed potential + USE m_constants + USE m_util, ONLY: sphbessel, pure_intgrf, intgrf_init, intgrf_out, NEGATIVE_EXPONENT_WARNING, NEGATIVE_EXPONENT_ERROR + USE m_trafo, ONLY: symmetrize + + IMPLICIT NONE + + ! scalar input + INTEGER, INTENT(IN) :: natd, ntype, maxlcutm + INTEGER, INTENT(IN) :: ikpt, nkptf, jmtd + INTEGER, INTENT(IN) :: maxindxm, irank + INTEGER, INTENT(IN) :: gptmd, noGPts + REAL, INTENT(IN) :: vol + + ! array input + INTEGER, INTENT(IN) :: lcutm(ntype) + INTEGER, INTENT(IN) :: nindxm(0:maxlcutm, ntype), neq(ntype) + INTEGER, INTENT(IN) :: jri(ntype) + INTEGER, INTENT(IN) :: gptm(3, gptmd) + INTEGER, INTENT(IN) :: ngptm, nbasp + INTEGER, INTENT(IN) :: pgptm(ngptm) + INTEGER, INTENT(IN) :: invsat(natd), invsatnr(natd) + + REAL, INTENT(IN) :: bk(3) + REAL, INTENT(IN) :: rmsh(jmtd, ntype), rmt(ntype), dx(ntype) + REAL, INTENT(IN) :: basm(jmtd, maxindxm, 0:maxlcutm, ntype) + REAL, INTENT(IN) :: bmat(3, 3) + REAL, INTENT(IN) :: taual(3, natd) + + ! array output + REAL, INTENT(OUT) :: potential(noGPts) ! Fourier transformed potential #ifdef CPP_INVERSION - REAL, INTENT(OUT) :: fourier_trafo(nbasp,noGPts) !muffintin_out(nbasp,noGPts) + REAL, INTENT(OUT) :: fourier_trafo(nbasp, noGPts) !muffintin_out(nbasp,noGPts) #else - COMPLEX, INTENT(OUT) :: fourier_trafo(nbasp,noGPts) !muffintin_out(nbasp,noGPts) + COMPLEX, INTENT(OUT) :: fourier_trafo(nbasp, noGPts) !muffintin_out(nbasp,noGPts) #endif - ! private scalars - INTEGER :: cg,cg2,ci,cl,cm,cn,cr ! counter variables - REAL :: r2Pi, r4Pi, pi_omega2 ! Pi, 2*Pi, 4*Pi, Pi/omega^2 - REAL :: sVol, r4Pi_sVol, r4Pi_Vol ! sqrt(vol), 4*Pi/sqrt(Vol), 4*Pi/Vol - REAL :: omega, r1_omega2, r1_4omega2 + ! private scalars + INTEGER :: cg, cg2, ci, cl, cm, cn, cr ! counter variables + REAL :: r2Pi, r4Pi, pi_omega2 ! Pi, 2*Pi, 4*Pi, Pi/omega^2 + REAL :: sVol, r4Pi_sVol, r4Pi_Vol ! sqrt(vol), 4*Pi/sqrt(Vol), 4*Pi/Vol + REAL :: omega, r1_omega2, r1_4omega2 ! REAL, PARAMETER :: omega = omega_VHSE() ! omega of the HSE functional ! REAL, PARAMETER :: r1_omega2 = 1.0 / omega**2 ! 1/omega^2 ! REAL, PARAMETER :: r1_4omega2 = 0.25 * r1_omega2 ! 1/(4 omega^2) - COMPLEX, PARAMETER :: img = (0.0,1.0) ! i - - ! private arrays - INTEGER :: gPts(3,noGPts) ! g vectors (internal units) - INTEGER :: natdPtr(ntype+1) ! pointer to all atoms of one type - INTEGER :: ptrType(nbasp),ptrEq(nbasp),& ! pointer from ibasp to corresponding - ptrLM(nbasp),ptrN(nbasp) ! type, atom, l and m, and n - REAL, ALLOCATABLE :: gridf(:,:) ! grid for radial integration - REAL :: k_G(3,noGPts) ! k + G - REAL :: AbsK_G(noGPts),AbsK_G2(noGPts) ! abs(k+G), abs(k+G)^2 - REAL :: arg(noGPts) ! abs(k+G)^2 / (4*omega^2) - REAL :: sphbesK_Gr(noGPts,jmtd,0:maxlcutm,ntype) ! spherical bessel function of abs(k+G)r - TYPE(intgrf_out) :: intgrMT(noGPts,maxindxm,0:maxlcutm,ntype) ! integration in muffin-tin - COMPLEX :: imgl(0:maxlcutm) ! i^l - COMPLEX :: Ylm(noGPts,(maxlcutm+1)**2) ! spherical harmonics for k+G and all lm - COMPLEX :: expIGR(noGPts,ntype,MAXVAL(neq)) ! exp(-iGR) for all atom types - COMPLEX :: muffintin(noGPts,maxindxm,& ! muffin-tin overlap integral - (maxlcutm+1)**2,ntype,MAXVAL(neq)) + COMPLEX, PARAMETER :: img = (0.0, 1.0) ! i + + ! private arrays + INTEGER :: gPts(3, noGPts) ! g vectors (internal units) + INTEGER :: natdPtr(ntype + 1) ! pointer to all atoms of one type + INTEGER :: ptrType(nbasp), ptrEq(nbasp), & ! pointer from ibasp to corresponding + ptrLM(nbasp), ptrN(nbasp) ! type, atom, l and m, and n + REAL, ALLOCATABLE :: gridf(:, :) ! grid for radial integration + REAL :: k_G(3, noGPts) ! k + G + REAL :: AbsK_G(noGPts), AbsK_G2(noGPts) ! abs(k+G), abs(k+G)^2 + REAL :: arg(noGPts) ! abs(k+G)^2 / (4*omega^2) + REAL :: sphbesK_Gr(noGPts, jmtd, 0:maxlcutm, ntype) ! spherical bessel function of abs(k+G)r + TYPE(intgrf_out) :: intgrMT(noGPts, maxindxm, 0:maxlcutm, ntype) ! integration in muffin-tin + COMPLEX :: imgl(0:maxlcutm) ! i^l + COMPLEX :: Ylm(noGPts, (maxlcutm + 1)**2) ! spherical harmonics for k+G and all lm + COMPLEX :: expIGR(noGPts, ntype, MAXVAL(neq)) ! exp(-iGR) for all atom types + COMPLEX :: muffintin(noGPts, maxindxm, & ! muffin-tin overlap integral + (maxlcutm + 1)**2, ntype, MAXVAL(neq)) #ifdef CPP_INVERSION - COMPLEX :: sym_muffintin(nbasp,noGPts) ! symmetrized muffin tin + COMPLEX :: sym_muffintin(nbasp, noGPts) ! symmetrized muffin tin #endif - LOGICAL, SAVE :: first_entry = .TRUE. ! allocate arrays in first entry - - ! allocate arrays in first entry reuse later - IF ( first_entry ) THEN - ALLOCATE ( already_known(nkptf), & ! stores which elements are known - known_potential(maxNoGPts,nkptf), & ! stores the potential for all k-points - known_fourier_trafo(nbasp, maxNoGPts,nkptf) ) ! stores the fourier transform of the mixed basis - ! initialization - already_known = .FALSE. - known_potential = 0.0 - known_fourier_trafo = 0.0 - ! unset flag as arrays are allocated - first_entry = .FALSE. - ELSE - ! check if size of arrays has changed and stop with error if they did - IF ( SIZE(already_known) /= nkptf ) STOP 'hsefunctional: Array size changed!' - IF ( SIZE(known_fourier_trafo,1) /= nbasp ) STOP 'hsefunctional: Array size changed!' - END IF - - ! if the current k-point was not calculated yet - IF ( .NOT.(already_known(ikpt)) ) THEN - - ! Calculate helper variables - r2Pi = 2.0 * pi_const - r4Pi = 4.0 * pi_const - sVol = SQRT(vol) - r4Pi_sVol = r4Pi / sVol - r4Pi_Vol = r4Pi / Vol - omega = omega_hse!omega_VHSE() - r1_omega2 = 1.0 / omega**2 - r1_4omega2 = 0.25 * r1_omega2 - pi_omega2 = pi_const * r1_omega2 - - ! calculate pointers for all atom-types to all atoms - natdPtr(ntype+1) = natd - DO cn=ntype,1,-1 - natdPtr(cn) = natdPtr(cn+1) - neq(cn) - END DO - - ! Define imgl(l) = img**l - imgl(0) = 1.0 - DO ci=1,maxlcutm - imgl(ci) = imgl(ci-1) * img - END DO - - ! generate grid for fast radial integration - CALL intgrf_init(ntype,jmtd,jri,dx,rmsh,gridf) + LOGICAL, SAVE :: first_entry = .TRUE. ! allocate arrays in first entry + + ! allocate arrays in first entry reuse later + IF (first_entry) THEN + ALLOCATE (already_known(nkptf), & ! stores which elements are known + known_potential(maxNoGPts, nkptf), & ! stores the potential for all k-points + known_fourier_trafo(nbasp, maxNoGPts, nkptf)) ! stores the fourier transform of the mixed basis + ! initialization + already_known = .FALSE. + known_potential = 0.0 + known_fourier_trafo = 0.0 + ! unset flag as arrays are allocated + first_entry = .FALSE. + ELSE + ! check if size of arrays has changed and stop with error if they did + IF (SIZE(already_known) /= nkptf) STOP 'hsefunctional: Array size changed!' + IF (SIZE(known_fourier_trafo, 1) /= nbasp) STOP 'hsefunctional: Array size changed!' + END IF - ! Set all arrays to 0 - gPts = 0 - k_G = 0 - AbsK_G = 0 - arg = 0 - sphbesK_Gr = 0 - intgrMT%value = 0 - intgrMT%ierror = 0 - Ylm = 0 - expIGR = 0 - potential = 0 - muffintin = 0 + ! if the current k-point was not calculated yet + IF (.NOT. (already_known(ikpt))) THEN + + ! Calculate helper variables + r2Pi = 2.0*pi_const + r4Pi = 4.0*pi_const + sVol = SQRT(vol) + r4Pi_sVol = r4Pi/sVol + r4Pi_Vol = r4Pi/Vol + omega = omega_hse!omega_VHSE() + r1_omega2 = 1.0/omega**2 + r1_4omega2 = 0.25*r1_omega2 + pi_omega2 = pi_const*r1_omega2 + + ! calculate pointers for all atom-types to all atoms + natdPtr(ntype + 1) = natd + DO cn = ntype, 1, -1 + natdPtr(cn) = natdPtr(cn + 1) - neq(cn) + END DO + + ! Define imgl(l) = img**l + imgl(0) = 1.0 + DO ci = 1, maxlcutm + imgl(ci) = imgl(ci - 1)*img + END DO + + ! generate grid for fast radial integration + CALL intgrf_init(ntype, jmtd, jri, dx, rmsh, gridf) + + ! Set all arrays to 0 + gPts = 0 + k_G = 0 + AbsK_G = 0 + arg = 0 + sphbesK_Gr = 0 + intgrMT%value = 0 + intgrMT%ierror = 0 + Ylm = 0 + expIGR = 0 + potential = 0 + muffintin = 0 ! Calculate the muffin-tin basis function overlap integral ! R @@ -1440,67 +1438,67 @@ CONTAINS ! G,I \ | k,I / Sqrt(Om) LM | L ! / ! 0 - IF (ngptm < noGpts) STOP 'hsefunctional: error calculating Fourier coefficients, noGpts too large' - - gPts(:,:) = gptm(:,pgptm(1:noGPts)) - - gpoints: FORALL ( cg=1:noGPts ) - ntypesA: FORALL ( cn=1:ntype ) - - ! Calculate the phase factor exp(-iGR) for all atoms - FORALL ( ci=1:neq(cn) ) - expIGR(cg,cn,ci) = EXP( -r2Pi * img * DOT_PRODUCT(taual(:,natdPtr(cn)+ci),gPts(:,cg)) ) - muffintin(cg,:,:,cn,ci) = r4Pi_sVol * expIGR(cg,cn,ci) - END FORALL - - ! Multiplication with i^-L - FORALL ( cl=0:lcutm(cn) ) - muffintin(cg,:,cl*cl+1:(cl+1)*(cl+1),cn,:) = muffintin(cg,:,cl*cl+1:(cl+1)*(cl+1),cn,:) / imgl(cl) - END FORALL - - END FORALL ntypesA - - ! Calculate the k+G, abs(k+G), and abs(k+G)^2 - k_G(:,cg) = MATMUL( gPts(:,cg)+bk(:), bmat(:,:) ) - AbsK_G2(cg) = SUM( k_G(:,cg)**2 ) - AbsK_G(cg) = SQRT(AbsK_G2(cg)) - - ! Spherical harmonics are calculated for all lm's and k+G's - Ylm(cg,:) = calcYlm(k_G(:,cg),maxlcutm) - - ! Perform the integration in eq.[2] for all muffin-tins - ntypesB: FORALL ( cn=1:ntype ) - - ! Multiplication with the spherical harmonic - FORALL ( cl=1:(lcutm(cn)+1)**2 ) - muffintin(cg,:,cl,cn,:) = muffintin(cg,:,cl,cn,:) * Ylm(cg,cl) - END FORALL - - ! Calculate the spherical bessel function - FORALL ( cr=1:jri(cn) ) - sphbesK_Gr(cg,cr,:,cn) = calcSphBes(AbsK_G(cg)*rmsh(cr,cn),maxlcutm) - END FORALL - ! integrate the function and multiplicate to the result - FORALL ( cl=0:lcutm(cn) ) - FORALL ( ci=1:nindxm(cl,cn) ) - intgrMT(cg,ci,cl,cn) = pure_intgrf(rmsh(:,cn) * basm(:,ci,cl,cn) * & - sphbesK_Gr(cg,:,cl,cn),jri,jmtd,rmsh,dx,ntype,cn,gridf) - muffintin(cg,ci,cl*cl+1:(cl+1)*(cl+1),cn,:) = & - muffintin(cg,ci,cl*cl+1:(cl+1)*(cl+1),cn,:) * intgrMT(cg,ci,cl,cn)%value - END FORALL - END FORALL - - END FORALL ntypesB - - END FORALL gpoints - - ! Check if any of the integrations failed and abort if one did - IF ( ANY( intgrMT%ierror == NEGATIVE_EXPONENT_ERROR ) ) THEN - IF ( irank == 0 ) WRITE(6,*) 'intgrf: Warning! Negative exponent x in extrapolation a+c*r**x' - ELSEIF ( ANY( intgrMT%ierror == NEGATIVE_EXPONENT_WARNING ) ) THEN - IF ( irank == 0 ) WRITE(6,*) 'intgrf: Negative exponent x in extrapolation a+c*r**x' - STOP 'intgrf: Negative exponent x in extrapolation a+c*r**x' - END IF + IF (ngptm < noGpts) STOP 'hsefunctional: error calculating Fourier coefficients, noGpts too large' + + gPts(:, :) = gptm(:, pgptm(1:noGPts)) + + gpoints:FORALL (cg=1:noGPts) + ntypesA:FORALL (cn=1:ntype) + + ! Calculate the phase factor exp(-iGR) for all atoms + FORALL (ci=1:neq(cn)) + expIGR(cg, cn, ci) = EXP(-r2Pi*img*DOT_PRODUCT(taual(:, natdPtr(cn) + ci), gPts(:, cg))) + muffintin(cg, :, :, cn, ci) = r4Pi_sVol*expIGR(cg, cn, ci) + END FORALL + + ! Multiplication with i^-L + FORALL (cl=0:lcutm(cn)) + muffintin(cg, :, cl*cl + 1:(cl + 1)*(cl + 1), cn, :) = muffintin(cg, :, cl*cl + 1:(cl + 1)*(cl + 1), cn, :)/imgl(cl) + END FORALL + + END FORALL ntypesA + + ! Calculate the k+G, abs(k+G), and abs(k+G)^2 + k_G(:, cg) = MATMUL(gPts(:, cg) + bk(:), bmat(:, :)) + AbsK_G2(cg) = SUM(k_G(:, cg)**2) + AbsK_G(cg) = SQRT(AbsK_G2(cg)) + + ! Spherical harmonics are calculated for all lm's and k+G's + Ylm(cg, :) = calcYlm(k_G(:, cg), maxlcutm) + + ! Perform the integration in eq.[2] for all muffin-tins + ntypesB:FORALL (cn=1:ntype) + + ! Multiplication with the spherical harmonic + FORALL (cl=1:(lcutm(cn) + 1)**2) + muffintin(cg, :, cl, cn, :) = muffintin(cg, :, cl, cn, :)*Ylm(cg, cl) + END FORALL + + ! Calculate the spherical bessel function + FORALL (cr=1:jri(cn)) + sphbesK_Gr(cg, cr, :, cn) = calcSphBes(AbsK_G(cg)*rmsh(cr, cn), maxlcutm) + END FORALL + ! integrate the function and multiplicate to the result + FORALL (cl=0:lcutm(cn)) + FORALL (ci=1:nindxm(cl, cn)) + intgrMT(cg, ci, cl, cn) = pure_intgrf(rmsh(:, cn)*basm(:, ci, cl, cn)* & + sphbesK_Gr(cg, :, cl, cn), jri, jmtd, rmsh, dx, ntype, cn, gridf) + muffintin(cg, ci, cl*cl + 1:(cl + 1)*(cl + 1), cn, :) = & + muffintin(cg, ci, cl*cl + 1:(cl + 1)*(cl + 1), cn, :)*intgrMT(cg, ci, cl, cn)%value + END FORALL + END FORALL + + END FORALL ntypesB + + END FORALL gpoints + + ! Check if any of the integrations failed and abort if one did + IF (ANY(intgrMT%ierror == NEGATIVE_EXPONENT_ERROR)) THEN + IF (irank == 0) WRITE (6, *) 'intgrf: Warning! Negative exponent x in extrapolation a+c*r**x' + ELSEIF (ANY(intgrMT%ierror == NEGATIVE_EXPONENT_WARNING)) THEN + IF (irank == 0) WRITE (6, *) 'intgrf: Negative exponent x in extrapolation a+c*r**x' + STOP 'intgrf: Negative exponent x in extrapolation a+c*r**x' + END IF ! Calculate the Fourier transformed potential ! / \ @@ -1508,12 +1506,12 @@ CONTAINS ! V (k) = ( k + G | --- | k + G' ) = ------- Exp| - ------- | kronecker(G,G') [1] ! G \ | r | / |k+G|^2 | 4 w^2 | ! \ / - WHERE ( absK_G.NE.0 ) - ! Calculate (k+G)^2 / 4*w^2 - arg = -r1_4omega2 * AbsK_G2 + WHERE (absK_G /= 0) + ! Calculate (k+G)^2 / 4*w^2 + arg = -r1_4omega2*AbsK_G2 - ! The potential is calculated using eq.[1] - potential = r4Pi / AbsK_G2 * EXP(arg) + ! The potential is calculated using eq.[1] + potential = r4Pi/AbsK_G2*EXP(arg) ! Calculate the Fourier transformed potential for the full(!) potential ! @@ -1521,917 +1519,914 @@ CONTAINS ! V (k) = ( k + G = 0 | ---- | k + G = 0 ) = ----- ! G \ | r | / w^2 ! - ELSEWHERE - ! the negative sign is added to compensate the sign when the - ! contribution is added to the Coulomb matrix - potential = -pi_omega2 - endwhere - - DEALLOCATE( gridf ) - - ! - ! Create pointer which correlate the position in the array with the - ! appropriate indices of the MT mixed basis function - ! - cg = 0 - DO cn=1,ntype - DO ci=1,neq(cn) - DO cl=0,lcutm(cn) - DO cm=-cl,cl - DO cr=1,nindxm(cl,cn) - cg = cg + 1 - ptrType(cg) = cn - ptrEq(cg) = ci - ptrLM(cg) = (cl+1)*cl+cm+1 - ptrN(cg) = cr - END DO + ELSEWHERE + ! the negative sign is added to compensate the sign when the + ! contribution is added to the Coulomb matrix + potential = -pi_omega2 + endwhere + + DEALLOCATE (gridf) + + ! + ! Create pointer which correlate the position in the array with the + ! appropriate indices of the MT mixed basis function + ! + cg = 0 + DO cn = 1, ntype + DO ci = 1, neq(cn) + DO cl = 0, lcutm(cn) + DO cm = -cl, cl + DO cr = 1, nindxm(cl, cn) + cg = cg + 1 + ptrType(cg) = cn + ptrEq(cg) = ci + ptrLM(cg) = (cl + 1)*cl + cm + 1 + ptrN(cg) = cr + END DO + END DO + END DO END DO - END DO - END DO - END DO - IF ( nbasp /= cg ) STOP 'hsefunctional: wrong array size: nbasp' + END DO + IF (nbasp /= cg) STOP 'hsefunctional: wrong array size: nbasp' #ifdef CPP_INVERSION - ! Symmetrize muffin tin fourier transform - DO ci=1,nbasp - sym_muffintin(ci,:noGPts) = muffintin(:,ptrN(ci),ptrLM(ci),ptrType(ci),ptrEq(ci)) - END DO - DO cg=1,noGPts - CALL symmetrize( sym_muffintin(:,cg),1,nbasp,2,.FALSE., & - ntype,ntype,neq,lcutm,maxlcutm, & - nindxm,natd,invsat,invsatnr ) - END DO - ! store the fourier transform of the muffin tin basis - known_fourier_trafo(:,:,ikpt) = REAL( sym_muffintin ) + ! Symmetrize muffin tin fourier transform + DO ci = 1, nbasp + sym_muffintin(ci, :noGPts) = muffintin(:, ptrN(ci), ptrLM(ci), ptrType(ci), ptrEq(ci)) + END DO + DO cg = 1, noGPts + CALL symmetrize(sym_muffintin(:, cg), 1, nbasp, 2, .FALSE., & + ntype, ntype, neq, lcutm, maxlcutm, & + nindxm, natd, invsat, invsatnr) + END DO + ! store the fourier transform of the muffin tin basis + known_fourier_trafo(:, :, ikpt) = REAL(sym_muffintin) #else - ! store the fourier transform of the muffin tin basis - DO ci=1,nbasp - known_fourier_trafo(ci,:noGPts,ikpt) = CONJG( muffintin(:,ptrN(ci),ptrLM(ci),ptrType(ci),ptrEq(ci)) ) - END DO + ! store the fourier transform of the muffin tin basis + DO ci = 1, nbasp + known_fourier_trafo(ci, :noGPts, ikpt) = CONJG(muffintin(:, ptrN(ci), ptrLM(ci), ptrType(ci), ptrEq(ci))) + END DO #endif - ! store the fourier transform of the potential - known_potential(:noGPts,ikpt) = potential - ! set the flag so that the fourier transform is not calculated again - already_known(ikpt) = .TRUE. - IF ( MINVAL( ABS(potential) ) > 1e-12 ) THEN - WRITE(*,*) 'hsefunctional: Warning! Smallest potential bigger than numerical precision!', MINVAL( ABS(potential) ) - WRITE(*,*) 'Perhaps you should increase the number of g-Points used and recompile!' + ! store the fourier transform of the potential + known_potential(:noGPts, ikpt) = potential + ! set the flag so that the fourier transform is not calculated again + already_known(ikpt) = .TRUE. + IF (MINVAL(ABS(potential)) > 1e-12) THEN + WRITE (*, *) 'hsefunctional: Warning! Smallest potential bigger than numerical precision!', MINVAL(ABS(potential)) + WRITE (*, *) 'Perhaps you should increase the number of g-Points used and recompile!' + END IF + END IF - END IF - - ! return the fourier transform - potential = known_potential(:noGPts,ikpt) - fourier_trafo = known_fourier_trafo(:,:noGPts,ikpt) - - END SUBROUTINE calculate_fourier_transform_once - - ! Correct the pure Coulomb Matrix with by subtracting the long-range component - ! - ! / | | \ / | | \ / | | \ - ! ( M | V | M ) = ( M | V | M ) - ( M | V | M ) - ! \ k,I | HSE | k,J / \ k,I | coul | k,J / \ k,I | LR | k,J / - ! - ! The long-range component is given py the potential - ! - ! erf( w r ) - ! V (r) = ---------- - ! LR r - ! - ! Input: - ! rmsh - array of radial mesh points - ! rmt - radius of the muffin tin - ! dx - logarithmic increment of radial mesh - ! jri - number of radial mesh points - ! jmtd - dimension of radial mesh points - ! nkptf - number of total k-points - ! nkptd - dimension of k-points - ! nkpti - number of irreducible k-points in window (in KPTS) - ! bk - k-vector for all irreduble k-points - ! bmat - reciprocal lattice vector for all directions - ! vol - volume of unit cell - ! ntype - number of atom types - ! neq - number of symmetry-equivalent atoms of atom type i - ! natd - dimension of atoms in unit cell - ! taual - vector of atom positions (internal coordinates) - ! lcutm - l cutoff for mixed basis - ! maxlcutm - maximum of all these l cutoffs - ! nindxm - number of radial functions of mixed basis - ! maxindxm - maximum of these numbers - ! gptm - reciprocal lattice vectors of the mixed basis (internal coord.) - ! ngptm - number of vectors - ! pgptm - pointer to the appropriate g-vector - ! gptmd - dimension of gptm - ! basm - radial mixed basis functions (mt + inter) - ! lexp - cutoff of spherical harmonics expansion of plane wave - ! maxbasm - maximum number of mixed basis functions - ! nbasm - number of mixed basis function - ! invsat - number of inversion-symmetric atom - ! invsatnr - number of inversion-symmetric atom - ! Inout: - ! coulomb - Coulomb matrix which is changed - SUBROUTINE change_coulombmatrix(& + ! return the fourier transform + potential = known_potential(:noGPts, ikpt) + fourier_trafo = known_fourier_trafo(:, :noGPts, ikpt) + + END SUBROUTINE calculate_fourier_transform_once + + ! Correct the pure Coulomb Matrix with by subtracting the long-range component + ! + ! / | | \ / | | \ / | | \ + ! ( M | V | M ) = ( M | V | M ) - ( M | V | M ) + ! \ k,I | HSE | k,J / \ k,I | coul | k,J / \ k,I | LR | k,J / + ! + ! The long-range component is given py the potential + ! + ! erf( w r ) + ! V (r) = ---------- + ! LR r + ! + ! Input: + ! rmsh - array of radial mesh points + ! rmt - radius of the muffin tin + ! dx - logarithmic increment of radial mesh + ! jri - number of radial mesh points + ! jmtd - dimension of radial mesh points + ! nkptf - number of total k-points + ! nkptd - dimension of k-points + ! nkpti - number of irreducible k-points in window (in KPTS) + ! bk - k-vector for all irreduble k-points + ! bmat - reciprocal lattice vector for all directions + ! vol - volume of unit cell + ! ntype - number of atom types + ! neq - number of symmetry-equivalent atoms of atom type i + ! natd - dimension of atoms in unit cell + ! taual - vector of atom positions (internal coordinates) + ! lcutm - l cutoff for mixed basis + ! maxlcutm - maximum of all these l cutoffs + ! nindxm - number of radial functions of mixed basis + ! maxindxm - maximum of these numbers + ! gptm - reciprocal lattice vectors of the mixed basis (internal coord.) + ! ngptm - number of vectors + ! pgptm - pointer to the appropriate g-vector + ! gptmd - dimension of gptm + ! basm - radial mixed basis functions (mt + inter) + ! lexp - cutoff of spherical harmonics expansion of plane wave + ! maxbasm - maximum number of mixed basis functions + ! nbasm - number of mixed basis function + ! invsat - number of inversion-symmetric atom + ! invsatnr - number of inversion-symmetric atom + ! Inout: + ! coulomb - Coulomb matrix which is changed + SUBROUTINE change_coulombmatrix( & ! Input - rmsh,rmt,dx,jri,jmtd,nkptf,nkptd,nkpti,bk, & - bmat,vol,ntype,neq,natd,taual,lcutm,maxlcutm, & - nindxm,maxindxm,gptm,ngptm,pgptm,gptmd, & - basm,lexp,maxbasm,nbasm,invsat,invsatnr,irank, & + rmsh, rmt, dx, jri, jmtd, nkptf, nkptd, nkpti, bk, & + bmat, vol, ntype, neq, natd, taual, lcutm, maxlcutm, & + nindxm, maxindxm, gptm, ngptm, pgptm, gptmd, & + basm, lexp, maxbasm, nbasm, invsat, invsatnr, irank, & ! Input & output coulomb) - USE m_trafo, ONLY: symmetrize - USE m_wrapper, ONLY: packmat, unpackmat, diagonalize, inverse - USE m_olap, ONLY: olap_pw - - IMPLICIT NONE - - ! scalar input - INTEGER, INTENT(IN) :: natd,ntype,maxlcutm,lexp - INTEGER, INTENT(IN) :: jmtd,nkptf,nkptd,nkpti - INTEGER, INTENT(IN) :: maxindxm - INTEGER, INTENT(IN) :: gptmd,irank - INTEGER, INTENT(IN) :: maxbasm - REAL, INTENT(IN) :: vol - - ! array input - INTEGER, INTENT(IN) :: lcutm(ntype) - INTEGER, INTENT(IN) :: nindxm(0:maxlcutm,ntype),neq(ntype) - INTEGER, INTENT(IN) :: jri(ntype) - INTEGER, INTENT(IN) :: gptm(3,gptmd) - INTEGER, INTENT(IN) :: ngptm(nkptf) - INTEGER, INTENT(IN) :: pgptm(MAXVAL(ngptm),nkptf) - INTEGER, INTENT(IN) :: nbasm(nkptf) - INTEGER, INTENT(IN) :: invsat(natd),invsatnr(natd) - - REAL, INTENT(IN) :: bk(3,nkptd) - REAL, INTENT(IN) :: rmsh(jmtd,ntype),rmt(ntype),dx(ntype) - REAL, INTENT(IN) :: basm(jmtd,maxindxm,0:maxlcutm,ntype) - REAL, INTENT(IN) :: bmat(3,3) - REAL, INTENT(IN) :: taual(3,natd) - - ! array inout + USE m_trafo, ONLY: symmetrize + USE m_wrapper, ONLY: packmat, unpackmat, diagonalize, inverse + USE m_olap, ONLY: olap_pw + + IMPLICIT NONE + + ! scalar input + INTEGER, INTENT(IN) :: natd, ntype, maxlcutm, lexp + INTEGER, INTENT(IN) :: jmtd, nkptf, nkptd, nkpti + INTEGER, INTENT(IN) :: maxindxm + INTEGER, INTENT(IN) :: gptmd, irank + INTEGER, INTENT(IN) :: maxbasm + REAL, INTENT(IN) :: vol + + ! array input + INTEGER, INTENT(IN) :: lcutm(ntype) + INTEGER, INTENT(IN) :: nindxm(0:maxlcutm, ntype), neq(ntype) + INTEGER, INTENT(IN) :: jri(ntype) + INTEGER, INTENT(IN) :: gptm(3, gptmd) + INTEGER, INTENT(IN) :: ngptm(nkptf) + INTEGER, INTENT(IN) :: pgptm(MAXVAL(ngptm), nkptf) + INTEGER, INTENT(IN) :: nbasm(nkptf) + INTEGER, INTENT(IN) :: invsat(natd), invsatnr(natd) + + REAL, INTENT(IN) :: bk(3, nkptd) + REAL, INTENT(IN) :: rmsh(jmtd, ntype), rmt(ntype), dx(ntype) + REAL, INTENT(IN) :: basm(jmtd, maxindxm, 0:maxlcutm, ntype) + REAL, INTENT(IN) :: bmat(3, 3) + REAL, INTENT(IN) :: taual(3, natd) + + ! array inout #ifdef CPP_INVERSION - REAL, INTENT(INOUT) :: coulomb(maxbasm*(maxbasm+1)/2,nkpti) + REAL, INTENT(INOUT) :: coulomb(maxbasm*(maxbasm + 1)/2, nkpti) #else - COMPLEX, INTENT(INOUT) :: coulomb(maxbasm*(maxbasm+1)/2,nkpti) + COMPLEX, INTENT(INOUT) :: coulomb(maxbasm*(maxbasm + 1)/2, nkpti) #endif - ! private scalars - INTEGER :: ikpt,itype,ieq,il,im,iindxm,idum,n1,n2,ok ! counters and other helper variables - INTEGER :: noGPts,nbasp ! no used g-vectors, no MT functions - - ! private arrays - INTEGER, ALLOCATABLE :: ptrType(:),ptrEq(:),ptrL(:),ptrM(:),ptrN(:) ! Pointer - REAL :: potential(maxNoGPts) ! Fourier transformed potential - COMPLEX :: muffintin(maxNoGPts,maxindxm,& ! muffin-tin overlap integral - (maxlcutm+1)**2,ntype,MAXVAL(neq)) - COMPLEX :: interstitial(maxNoGPts,gptmd) ! interstistial overlap intergral - COMPLEX, ALLOCATABLE :: coulmat(:,:) ! helper array to symmetrize coulomb - - ! Check size of arrays - IF (nkpti > nkptd) STOP 'hsefunctional: missmatch in dimension of arrays' - nbasp = maxbasm - MAXVAL(ngptm) - IF ( ANY( nbasm - ngptm /= nbasp ) ) STOP 'hsefunctional: wrong assignment of nbasp' - - ! - ! Create pointer which correlate the position in the array with the - ! appropriate indices of the MT mixed basis function - ! - ALLOCATE( ptrType(nbasp), ptrEq(nbasp), ptrL(nbasp), ptrM(nbasp), ptrN(nbasp) ) - nbasp = 0 - DO itype=1,ntype - DO ieq=1,neq(itype) - DO il=0,lcutm(itype) - DO im=-il,il - DO iindxm=1,nindxm(il,itype) - nbasp = nbasp + 1 - ptrType(nbasp) = itype - ptrEq(nbasp) = ieq - ptrL(nbasp) = il - ptrM(nbasp) = im - ptrN(nbasp) = iindxm - END DO - END DO - END DO - END DO - END DO - - ! - ! Change the Coulomb matrix for all k-points - ! - DO ikpt=1,nkpti - ! use the same g-vectors as in the mixed basis - ! adjust the limit of the array if necessary - IF (ngptm(ikpt) < maxNoGPts) THEN - noGPts = ngptm(ikpt) - ELSE - noGPts = maxNoGPts - END IF + ! private scalars + INTEGER :: ikpt, itype, ieq, il, im, iindxm, idum, n1, n2, ok ! counters and other helper variables + INTEGER :: noGPts, nbasp ! no used g-vectors, no MT functions + + ! private arrays + INTEGER, ALLOCATABLE :: ptrType(:), ptrEq(:), ptrL(:), ptrM(:), ptrN(:) ! Pointer + REAL :: potential(maxNoGPts) ! Fourier transformed potential + COMPLEX :: muffintin(maxNoGPts, maxindxm, & ! muffin-tin overlap integral + (maxlcutm + 1)**2, ntype, MAXVAL(neq)) + COMPLEX :: interstitial(maxNoGPts, gptmd) ! interstistial overlap intergral + COMPLEX, ALLOCATABLE :: coulmat(:, :) ! helper array to symmetrize coulomb + + ! Check size of arrays + IF (nkpti > nkptd) STOP 'hsefunctional: missmatch in dimension of arrays' + nbasp = maxbasm - MAXVAL(ngptm) + IF (ANY(nbasm - ngptm /= nbasp)) STOP 'hsefunctional: wrong assignment of nbasp' ! - ! Calculate the Fourier transform of the mixed basis and the potential + ! Create pointer which correlate the position in the array with the + ! appropriate indices of the MT mixed basis function ! - CALL calculate_fourier_transform( & - ! Input - rmsh,rmt,dx,jri,jmtd,bk(:,ikpt),& - bmat,vol,ntype,neq,natd,taual,lcutm,maxlcutm,& - nindxm,maxindxm,gptm,ngptm(ikpt),pgptm(:,ikpt),gptmd,& - basm,noGPts,irank,& - ! Output - potential,muffintin,interstitial) - interstitial = CONJG(interstitial) - - ! Helper matrix for temporary storage of the attenuated Coulomb matrix - ALLOCATE ( coulmat(nbasm(ikpt),nbasm(ikpt)) , stat=ok ) - IF ( ok /= 0 ) STOP 'hsefunctional: failure at matrix allocation' - coulmat = 0 + ALLOCATE (ptrType(nbasp), ptrEq(nbasp), ptrL(nbasp), ptrM(nbasp), ptrN(nbasp)) + nbasp = 0 + DO itype = 1, ntype + DO ieq = 1, neq(itype) + DO il = 0, lcutm(itype) + DO im = -il, il + DO iindxm = 1, nindxm(il, itype) + nbasp = nbasp + 1 + ptrType(nbasp) = itype + ptrEq(nbasp) = ieq + ptrL(nbasp) = il + ptrM(nbasp) = im + ptrN(nbasp) = iindxm + END DO + END DO + END DO + END DO + END DO + ! - ! Calculate the difference of the Coulomb matrix by the attenuation + ! Change the Coulomb matrix for all k-points ! - DO n1 = 1,nbasp - DO n2 = 1,n1 - ! muffin tin - muffin tin contribution - coulmat(n2,n1) = - gPtsSummation( noGpts,& - muffintin(:,ptrN(n2),(ptrL(n2)+1)*ptrL(n2)+ptrM(n2)+1,ptrType(n2),ptrEq(n2)),potential,& - CONJG(muffintin(:,ptrN(n1),(ptrL(n1)+1)*ptrL(n1)+ptrM(n1)+1,ptrType(n1),ptrEq(n1))) ) - coulmat(n1,n2) = CONJG(coulmat(n2,n1)) - END DO - END DO - DO n1 = nbasp+1,nbasm(ikpt) - DO n2 = 1,n1 - IF ( n2 <= nbasp ) THEN - ! muffin tin - interstitial contribution - coulmat(n2,n1) = - gPtsSummation( noGPts,& - muffintin(:,ptrN(n2),(ptrL(n2)+1)*ptrL(n2)+ptrM(n2)+1,ptrType(n2),ptrEq(n2)),& - potential,CONJG(interstitial(:,pgptm(n1-nbasp,ikpt))) ) - coulmat(n1,n2) = CONJG(coulmat(n2,n1)) - ELSE - ! interstitial - interstitial contribution - coulmat(n2,n1) = - gPtsSummation( noGPts,& - interstitial(:,pgptm(n2-nbasp,ikpt)),potential,& - CONJG(interstitial(:,pgptm(n1-nbasp,ikpt))) ) - coulmat(n1,n2) = CONJG(coulmat(n2,n1)) - END IF - END DO - END DO + DO ikpt = 1, nkpti + ! use the same g-vectors as in the mixed basis + ! adjust the limit of the array if necessary + IF (ngptm(ikpt) < maxNoGPts) THEN + noGPts = ngptm(ikpt) + ELSE + noGPts = maxNoGPts + END IF + + ! + ! Calculate the Fourier transform of the mixed basis and the potential + ! + CALL calculate_fourier_transform( & + ! Input + rmsh, rmt, dx, jri, jmtd, bk(:, ikpt), & + bmat, vol, ntype, neq, natd, taual, lcutm, maxlcutm, & + nindxm, maxindxm, gptm, ngptm(ikpt), pgptm(:, ikpt), gptmd, & + basm, noGPts, irank, & + ! Output + potential, muffintin, interstitial) + interstitial = CONJG(interstitial) + + ! Helper matrix for temporary storage of the attenuated Coulomb matrix + ALLOCATE (coulmat(nbasm(ikpt), nbasm(ikpt)), stat=ok) + IF (ok /= 0) STOP 'hsefunctional: failure at matrix allocation' + coulmat = 0 + ! + ! Calculate the difference of the Coulomb matrix by the attenuation + ! + DO n1 = 1, nbasp + DO n2 = 1, n1 + ! muffin tin - muffin tin contribution + coulmat(n2, n1) = -gPtsSummation(noGpts, & + muffintin(:, ptrN(n2), (ptrL(n2) + 1)*ptrL(n2) + ptrM(n2) + 1, ptrType(n2), ptrEq(n2)), potential, & + CONJG(muffintin(:, ptrN(n1), (ptrL(n1) + 1)*ptrL(n1) + ptrM(n1) + 1, ptrType(n1), ptrEq(n1)))) + coulmat(n1, n2) = CONJG(coulmat(n2, n1)) + END DO + END DO + DO n1 = nbasp + 1, nbasm(ikpt) + DO n2 = 1, n1 + IF (n2 <= nbasp) THEN + ! muffin tin - interstitial contribution + coulmat(n2, n1) = -gPtsSummation(noGPts, & + muffintin(:, ptrN(n2), (ptrL(n2) + 1)*ptrL(n2) + ptrM(n2) + 1, ptrType(n2), ptrEq(n2)), & + potential, CONJG(interstitial(:, pgptm(n1 - nbasp, ikpt)))) + coulmat(n1, n2) = CONJG(coulmat(n2, n1)) + ELSE + ! interstitial - interstitial contribution + coulmat(n2, n1) = -gPtsSummation(noGPts, & + interstitial(:, pgptm(n2 - nbasp, ikpt)), potential, & + CONJG(interstitial(:, pgptm(n1 - nbasp, ikpt)))) + coulmat(n1, n2) = CONJG(coulmat(n2, n1)) + END IF + END DO + END DO #ifdef CPP_INVERSION - ! symmetrize matrix if system has inversion symmetry - CALL symmetrize(coulmat,nbasm(ikpt),nbasm(ikpt),3,.FALSE., & - ntype,ntype,neq,lcutm,maxlcutm, & - nindxm,natd,invsat,invsatnr) + ! symmetrize matrix if system has inversion symmetry + CALL symmetrize(coulmat, nbasm(ikpt), nbasm(ikpt), 3, .FALSE., & + ntype, ntype, neq, lcutm, maxlcutm, & + nindxm, natd, invsat, invsatnr) #endif - ! add the changes to the Coulomb matrix - coulomb(:nbasm(ikpt)*(nbasm(ikpt)+1)/2,ikpt) = packmat( coulmat ) + coulomb(:nbasm(ikpt)*(nbasm(ikpt)+1)/2,ikpt) - DEALLOCATE ( coulmat ) - - END DO - - DEALLOCATE( ptrType, ptrEq, ptrL, ptrM, ptrN ) - - END SUBROUTINE change_coulombmatrix - - ! Correct the pure Coulomb Matrix with by subtracting the long-range component - ! during execution time - ! - ! / | | \ / | | \ / | | \ - ! ( M | V | M ) = ( M | V | M ) - ( M | V | M ) - ! \ k,I | HSE | k,J / \ k,I | coul | k,J / \ k,I | LR | k,J / - ! - ! The long-range component is given py the potential - ! - ! erf( w r ) - ! V (r) = ---------- - ! LR r - ! - ! Input: - ! rmsh - array of radial mesh points - ! rmt - radius of the muffin tin - ! dx - logarithmic increment of radial mesh - ! jri - number of radial mesh points - ! jmtd - dimension of radial mesh points - ! bk - k-vector for this k-point - ! ikpt - number of this k-point - ! nkptf - number of total k-points - ! bmat - reciprocal lattice vector for all directions - ! vol - volume of unit cell - ! ntype - number of atom types - ! neq - number of symmetry-equivalent atoms of atom type i - ! natd - dimension of atoms in unit cell - ! taual - vector of atom positions (internal coordinates) - ! lcutm - l cutoff for mixed basis - ! maxlcutm - maximum of all these l cutoffs - ! nindxm - number of radial functions of mixed basis - ! maxindxm - maximum of these numbers - ! gptm - reciprocal lattice vectors of the mixed basis (internal coord.) - ! ngptm - number of vectors - ! pgptm - pointer to the appropriate g-vector - ! gptmd - dimension of gptm - ! basm - radial mixed basis functions (mt + inter) - ! nbasm - number of mixed basis function - ! nobd - dimension of occupied bands - ! nbands - number of bands - ! nsst - size of indx - ! indx - pointer to bands - ! invsat - number of inversion-symmetric atom - ! invsatnr - number of inversion-symmetric atom - ! cprod - scalar product of mixed basis and wavefunction product basis - ! wl_iks - - ! n_q - - ! Return: - ! Change of the Coulomb matrix - FUNCTION dynamic_hse_adjustment( & - rmsh,rmt,dx,jri,jmtd,bk,ikpt,nkptf,bmat,vol,& - ntype,neq,natd,taual,lcutm,maxlcutm,nindxm,maxindxm,& - gptm,ngptm,pgptm,gptmd,basm,nbasm,& - nobd,nbands,nsst,ibando,psize,indx,invsat,invsatnr,irank,& - cprod_r,cprod_c,l_real,wl_iks,n_q) - - USE m_trafo, ONLY: symmetrize - USE m_olap, ONLY: olap_pw, olap_pwp - USE m_wrapper, ONLY: diagonalize, dotprod, matvec, packmat, inverse - - IMPLICIT NONE - - ! scalar input - INTEGER, INTENT(IN) :: natd,ntype,maxlcutm - INTEGER, INTENT(IN) :: jmtd,ikpt,nkptf - INTEGER, INTENT(IN) :: maxindxm - INTEGER, INTENT(IN) :: gptmd,irank - INTEGER, INTENT(IN) :: nbasm,nobd,nbands,ibando,psize - INTEGER, INTENT(IN) :: n_q - REAL, INTENT(IN) :: vol - - ! array input - INTEGER, INTENT(IN) :: lcutm(ntype) - INTEGER, INTENT(IN) :: nindxm(0:maxlcutm,ntype),neq(ntype) - INTEGER, INTENT(IN) :: jri(ntype) - INTEGER, INTENT(IN) :: gptm(3,gptmd) - INTEGER, INTENT(IN) :: ngptm - INTEGER, INTENT(IN) :: pgptm(ngptm) - INTEGER, INTENT(IN) :: nsst(nbands),indx(nbands,nbands) - INTEGER, INTENT(IN) :: invsat(natd),invsatnr(natd) - REAL, INTENT(IN) :: bk(3) - REAL, INTENT(IN) :: rmsh(jmtd,ntype),rmt(ntype),dx(ntype) - REAL, INTENT(IN) :: basm(jmtd,maxindxm,0:maxlcutm,ntype) - REAL, INTENT(IN) :: bmat(3,3) - REAL, INTENT(IN) :: taual(3,natd) - REAL, INTENT(IN) :: wl_iks(nobd) - REAL, INTENT(IN) :: cprod_r(nbasm,psize,nbands) - COMPLEX, INTENT(IN) :: cprod_c(nbasm,psize,nbands) - LOGICAL,INTENT(IN) :: l_real - - ! return type definition - COMPLEX :: dynamic_hse_adjustment(nbands,nbands) - - ! private scalars - INTEGER :: noGpts,nbasp - INTEGER :: itype,ieq,il,im,iindxm,ibasp - INTEGER :: igpt,iobd,iobd0,isst,iband1,iband2 - COMPLEX :: cdum,gPtsSum - - ! private arrays - INTEGER, ALLOCATABLE :: ptrType(:),ptrEq(:),ptrL(:),ptrM(:),ptrN(:) ! pointer to reference muffintin-array - REAL :: potential(maxNoGPts) ! Fourier transformed potential - COMPLEX :: muffintin(maxNoGPts,maxindxm,& ! muffin-tin overlap integral - (maxlcutm+1)**2,ntype,MAXVAL(neq)) - COMPLEX :: interstitial(maxNoGPts,gptmd) ! interstistial overlap intergral + ! add the changes to the Coulomb matrix + coulomb(:nbasm(ikpt)*(nbasm(ikpt) + 1)/2, ikpt) = packmat(coulmat) + coulomb(:nbasm(ikpt)*(nbasm(ikpt) + 1)/2, ikpt) + DEALLOCATE (coulmat) + + END DO + + DEALLOCATE (ptrType, ptrEq, ptrL, ptrM, ptrN) + + END SUBROUTINE change_coulombmatrix + + ! Correct the pure Coulomb Matrix with by subtracting the long-range component + ! during execution time + ! + ! / | | \ / | | \ / | | \ + ! ( M | V | M ) = ( M | V | M ) - ( M | V | M ) + ! \ k,I | HSE | k,J / \ k,I | coul | k,J / \ k,I | LR | k,J / + ! + ! The long-range component is given py the potential + ! + ! erf( w r ) + ! V (r) = ---------- + ! LR r + ! + ! Input: + ! rmsh - array of radial mesh points + ! rmt - radius of the muffin tin + ! dx - logarithmic increment of radial mesh + ! jri - number of radial mesh points + ! jmtd - dimension of radial mesh points + ! bk - k-vector for this k-point + ! ikpt - number of this k-point + ! nkptf - number of total k-points + ! bmat - reciprocal lattice vector for all directions + ! vol - volume of unit cell + ! ntype - number of atom types + ! neq - number of symmetry-equivalent atoms of atom type i + ! natd - dimension of atoms in unit cell + ! taual - vector of atom positions (internal coordinates) + ! lcutm - l cutoff for mixed basis + ! maxlcutm - maximum of all these l cutoffs + ! nindxm - number of radial functions of mixed basis + ! maxindxm - maximum of these numbers + ! gptm - reciprocal lattice vectors of the mixed basis (internal coord.) + ! ngptm - number of vectors + ! pgptm - pointer to the appropriate g-vector + ! gptmd - dimension of gptm + ! basm - radial mixed basis functions (mt + inter) + ! nbasm - number of mixed basis function + ! nobd - dimension of occupied bands + ! nbands - number of bands + ! nsst - size of indx + ! indx - pointer to bands + ! invsat - number of inversion-symmetric atom + ! invsatnr - number of inversion-symmetric atom + ! cprod - scalar product of mixed basis and wavefunction product basis + ! wl_iks - + ! n_q - + ! Return: + ! Change of the Coulomb matrix + FUNCTION dynamic_hse_adjustment( & + rmsh, rmt, dx, jri, jmtd, bk, ikpt, nkptf, bmat, vol, & + ntype, neq, natd, taual, lcutm, maxlcutm, nindxm, maxindxm, & + gptm, ngptm, pgptm, gptmd, basm, nbasm, & + nobd, nbands, nsst, ibando, psize, indx, invsat, invsatnr, irank, & + cprod_r, cprod_c, l_real, wl_iks, n_q) + + USE m_trafo, ONLY: symmetrize + USE m_olap, ONLY: olap_pw, olap_pwp + USE m_wrapper, ONLY: diagonalize, dotprod, matvec, packmat, inverse + + IMPLICIT NONE + + ! scalar input + INTEGER, INTENT(IN) :: natd, ntype, maxlcutm + INTEGER, INTENT(IN) :: jmtd, ikpt, nkptf + INTEGER, INTENT(IN) :: maxindxm + INTEGER, INTENT(IN) :: gptmd, irank + INTEGER, INTENT(IN) :: nbasm, nobd, nbands, ibando, psize + INTEGER, INTENT(IN) :: n_q + REAL, INTENT(IN) :: vol + + ! array input + INTEGER, INTENT(IN) :: lcutm(ntype) + INTEGER, INTENT(IN) :: nindxm(0:maxlcutm, ntype), neq(ntype) + INTEGER, INTENT(IN) :: jri(ntype) + INTEGER, INTENT(IN) :: gptm(3, gptmd) + INTEGER, INTENT(IN) :: ngptm + INTEGER, INTENT(IN) :: pgptm(ngptm) + INTEGER, INTENT(IN) :: nsst(nbands), indx(nbands, nbands) + INTEGER, INTENT(IN) :: invsat(natd), invsatnr(natd) + REAL, INTENT(IN) :: bk(3) + REAL, INTENT(IN) :: rmsh(jmtd, ntype), rmt(ntype), dx(ntype) + REAL, INTENT(IN) :: basm(jmtd, maxindxm, 0:maxlcutm, ntype) + REAL, INTENT(IN) :: bmat(3, 3) + REAL, INTENT(IN) :: taual(3, natd) + REAL, INTENT(IN) :: wl_iks(nobd) + REAL, INTENT(IN) :: cprod_r(nbasm, psize, nbands) + COMPLEX, INTENT(IN) :: cprod_c(nbasm, psize, nbands) + LOGICAL, INTENT(IN) :: l_real + + ! return type definition + COMPLEX :: dynamic_hse_adjustment(nbands, nbands) + + ! private scalars + INTEGER :: noGpts, nbasp + INTEGER :: itype, ieq, il, im, iindxm, ibasp + INTEGER :: igpt, iobd, iobd0, isst, iband1, iband2 + COMPLEX :: cdum, gPtsSum + + ! private arrays + INTEGER, ALLOCATABLE :: ptrType(:), ptrEq(:), ptrL(:), ptrM(:), ptrN(:) ! pointer to reference muffintin-array + REAL :: potential(maxNoGPts) ! Fourier transformed potential + COMPLEX :: muffintin(maxNoGPts, maxindxm, & ! muffin-tin overlap integral + (maxlcutm + 1)**2, ntype, MAXVAL(neq)) + COMPLEX :: interstitial(maxNoGPts, gptmd) ! interstistial overlap intergral #ifdef CPP_INVERSION - REAL :: fourier_trafo(nbasm-ngptm,maxNoGPts) ! Fourier trafo of all mixed basis functions + REAL :: fourier_trafo(nbasm - ngptm, maxNoGPts) ! Fourier trafo of all mixed basis functions #else - COMPLEX :: fourier_trafo(nbasm-ngptm,maxNoGPts) ! Fourier trafo of all mixed basis functions + COMPLEX :: fourier_trafo(nbasm - ngptm, maxNoGPts) ! Fourier trafo of all mixed basis functions #endif - REAL :: cprod_fourier_trafo_r(maxNoGpts,psize,nbands) ! Product of cprod and Fourier trafo - COMPLEX :: cprod_fourier_trafo_c(maxNoGpts,psize,nbands) ! Product of cprod and Fourier trafo - - ! Initialisation - dynamic_hse_adjustment = 0.0 - potential = 0.0 - fourier_trafo = 0.0 - cprod_fourier_trafo_r = 0.0 - cprod_fourier_trafo_c = 0.0 - noGPts = MIN(ngptm,maxNoGPts) - nbasp = nbasm - ngptm - - ! - ! Calculate the fourier transform of the mixed basis once - ! If it was already calculated load the old results - ! - CALL calculate_fourier_transform_once( & - rmsh,rmt,dx,jri,jmtd,bk,ikpt,nkptf, & - bmat,vol,ntype,neq,natd,taual,lcutm,maxlcutm, & - nindxm,maxindxm,gptm,ngptm,pgptm,gptmd, & - nbasp,basm,noGPts,invsat,invsatnr,irank, & - potential,fourier_trafo) - - ! Calculate the Fourier transform of the 'normal' basis - ! by summing over the mixed basis - DO igpt = 1,noGPts - DO iobd0 = 1,psize!ibando,min(ibando+psize,nobd) - iobd = iobd0 + ibando - 1 - IF( iobd .GT. nobd ) CYCLE - DO iband1 = 1,nbands - if (l_real) THEN - cprod_fourier_trafo_r(igpt,iobd0,iband1) = & - ! muffin tin contribution - dotprod( fourier_trafo(:nbasp,igpt), cprod_r(:nbasp,iobd0,iband1) ) & - ! interstitial contribution (interstitial is kronecker_G,G') - + cprod_r(nbasp+igpt,iobd0,iband1) - else - cprod_fourier_trafo_c(igpt,iobd0,iband1) = & - ! muffin tin contribution - dotprod( cprod_c(:nbasp,iobd0,iband1), fourier_trafo(:nbasp,igpt) ) & - ! interstitial contribution (interstitial is kronecker_G,G') - + CONJG( cprod_c(nbasp+igpt,iobd0,iband1) ) - endif - END DO + REAL :: cprod_fourier_trafo_r(maxNoGpts, psize, nbands) ! Product of cprod and Fourier trafo + COMPLEX :: cprod_fourier_trafo_c(maxNoGpts, psize, nbands) ! Product of cprod and Fourier trafo + + ! Initialisation + dynamic_hse_adjustment = 0.0 + potential = 0.0 + fourier_trafo = 0.0 + cprod_fourier_trafo_r = 0.0 + cprod_fourier_trafo_c = 0.0 + noGPts = MIN(ngptm, maxNoGPts) + nbasp = nbasm - ngptm + + ! + ! Calculate the fourier transform of the mixed basis once + ! If it was already calculated load the old results + ! + CALL calculate_fourier_transform_once( & + rmsh, rmt, dx, jri, jmtd, bk, ikpt, nkptf, & + bmat, vol, ntype, neq, natd, taual, lcutm, maxlcutm, & + nindxm, maxindxm, gptm, ngptm, pgptm, gptmd, & + nbasp, basm, noGPts, invsat, invsatnr, irank, & + potential, fourier_trafo) + + ! Calculate the Fourier transform of the 'normal' basis + ! by summing over the mixed basis + DO igpt = 1, noGPts + DO iobd0 = 1, psize!ibando,min(ibando+psize,nobd) + iobd = iobd0 + ibando - 1 + IF (iobd > nobd) CYCLE + DO iband1 = 1, nbands + if (l_real) THEN + cprod_fourier_trafo_r(igpt, iobd0, iband1) = & + ! muffin tin contribution + dotprod(fourier_trafo(:nbasp, igpt), cprod_r(:nbasp, iobd0, iband1)) & + ! interstitial contribution (interstitial is kronecker_G,G') + + cprod_r(nbasp + igpt, iobd0, iband1) + else + cprod_fourier_trafo_c(igpt, iobd0, iband1) = & + ! muffin tin contribution + dotprod(cprod_c(:nbasp, iobd0, iband1), fourier_trafo(:nbasp, igpt)) & + ! interstitial contribution (interstitial is kronecker_G,G') + + CONJG(cprod_c(nbasp + igpt, iobd0, iband1)) + endif + END DO + END DO END DO - END DO - - ! Summation over all G-vectors - DO iband1 = 1,nbands - DO iobd0 = 1,psize!ibando,min(ibando+psize,nobd) - iobd = iobd0 + ibando - 1 - IF( iobd .GT. nobd ) CYCLE - ! prefactor for all elements - cdum = wl_iks(iobd) / n_q - DO isst = 1,nsst(iband1) - iband2 = indx(isst,iband1) - ! do summation over G-vectors - if (l_real) THEN - gPtsSum = cdum * gPtsSummation(noGPts,& - cprod_fourier_trafo_r(:,iobd0,iband1),& - potential,cprod_fourier_trafo_r(:,iobd0,iband2) ) - ELSE - gPtsSum = cdum * gPtsSummation(noGPts,& - conjg(cprod_fourier_trafo_c(:,iobd0,iband1)),& - potential,cprod_fourier_trafo_c(:,iobd0,iband2) ) - endif - dynamic_hse_adjustment(iband2,iband1) = & - dynamic_hse_adjustment(iband2,iband1) - gPtsSum - END DO + + ! Summation over all G-vectors + DO iband1 = 1, nbands + DO iobd0 = 1, psize!ibando,min(ibando+psize,nobd) + iobd = iobd0 + ibando - 1 + IF (iobd > nobd) CYCLE + ! prefactor for all elements + cdum = wl_iks(iobd)/n_q + DO isst = 1, nsst(iband1) + iband2 = indx(isst, iband1) + ! do summation over G-vectors + if (l_real) THEN + gPtsSum = cdum*gPtsSummation(noGPts, & + cprod_fourier_trafo_r(:, iobd0, iband1), & + potential, cprod_fourier_trafo_r(:, iobd0, iband2)) + ELSE + gPtsSum = cdum*gPtsSummation(noGPts, & + conjg(cprod_fourier_trafo_c(:, iobd0, iband1)), & + potential, cprod_fourier_trafo_c(:, iobd0, iband2)) + endif + dynamic_hse_adjustment(iband2, iband1) = & + dynamic_hse_adjustment(iband2, iband1) - gPtsSum + END DO + END DO END DO - END DO - - END FUNCTION dynamic_hse_adjustment - - ! Helper function needed to use forall statements instead of do loop's - ! calls the harmonicsr subroutine from 'util.F' - PURE FUNCTION calcYlm(rvec,ll) - USE m_util, ONLY : harmonicsr - IMPLICIT NONE - REAL, INTENT(IN) :: rvec(3) - INTEGER, INTENT(IN) :: ll - COMPLEX :: calcYlm( (ll+1)**2 ) - CALL harmonicsr(calcYlm, rvec, ll) - END FUNCTION calcYlm - - ! Helper function needed to use forall statements instead of do loop's - ! calls the sphbessel subroutine from 'util.F' - PURE FUNCTION calcSphBes(x,l) - USE m_util, ONLY : sphbessel - IMPLICIT NONE - REAL, INTENT(IN) :: x - INTEGER, INTENT(IN) :: l - REAL :: calcSphBes(0:l) - CALL sphbessel(calcSphBes,x,l) - END FUNCTION calcSphBes - - ! Dot_product definition for two arrays (3d x 1d) with common size of first dimension - PURE FUNCTION my_dot_product3x1(first,second) - IMPLICIT NONE - INTEGER, INTENT(IN) :: first(:,:,:) - REAL, INTENT(IN) :: second( SIZE(first,1) ) - REAL :: my_dot_product3x1( SIZE(first,2), SIZE(first,3) ) - INTEGER :: ci, cj - - FORALL ( ci=1:SIZE(first,2), cj=1:SIZE(first,3) ) - my_dot_product3x1(ci,cj) = DOT_PRODUCT(first(:,ci,cj), second) - END FORALL - END FUNCTION my_dot_product3x1 - - ! Dot_product definition for two arrays (4d x 1d) with common size of first dimension - PURE FUNCTION my_dot_product4x1(first,second) - IMPLICIT NONE - INTEGER, INTENT(IN) :: first(:,:,:,:) - REAL, INTENT(IN) :: second( SIZE(first,1) ) - REAL :: my_dot_product4x1( SIZE(first,2), SIZE(first,3), SIZE(first,4) ) - INTEGER :: ci, cj, ck - - FORALL ( ci=1:SIZE(first,2), cj=1:SIZE(first,3), ck=1:SIZE(first,4) ) - my_dot_product4x1(ci,cj,ck) = DOT_PRODUCT(first(:,ci,cj,ck), second) - END FORALL - END FUNCTION my_dot_product4x1 - - ! Dot_product definition for two arrays (3d x 3d) with common size of all dimensions, - ! The scalar product is evaluated over the last index - PURE FUNCTION my_dot_product3x3(first, second) - IMPLICIT NONE - COMPLEX, INTENT(IN) :: first(:,:,:) - REAL, INTENT(IN) :: second( SIZE(first,1), SIZE(first,2), SIZE(first,3) ) - COMPLEX :: my_dot_product3x3( SIZE(first,1), SIZE(first,2) ) - INTEGER :: ci, cj - - FORALL ( ci=1:SIZE(first,1), cj=1:SIZE(first,2) ) - my_dot_product3x3(ci,cj) = DOT_PRODUCT( first(ci,cj,:), second(ci,cj,:) ) - END FORALL - END FUNCTION my_dot_product3x3 - - ! Dot_product definition for two arrays (4d x 4d) with common size of all dimensions, - ! The scalar product is evaluated over the last index - PURE FUNCTION my_dot_product4x4(first, second) - IMPLICIT NONE - COMPLEX, INTENT(IN) :: first(:,:,:,:) - REAL, INTENT(IN) :: second( SIZE(first,1), SIZE(first,2), SIZE(first,3), SIZE(first,4) ) - COMPLEX :: my_dot_product4x4( SIZE(first,1), SIZE(first,2), SIZE(first,3) ) - INTEGER :: ci, cj, ck - - FORALL ( ci=1:SIZE(first,1), cj=1:SIZE(first,2), ck=1:SIZE(first,3) ) - my_dot_product4x4(ci,cj,ck) = DOT_PRODUCT( first(ci,cj,ck,:), second(ci,cj,ck,:) ) - END FORALL - END FUNCTION my_dot_product4x4 - - ! Sum over last index of 4d array - PURE FUNCTION my_sum3d(array) - IMPLICIT NONE - COMPLEX, INTENT(IN) :: array(:,:,:) - COMPLEX :: my_sum3d( SIZE(array,1), SIZE(array,2) ) - INTEGER :: ci, cj - - FORALL ( ci=1:SIZE(array,1), cj=1:SIZE(array,2) ) - my_sum3d(ci,cj) = SUM( array(ci,cj,:) ) - END FORALL - END FUNCTION my_sum3d - - ! Sum over last index of 4d array - PURE FUNCTION my_sum4d(array) - IMPLICIT NONE - COMPLEX, INTENT(IN) :: array(:,:,:,:) - COMPLEX :: my_sum4d( SIZE(array,1), SIZE(array,2), SIZE(array,3) ) - INTEGER :: ci, cj, ck - - FORALL ( ci=1:SIZE(array,1), cj=1:SIZE(array,2), ck=1:SIZE(array,3) ) - my_sum4d(ci,cj,ck) = SUM( array(ci,cj,ck,:) ) - END FORALL - END FUNCTION my_sum4d - - ! Sum product of three vectors - COMPLEX PURE FUNCTION crc_gPtsSummation(noGpts, vec1, vec2, vec3) - IMPLICIT NONE - INTEGER, INTENT(IN) :: noGPts - COMPLEX, INTENT(IN) :: vec1(noGPts) - REAL, INTENT(IN) :: vec2(noGPts) - COMPLEX, INTENT(IN) :: vec3(noGPts) - COMPLEX :: temp(noGPts) - temp = vec1 * vec3 - crc_gPtsSummation = DOT_PRODUCT(temp,vec2) - END FUNCTION crc_gPtsSummation - REAL PURE FUNCTION rrr_gPtsSummation(noGpts, vec1, vec2, vec3) - IMPLICIT NONE - INTEGER, INTENT(IN) :: noGPts - REAL, INTENT(IN) :: vec1(noGPts) - REAL, INTENT(IN) :: vec2(noGPts) - REAL, INTENT(IN) :: vec3(noGPts) - REAL :: temp(noGPts) - temp = vec1 * vec3 - rrr_gPtsSummation = DOT_PRODUCT(temp,vec2) - END FUNCTION rrr_gPtsSummation - - ! Include the core valence exchange for the HSE functional - ! The HSE potential is the Coulomb one attenuated with the complementary - ! error function which can be expanded in Legendre polynomials (r' > r) - ! - ! ----- l+2n - ! erfc( w |r - r'| ) \ r / \ - ! ------------------ = ) d (w r') --------- P ( cos(r,r') ) - ! | r - r' | / ln l+2n+1 l \ / - ! ----- r' - ! l,n - ! - ! Then an analytical integration of the angular part of the exchange - ! potential is possible and only the radial part remains - ! - ! R r R - ! / ----- / d (w r) / / d (w r') \ - ! 4 Pi | \ | ln | l+2n+2 l+2n | ln | - ! ------- | dr ) | --------- | dr' f(r') r' + r | dr' f(r') ----------- | - ! 2 l + 1 | / | l+2n+1 | | l+2n-1 | - ! / ----- \ r / / r' / - ! 0 n 0 r - ! - ! The function f is a product of core and valence function - ! (note: in the code f is defined with an additional 1/r factor) - ! - SUBROUTINE exchange_vccvHSE(nk,bkpt,nkptd,nkpt,nkpti,ntype,neq,natd, & - lmax,lmaxd,nindx,maxindx,lmaxc,nindxc, & - maxindxc,core1,core2,lcutm,maxlmindx, & - bas1,bas2,jmtd,rmsh,dx,jri,jspd,jsp, & - maxfac,fac,sfac,nv,neigd,nbasfcn,nbands, & - gridf,nsymop,nsest,indx_sest,irank, & - a_ex,nobd,w_iks, & - mat_ex,te_hfex_core) - - USE m_constants - USE m_util - USE m_wrapper - - IMPLICIT NONE + + END FUNCTION dynamic_hse_adjustment + + ! Helper function needed to use forall statements instead of do loop's + ! calls the harmonicsr subroutine from 'util.F' + PURE FUNCTION calcYlm(rvec, ll) + USE m_util, ONLY: harmonicsr + IMPLICIT NONE + REAL, INTENT(IN) :: rvec(3) + INTEGER, INTENT(IN) :: ll + COMPLEX :: calcYlm((ll + 1)**2) + CALL harmonicsr(calcYlm, rvec, ll) + END FUNCTION calcYlm + + ! Helper function needed to use forall statements instead of do loop's + ! calls the sphbessel subroutine from 'util.F' + PURE FUNCTION calcSphBes(x, l) + USE m_util, ONLY: sphbessel + IMPLICIT NONE + REAL, INTENT(IN) :: x + INTEGER, INTENT(IN) :: l + REAL :: calcSphBes(0:l) + CALL sphbessel(calcSphBes, x, l) + END FUNCTION calcSphBes + + ! Dot_product definition for two arrays (3d x 1d) with common size of first dimension + PURE FUNCTION my_dot_product3x1(first, second) + IMPLICIT NONE + INTEGER, INTENT(IN) :: first(:, :, :) + REAL, INTENT(IN) :: second(SIZE(first, 1)) + REAL :: my_dot_product3x1(SIZE(first, 2), SIZE(first, 3)) + INTEGER :: ci, cj + + FORALL (ci=1:SIZE(first, 2), cj=1:SIZE(first, 3)) + my_dot_product3x1(ci, cj) = DOT_PRODUCT(first(:, ci, cj), second) + END FORALL + END FUNCTION my_dot_product3x1 + + ! Dot_product definition for two arrays (4d x 1d) with common size of first dimension + PURE FUNCTION my_dot_product4x1(first, second) + IMPLICIT NONE + INTEGER, INTENT(IN) :: first(:, :, :, :) + REAL, INTENT(IN) :: second(SIZE(first, 1)) + REAL :: my_dot_product4x1(SIZE(first, 2), SIZE(first, 3), SIZE(first, 4)) + INTEGER :: ci, cj, ck + + FORALL (ci=1:SIZE(first, 2), cj=1:SIZE(first, 3), ck=1:SIZE(first, 4)) + my_dot_product4x1(ci, cj, ck) = DOT_PRODUCT(first(:, ci, cj, ck), second) + END FORALL + END FUNCTION my_dot_product4x1 + + ! Dot_product definition for two arrays (3d x 3d) with common size of all dimensions, + ! The scalar product is evaluated over the last index + PURE FUNCTION my_dot_product3x3(first, second) + IMPLICIT NONE + COMPLEX, INTENT(IN) :: first(:, :, :) + REAL, INTENT(IN) :: second(SIZE(first, 1), SIZE(first, 2), SIZE(first, 3)) + COMPLEX :: my_dot_product3x3(SIZE(first, 1), SIZE(first, 2)) + INTEGER :: ci, cj + + FORALL (ci=1:SIZE(first, 1), cj=1:SIZE(first, 2)) + my_dot_product3x3(ci, cj) = DOT_PRODUCT(first(ci, cj, :), second(ci, cj, :)) + END FORALL + END FUNCTION my_dot_product3x3 + + ! Dot_product definition for two arrays (4d x 4d) with common size of all dimensions, + ! The scalar product is evaluated over the last index + PURE FUNCTION my_dot_product4x4(first, second) + IMPLICIT NONE + COMPLEX, INTENT(IN) :: first(:, :, :, :) + REAL, INTENT(IN) :: second(SIZE(first, 1), SIZE(first, 2), SIZE(first, 3), SIZE(first, 4)) + COMPLEX :: my_dot_product4x4(SIZE(first, 1), SIZE(first, 2), SIZE(first, 3)) + INTEGER :: ci, cj, ck + + FORALL (ci=1:SIZE(first, 1), cj=1:SIZE(first, 2), ck=1:SIZE(first, 3)) + my_dot_product4x4(ci, cj, ck) = DOT_PRODUCT(first(ci, cj, ck, :), second(ci, cj, ck, :)) + END FORALL + END FUNCTION my_dot_product4x4 + + ! Sum over last index of 4d array + PURE FUNCTION my_sum3d(array) + IMPLICIT NONE + COMPLEX, INTENT(IN) :: array(:, :, :) + COMPLEX :: my_sum3d(SIZE(array, 1), SIZE(array, 2)) + INTEGER :: ci, cj + + FORALL (ci=1:SIZE(array, 1), cj=1:SIZE(array, 2)) + my_sum3d(ci, cj) = SUM(array(ci, cj, :)) + END FORALL + END FUNCTION my_sum3d + + ! Sum over last index of 4d array + PURE FUNCTION my_sum4d(array) + IMPLICIT NONE + COMPLEX, INTENT(IN) :: array(:, :, :, :) + COMPLEX :: my_sum4d(SIZE(array, 1), SIZE(array, 2), SIZE(array, 3)) + INTEGER :: ci, cj, ck + + FORALL (ci=1:SIZE(array, 1), cj=1:SIZE(array, 2), ck=1:SIZE(array, 3)) + my_sum4d(ci, cj, ck) = SUM(array(ci, cj, ck, :)) + END FORALL + END FUNCTION my_sum4d + + ! Sum product of three vectors + COMPLEX PURE FUNCTION crc_gPtsSummation(noGpts, vec1, vec2, vec3) + IMPLICIT NONE + INTEGER, INTENT(IN) :: noGPts + COMPLEX, INTENT(IN) :: vec1(noGPts) + REAL, INTENT(IN) :: vec2(noGPts) + COMPLEX, INTENT(IN) :: vec3(noGPts) + COMPLEX :: temp(noGPts) + temp = vec1*vec3 + crc_gPtsSummation = DOT_PRODUCT(temp, vec2) + END FUNCTION crc_gPtsSummation + REAL PURE FUNCTION rrr_gPtsSummation(noGpts, vec1, vec2, vec3) + IMPLICIT NONE + INTEGER, INTENT(IN) :: noGPts + REAL, INTENT(IN) :: vec1(noGPts) + REAL, INTENT(IN) :: vec2(noGPts) + REAL, INTENT(IN) :: vec3(noGPts) + REAL :: temp(noGPts) + temp = vec1*vec3 + rrr_gPtsSummation = DOT_PRODUCT(temp, vec2) + END FUNCTION rrr_gPtsSummation + + ! Include the core valence exchange for the HSE functional + ! The HSE potential is the Coulomb one attenuated with the complementary + ! error function which can be expanded in Legendre polynomials (r' > r) + ! + ! ----- l+2n + ! erfc( w |r - r'| ) \ r / \ + ! ------------------ = ) d (w r') --------- P ( cos(r,r') ) + ! | r - r' | / ln l+2n+1 l \ / + ! ----- r' + ! l,n + ! + ! Then an analytical integration of the angular part of the exchange + ! potential is possible and only the radial part remains + ! + ! R r R + ! / ----- / d (w r) / / d (w r') \ + ! 4 Pi | \ | ln | l+2n+2 l+2n | ln | + ! ------- | dr ) | --------- | dr' f(r') r' + r | dr' f(r') ----------- | + ! 2 l + 1 | / | l+2n+1 | | l+2n-1 | + ! / ----- \ r / / r' / + ! 0 n 0 r + ! + ! The function f is a product of core and valence function + ! (note: in the code f is defined with an additional 1/r factor) + ! + SUBROUTINE exchange_vccvHSE(nk, bkpt, nkptd, nkpt, nkpti, ntype, neq, natd, & + lmax, lmaxd, nindx, maxindx, lmaxc, nindxc, & + maxindxc, core1, core2, lcutm, maxlmindx, & + bas1, bas2, jmtd, rmsh, dx, jri, jspd, jsp, & + maxfac, fac, sfac, nv, neigd, nbasfcn, nbands, & + gridf, nsymop, nsest, indx_sest, irank, & + a_ex, nobd, w_iks, & + mat_ex, te_hfex_core) + + USE m_constants + USE m_util + USE m_wrapper + + IMPLICIT NONE ! -scalars - - INTEGER,INTENT(IN) :: ntype,jmtd,lmaxd,jspd,jsp,neigd - INTEGER,INTENT(IN) :: maxfac,nbands,maxlmindx,natd,& - maxindxc,nk,maxindx,nbasfcn - INTEGER,INTENT(IN) :: nkptd,nkpt,nkpti,irank - INTEGER,INTENT(IN) :: nsymop - REAL, INTENT(IN) :: a_ex - REAL, INTENT(INOUT) :: te_hfex_core - + INTEGER, INTENT(IN) :: ntype, jmtd, lmaxd, jspd, jsp, neigd + INTEGER, INTENT(IN) :: maxfac, nbands, maxlmindx, natd, & + maxindxc, nk, maxindx, nbasfcn + INTEGER, INTENT(IN) :: nkptd, nkpt, nkpti, irank + INTEGER, INTENT(IN) :: nsymop + REAL, INTENT(IN) :: a_ex + REAL, INTENT(INOUT) :: te_hfex_core + ! - arrays - - INTEGER,INTENT(IN) :: neq(ntype),lcutm(ntype),lmax(ntype),& - lmaxc(ntype),jri(ntype),nv(jspd),& - nindxc(0:MAXVAL(lmaxc),ntype),& - nindx(0:lmaxd,ntype) - INTEGER,INTENT(IN) :: nsest(nbands),indx_sest(nbands,nbands) - INTEGER,INTENT(IN) :: nobd(nkpt) - REAL,INTENT(IN) :: rmsh(jmtd,ntype),dx(ntype) - REAL,INTENT(IN) :: bas1(jmtd,maxindx,0:lmaxd,ntype),& - bas2(jmtd,maxindx,0:lmaxd,ntype) - REAL,INTENT(IN) :: core1(jmtd,maxindxc,0:MAXVAL(lmaxc),ntype),& - core2(jmtd,maxindxc,0:MAXVAL(lmaxc),ntype) - REAL,INTENT(IN) :: fac( 0:maxfac),sfac( 0:maxfac) - REAL,INTENT(IN) :: bkpt(3) - REAL,INTENT(IN) :: gridf(jmtd,ntype) - REAL,INTENT(IN) :: w_iks(neigd,nkptd,jspd) + INTEGER, INTENT(IN) :: neq(ntype), lcutm(ntype), lmax(ntype), & + lmaxc(ntype), jri(ntype), nv(jspd), & + nindxc(0:MAXVAL(lmaxc), ntype), & + nindx(0:lmaxd, ntype) + INTEGER, INTENT(IN) :: nsest(nbands), indx_sest(nbands, nbands) + INTEGER, INTENT(IN) :: nobd(nkpt) + REAL, INTENT(IN) :: rmsh(jmtd, ntype), dx(ntype) + REAL, INTENT(IN) :: bas1(jmtd, maxindx, 0:lmaxd, ntype), & + bas2(jmtd, maxindx, 0:lmaxd, ntype) + REAL, INTENT(IN) :: core1(jmtd, maxindxc, 0:MAXVAL(lmaxc), ntype), & + core2(jmtd, maxindxc, 0:MAXVAL(lmaxc), ntype) + REAL, INTENT(IN) :: fac(0:maxfac), sfac(0:maxfac) + REAL, INTENT(IN) :: bkpt(3) + REAL, INTENT(IN) :: gridf(jmtd, ntype) + REAL, INTENT(IN) :: w_iks(neigd, nkptd, jspd) #ifdef CPP_INVERSION - REAL ,INTENT(INOUT) :: mat_ex(nbasfcn*(nbasfcn+1)/2) + REAL, INTENT(INOUT) :: mat_ex(nbasfcn*(nbasfcn + 1)/2) #else - COMPLEX ,INTENT(INOUT) :: mat_ex(nbasfcn*(nbasfcn+1)/2) + COMPLEX, INTENT(INOUT) :: mat_ex(nbasfcn*(nbasfcn + 1)/2) #endif - INTEGER, PARAMETER :: ncut = 5 ! cut-off value of n-summation - INTEGER :: cn ! counter for n-summation - REAL :: d_ln(jmtd,0:lmaxd,0:ncut) ! expansion coefficients of erfc(wr)/r - ! in Legendre polynomials - + INTEGER, PARAMETER :: ncut = 5 ! cut-off value of n-summation + INTEGER :: cn ! counter for n-summation + REAL :: d_ln(jmtd, 0:lmaxd, 0:ncut) ! expansion coefficients of erfc(wr)/r + ! in Legendre polynomials -! - local scalars - - INTEGER :: iatom,ieq,itype,ic,l,l1,l2,& - ll,lm,m,m1,m2,p1,p2,n,n1,n2,nn2,i,j - INTEGER :: iband1,iband2,ndb1,ndb2,ic1,ic2 - INTEGER :: irecl_cmt +! - local scalars - + INTEGER :: iatom, ieq, itype, ic, l, l1, l2, & + ll, lm, m, m1, m2, p1, p2, n, n1, n2, nn2, i, j + INTEGER :: iband1, iband2, ndb1, ndb2, ic1, ic2 + INTEGER :: irecl_cmt - REAL :: rdum - REAL :: sum_offdia + REAL :: rdum + REAL :: sum_offdia - COMPLEX :: cdum + COMPLEX :: cdum ! - local arrays - - INTEGER,ALLOCATABLE :: larr(:),larr2(:) - INTEGER,ALLOCATABLE :: parr(:),parr2(:) + INTEGER, ALLOCATABLE :: larr(:), larr2(:) + INTEGER, ALLOCATABLE :: parr(:), parr2(:) - REAL :: sum_primf(jmtd), integrand(jmtd) - REAL :: primf1(jmtd),primf2(jmtd) - REAL,ALLOCATABLE :: fprod(:,:),fprod2(:,:) - REAL,ALLOCATABLE :: integral(:,:) + REAL :: sum_primf(jmtd), integrand(jmtd) + REAL :: primf1(jmtd), primf2(jmtd) + REAL, ALLOCATABLE :: fprod(:, :), fprod2(:, :) + REAL, ALLOCATABLE :: integral(:, :) - COMPLEX :: cmt(neigd,maxlmindx,natd) - COMPLEX :: exchange(nbands,nbands) - COMPLEX,ALLOCATABLE :: carr(:,:),carr2(:,:),carr3(:,:) + COMPLEX :: cmt(neigd, maxlmindx, natd) + COMPLEX :: exchange(nbands, nbands) + COMPLEX, ALLOCATABLE :: carr(:, :), carr2(:, :), carr3(:, :) - LOGICAL :: ldum(nbands,nbands) + LOGICAL :: ldum(nbands, nbands) - - ! check if a_ex is consistent + ! check if a_ex is consistent ! IF ( a_ex /= aMix_HSE ) STOP 'hsefunctional: inconsistent mixing!' - ! read in mt wavefunction coefficients from file cmt - irecl_cmt = neigd*maxlmindx*natd*16 - OPEN(unit=777,file='cmt',form='unformatted',access='direct',recl=irecl_cmt) - READ(777,rec=nk) cmt(:,:,:) - CLOSE(777) - - ALLOCATE ( fprod(jmtd,5),larr(5),parr(5) ) - - exchange = 0 - iatom = 0 - rdum = 0 - DO itype = 1,ntype - ! Calculate the expansion coefficients of the potential in Legendre polynomials - d_ln(:,:lcutm(itype),:) = calculate_coefficients(rmsh(:,itype),lcutm(itype),ncut,fac) - DO ieq = 1,neq(itype) - iatom = iatom + 1 - DO l1 = 0,lmaxc(itype) - DO p1 = 1,nindxc(l1,itype) - - DO l = 0,lcutm(itype) - - ! Define core-valence product functions - - n = 0 - DO l2 = 0,lmax(itype) - IF(l.LT.ABS(l1-l2).OR.l.GT.l1+l2) CYCLE - - DO p2 = 1,nindx(l2,itype) - n = n + 1 - m = SIZE(fprod,2) - IF(n.GT.m) THEN - ALLOCATE ( fprod2(jmtd,m),larr2(m),parr2(m) ) - fprod2 = fprod ; larr2 = larr ; parr2 = parr - DEALLOCATE ( fprod,larr,parr ) - ALLOCATE ( fprod(jmtd,m+5),larr(m+5),parr(m+5) ) - fprod(:,:m) = fprod2 - larr(:m) = larr2 - parr(:m) = parr2 - DEALLOCATE ( fprod2,larr2,parr2 ) - END IF - fprod(:,n) = ( core1(:,p1,l1,itype)& - *bas1 (:,p2,l2,itype)& - +core2(:,p1,l1,itype)& - *bas2 (:,p2,l2,itype) )/ rmsh(:,itype) - larr(n) = l2 - parr(n) = p2 - END DO - END DO - - ! Evaluate radial integrals (special part of Coulomb matrix : contribution from single MT) - - ALLOCATE ( integral(n,n),carr(n,nbands),& - carr2(n,nv(jsp)),carr3(n,nv(jsp)) ) - - DO i = 1,n - ! Initialization of n Summation - sum_primf = 0.0 - ! Integration over r' - DO cn = 0,ncut ! Summation over Legendre polynomials - primf1 = 0.0 - primf2 = 0.0 - ! Calculate integral for 0 < r' < r - CALL primitivef(primf1,fprod(:,i)*rmsh(:,itype)**(l+2*cn+1),& - rmsh,dx,jri,jmtd, itype,ntype) - ! Calculate integral for r < r' < R - CALL primitivef(primf2,d_ln(:,l,cn)*fprod(:,i)/rmsh(:,itype)**(l+2*cn),& - rmsh,dx,jri,jmtd,-itype,ntype) ! -itype is to enforce inward integration - ! Multiplication with appropriate prefactors - primf1 = primf1 / rmsh(:,itype)**(l+2*cn) * d_ln(:,l,cn) - primf2 = primf2 * rmsh(:,itype)**(l+2*cn+1) - ! Summation over n - sum_primf = sum_primf + primf1 + primf2 - END DO - DO j = 1,n - ! Integration over r - integrand = fprod(:,j) * sum_primf - integral(i,j) = fpi_const/(2*l+1) * & - intgrf(integrand,jri,jmtd,rmsh,& - dx,ntype,itype,gridf) - END DO - - END DO - - ! Add everything up - - DO m1 = -l1,l1 - DO m = -l,l - m2 = m1 + m - - carr = 0 - ic = 0 - DO n1=1,nbands - - DO i = 1,n - ll = larr(i) - IF(ABS(m2).GT.ll) CYCLE - - lm = SUM((/ ((2*l2+1)*nindx(l2,itype),l2=0,ll-1) /)) & - + (m2+ll)*nindx(ll,itype) + parr(i) - - carr(i,n1) = cmt(n1,lm,iatom) & - * gaunt(l1,ll,l,m1,m2,m,maxfac,fac,sfac) - - END DO - DO n2=1,nsest(n1)!n1 - nn2 = indx_sest(n2,n1) - exchange(nn2,n1) = exchange(nn2,n1) & - + DOT_PRODUCT( carr(:,n1), MATMUL(integral,carr(:,nn2)) ) - END DO - END DO - END DO - END DO - - DEALLOCATE ( integral,carr,carr2,carr3 ) - - END DO - END DO - END DO - END DO - END DO + ! read in mt wavefunction coefficients from file cmt + irecl_cmt = neigd*maxlmindx*natd*16 + OPEN (unit=777, file='cmt', form='unformatted', access='direct', recl=irecl_cmt) + READ (777, rec=nk) cmt(:, :, :) + CLOSE (777) + + ALLOCATE (fprod(jmtd, 5), larr(5), parr(5)) + + exchange = 0 + iatom = 0 + rdum = 0 + DO itype = 1, ntype + ! Calculate the expansion coefficients of the potential in Legendre polynomials + d_ln(:, :lcutm(itype), :) = calculate_coefficients(rmsh(:, itype), lcutm(itype), ncut, fac) + DO ieq = 1, neq(itype) + iatom = iatom + 1 + DO l1 = 0, lmaxc(itype) + DO p1 = 1, nindxc(l1, itype) + + DO l = 0, lcutm(itype) + + ! Define core-valence product functions + + n = 0 + DO l2 = 0, lmax(itype) + IF (l < ABS(l1 - l2) .OR. l > l1 + l2) CYCLE + + DO p2 = 1, nindx(l2, itype) + n = n + 1 + m = SIZE(fprod, 2) + IF (n > m) THEN + ALLOCATE (fprod2(jmtd, m), larr2(m), parr2(m)) + fprod2 = fprod; larr2 = larr; parr2 = parr + DEALLOCATE (fprod, larr, parr) + ALLOCATE (fprod(jmtd, m + 5), larr(m + 5), parr(m + 5)) + fprod(:, :m) = fprod2 + larr(:m) = larr2 + parr(:m) = parr2 + DEALLOCATE (fprod2, larr2, parr2) + END IF + fprod(:, n) = (core1(:, p1, l1, itype) & + *bas1(:, p2, l2, itype) & + + core2(:, p1, l1, itype) & + *bas2(:, p2, l2, itype))/rmsh(:, itype) + larr(n) = l2 + parr(n) = p2 + END DO + END DO + + ! Evaluate radial integrals (special part of Coulomb matrix : contribution from single MT) + + ALLOCATE (integral(n, n), carr(n, nbands), & + carr2(n, nv(jsp)), carr3(n, nv(jsp))) + + DO i = 1, n + ! Initialization of n Summation + sum_primf = 0.0 + ! Integration over r' + DO cn = 0, ncut ! Summation over Legendre polynomials + primf1 = 0.0 + primf2 = 0.0 + ! Calculate integral for 0 < r' < r + CALL primitivef(primf1, fprod(:, i)*rmsh(:, itype)**(l + 2*cn + 1), & + rmsh, dx, jri, jmtd, itype, ntype) + ! Calculate integral for r < r' < R + CALL primitivef(primf2, d_ln(:, l, cn)*fprod(:, i)/rmsh(:, itype)**(l + 2*cn), & + rmsh, dx, jri, jmtd, -itype, ntype) ! -itype is to enforce inward integration + ! Multiplication with appropriate prefactors + primf1 = primf1/rmsh(:, itype)**(l + 2*cn)*d_ln(:, l, cn) + primf2 = primf2*rmsh(:, itype)**(l + 2*cn + 1) + ! Summation over n + sum_primf = sum_primf + primf1 + primf2 + END DO + DO j = 1, n + ! Integration over r + integrand = fprod(:, j)*sum_primf + integral(i, j) = fpi_const/(2*l + 1)* & + intgrf(integrand, jri, jmtd, rmsh, & + dx, ntype, itype, gridf) + END DO + + END DO + + ! Add everything up + + DO m1 = -l1, l1 + DO m = -l, l + m2 = m1 + m + + carr = 0 + ic = 0 + DO n1 = 1, nbands + + DO i = 1, n + ll = larr(i) + IF (ABS(m2) > ll) CYCLE + + lm = SUM((/((2*l2 + 1)*nindx(l2, itype), l2=0, ll - 1)/)) & + + (m2 + ll)*nindx(ll, itype) + parr(i) + + carr(i, n1) = cmt(n1, lm, iatom) & + *gaunt(l1, ll, l, m1, m2, m, maxfac, fac, sfac) + + END DO + DO n2 = 1, nsest(n1)!n1 + nn2 = indx_sest(n2, n1) + exchange(nn2, n1) = exchange(nn2, n1) & + + DOT_PRODUCT(carr(:, n1), MATMUL(integral, carr(:, nn2))) + END DO + END DO + END DO + END DO + + DEALLOCATE (integral, carr, carr2, carr3) + + END DO + END DO + END DO + END DO + END DO #ifdef CPP_INVERSION - IF( ANY(ABS(aimag(exchange)).GT.10.0**-10) ) THEN - IF ( irank == 0 ) WRITE(6,'(A)') 'exchangeCore: Warning! Unusually large imaginary component.' - WRITE(*,*) MAXVAL(ABS(aimag(exchange))) - STOP 'exchangeCore: Unusually large imaginary component.' - END IF + IF (ANY(ABS(aimag(exchange)) > 10.0**-10)) THEN + IF (irank == 0) WRITE (6, '(A)') 'exchangeCore: Warning! Unusually large imaginary component.' + WRITE (*, *) MAXVAL(ABS(aimag(exchange))) + STOP 'exchangeCore: Unusually large imaginary component.' + END IF #endif - DO n1=1,nobd(nk) - te_hfex_core = te_hfex_core - a_ex * w_iks(n1,nk,jsp)*exchange(n1,n1) - END DO - - ! add the core-valence contribution to the exchange matrix mat_ex - - ic = 0 - sum_offdia = 0 - DO n1=1,nbands - DO n2=1,n1 - ic = ic + 1 - mat_ex(ic) = mat_ex(ic) + CONJG(exchange(n2,n1))/nsymop - END DO - END DO - - - END SUBROUTINE exchange_vccvHSE - - ! Include the core core exchange for the HSE functional - ! The HSE potential is the Coulomb one attenuated with the complementary - ! error function which can be expanded in Legendre polynomials (r' > r) - ! - ! ----- l+2n - ! erfc( w |r - r'| ) \ r / \ - ! ------------------ = ) d (w r') --------- P ( cos(r,r') ) - ! | r - r' | / ln l+2n+1 l \ / - ! ----- r' - ! l,n - ! - ! Then an analytical integration of the angular part of the exchange - ! potential is possible and only the radial part remains - ! - ! R r R - ! / ----- / d (w r) / / d (w r') \ - ! 4 Pi | \ | ln | l+2n+2 l+2n | ln | - ! ------- | dr ) | --------- | dr' f(r') r' + r | dr' f(r') ----------- | - ! 2 l + 1 | / | l+2n+1 | | l+2n-1 | - ! / ----- \ r / / r' / - ! 0 n 0 r - ! - ! The function f is a product of core and valence function - ! (note: in the code f is defined with an additional 1/r factor) - ! - SUBROUTINE exchange_ccccHSE( & - ! Input - nk,nkpti,nw,nwd,ntype,neq,natd,lmaxcd,lmaxc, & - nindxc,maxindxc,ncst,ncstd,jmtd,jri, & - rmsh,dx,lmaxd,core1,core2,bkpt,gridf, & - invsat,invsatnr,wtkpt,maxfac,fac,a_ex,irank, & - ! Output - te_hfex) - - USE m_constants - USE m_util - USE m_wrapper - USE m_gaunt - USE m_trafo - - IMPLICIT NONE - - ! - scalars - - INTEGER,INTENT(IN) :: nk,nkpti,nw,nwd,ntype,natd,ncstd - INTEGER,INTENT(IN) :: lmaxcd,lmaxd,irank - INTEGER,INTENT(IN) :: jmtd,maxindxc,maxfac - - REAL ,INTENT(IN) :: a_ex - REAL ,INTENT(INOUT) :: te_hfex - - ! - arays - - INTEGER,INTENT(IN) :: neq(ntype),ncst(ntype),lmaxc(ntype) - INTEGER,INTENT(IN) :: nindxc(0:lmaxcd,ntype) - INTEGER,INTENT(IN) :: jri(ntype) - INTEGER,INTENT(IN) :: invsat(natd),invsatnr(natd) - - REAL ,INTENT(IN) :: rmsh(jmtd,ntype),dx(ntype) - REAL ,INTENT(IN) :: core1(jmtd,maxindxc,0:lmaxcd,ntype), & - core2(jmtd,maxindxc,0:lmaxcd,ntype) - REAL ,INTENT(IN) :: bkpt(3) - REAL ,INTENT(IN) :: gridf(jmtd,ntype) - REAL ,INTENT(IN) :: wtkpt(nkpti,nwd) - REAL ,INTENT(IN) :: fac( 0:maxfac ) - - ! - local scalars - - INTEGER :: itype,ieq,icst,icst1,icst2,iatom,iatom0 - INTEGER :: l1,l2,l,ll,llmax - INTEGER :: m1,m2,m,mm - INTEGER :: n1,n2,n - - REAL :: rdum,rdum1 - ! - local arrays - - INTEGER :: point(maxindxc,-lmaxcd:lmaxcd,0:lmaxcd,natd) - REAL :: rprod(jmtd),primf1(jmtd),primf2(jmtd),sum_primf(jmtd),integrand(jmtd) - COMPLEX :: exch(ncstd,ncstd) - - INTEGER, PARAMETER :: ncut = 5 ! cut-off value of n-summation - INTEGER :: cn ! counter for n-summation - REAL :: d_ln(jmtd,0:2*lmaxcd,0:ncut) ! expansion coefficients of erfc(wr)/r - ! in Legendre polynomials - CHARACTER*100 :: outtext + DO n1 = 1, nobd(nk) + te_hfex_core = te_hfex_core - a_ex*w_iks(n1, nk, jsp)*exchange(n1, n1) + END DO + + ! add the core-valence contribution to the exchange matrix mat_ex + + ic = 0 + sum_offdia = 0 + DO n1 = 1, nbands + DO n2 = 1, n1 + ic = ic + 1 + mat_ex(ic) = mat_ex(ic) + CONJG(exchange(n2, n1))/nsymop + END DO + END DO + + END SUBROUTINE exchange_vccvHSE + + ! Include the core core exchange for the HSE functional + ! The HSE potential is the Coulomb one attenuated with the complementary + ! error function which can be expanded in Legendre polynomials (r' > r) + ! + ! ----- l+2n + ! erfc( w |r - r'| ) \ r / \ + ! ------------------ = ) d (w r') --------- P ( cos(r,r') ) + ! | r - r' | / ln l+2n+1 l \ / + ! ----- r' + ! l,n + ! + ! Then an analytical integration of the angular part of the exchange + ! potential is possible and only the radial part remains + ! + ! R r R + ! / ----- / d (w r) / / d (w r') \ + ! 4 Pi | \ | ln | l+2n+2 l+2n | ln | + ! ------- | dr ) | --------- | dr' f(r') r' + r | dr' f(r') ----------- | + ! 2 l + 1 | / | l+2n+1 | | l+2n-1 | + ! / ----- \ r / / r' / + ! 0 n 0 r + ! + ! The function f is a product of core and valence function + ! (note: in the code f is defined with an additional 1/r factor) + ! + SUBROUTINE exchange_ccccHSE( & + ! Input + nk, nkpti, nw, nwd, ntype, neq, natd, lmaxcd, lmaxc, & + nindxc, maxindxc, ncst, ncstd, jmtd, jri, & + rmsh, dx, lmaxd, core1, core2, bkpt, gridf, & + invsat, invsatnr, wtkpt, maxfac, fac, a_ex, irank, & + ! Output + te_hfex) + + USE m_constants + USE m_util + USE m_wrapper + USE m_gaunt + USE m_trafo + + IMPLICIT NONE + + ! - scalars - + INTEGER, INTENT(IN) :: nk, nkpti, nw, nwd, ntype, natd, ncstd + INTEGER, INTENT(IN) :: lmaxcd, lmaxd, irank + INTEGER, INTENT(IN) :: jmtd, maxindxc, maxfac + + REAL, INTENT(IN) :: a_ex + REAL, INTENT(INOUT) :: te_hfex + + ! - arays - + INTEGER, INTENT(IN) :: neq(ntype), ncst(ntype), lmaxc(ntype) + INTEGER, INTENT(IN) :: nindxc(0:lmaxcd, ntype) + INTEGER, INTENT(IN) :: jri(ntype) + INTEGER, INTENT(IN) :: invsat(natd), invsatnr(natd) + + REAL, INTENT(IN) :: rmsh(jmtd, ntype), dx(ntype) + REAL, INTENT(IN) :: core1(jmtd, maxindxc, 0:lmaxcd, ntype), & + core2(jmtd, maxindxc, 0:lmaxcd, ntype) + REAL, INTENT(IN) :: bkpt(3) + REAL, INTENT(IN) :: gridf(jmtd, ntype) + REAL, INTENT(IN) :: wtkpt(nkpti, nwd) + REAL, INTENT(IN) :: fac(0:maxfac) + + ! - local scalars - + INTEGER :: itype, ieq, icst, icst1, icst2, iatom, iatom0 + INTEGER :: l1, l2, l, ll, llmax + INTEGER :: m1, m2, m, mm + INTEGER :: n1, n2, n + + REAL :: rdum, rdum1 + ! - local arrays - + INTEGER :: point(maxindxc, -lmaxcd:lmaxcd, 0:lmaxcd, natd) + REAL :: rprod(jmtd), primf1(jmtd), primf2(jmtd), sum_primf(jmtd), integrand(jmtd) + COMPLEX :: exch(ncstd, ncstd) + + INTEGER, PARAMETER :: ncut = 5 ! cut-off value of n-summation + INTEGER :: cn ! counter for n-summation + REAL :: d_ln(jmtd, 0:2*lmaxcd, 0:ncut) ! expansion coefficients of erfc(wr)/r + ! in Legendre polynomials + CHARACTER*100 :: outtext ! IF ( a_ex /= aMix_HSE ) STOP 'hsefunctional: mixing parameter inconsistent' @@ -2442,274 +2437,273 @@ CONTAINS ! CALL writeout(outtext,irank) ! END IF - ! set up point - icst = 0 - iatom= 0 - DO itype = 1,ntype - DO ieq = 1,neq(itype) - iatom = iatom + 1 - DO l = 0,lmaxc(itype) - DO m = -l,l - DO n = 1,nindxc(l,itype) - icst = icst + 1 - point(n,m,l,iatom) = icst - END DO - END DO + ! set up point + icst = 0 + iatom = 0 + DO itype = 1, ntype + DO ieq = 1, neq(itype) + iatom = iatom + 1 + DO l = 0, lmaxc(itype) + DO m = -l, l + DO n = 1, nindxc(l, itype) + icst = icst + 1 + point(n, m, l, iatom) = icst + END DO + END DO + END DO + END DO END DO - END DO - END DO - - llmax = 2*lmaxcd - exch = 0 - iatom0 = 0 - DO itype = 1,ntype - ! Calculate the expansion coefficients of the potential in Legendre polynomials - d_ln(:,0:2*lmaxc(itype),:) = calculate_coefficients(rmsh(:,itype),2*lmaxc(itype),ncut,fac) - - DO l1 = 0,lmaxc(itype) ! left core state - - DO l2 = 0,lmaxc(itype) ! right core state - DO l = 0,lmaxc(itype) ! occupied core state - - DO ll = ABS(l1-l),l1+l - IF( ll .LT. ABS(l-l2) .OR. ll .GT. l+l2 ) CYCLE - IF( MOD(l+l1+ll,2) .NE. 0 ) CYCLE - IF( MOD(l+l2+ll,2) .NE. 0 ) CYCLE - - DO m1 = -l1,l1 - m2 = m1 - IF( ABS(m2) .GT. l2 ) CYCLE - DO m = -l,l - mm = m - m1 - IF( ABS(mm) .GT. ll ) CYCLE - rdum = fpi_const/(2*ll+1)*gaunt1(l,ll,l1,m,mm,m1,llmax)*gaunt1(l,ll,l2,m,mm,m2,llmax) - - DO n = 1,nindxc(l,itype) - DO n2 = 1,nindxc(l2,itype) - rprod(:) = ( core1(:,n,l,itype)*core1(:,n2,l2,itype) & - + core2(:,n,l,itype)*core2(:,n2,l2,itype) )/rmsh(:,itype) - - ! Initialization of n Summation - sum_primf = 0.0 - ! Integration over r' - DO cn = 0,ncut ! Summation over Legendre polynomials - primf1 = 0.0 - primf2 = 0.0 - ! Calculate integral for 0 < r' < r - CALL primitivef(primf1,rprod(:)*rmsh(:,itype)**(ll+2*cn+1),rmsh,dx,jri,jmtd,itype,ntype) - ! Calculate integral for r < r' < R - !-itype is to enforce inward integration - CALL primitivef(primf2,d_ln(:,ll,cn)*rprod(:)/rmsh(:,itype)**(ll+2*cn),rmsh,dx,jri,jmtd,-itype,ntype) - ! Multiplication with appropriate prefactors - primf1 = primf1 / rmsh(:,itype)**(ll+2*cn) * d_ln(:,ll,cn) - primf2 = primf2 * rmsh(:,itype)**(ll+2*cn+1) - ! Summation over n - sum_primf = sum_primf + primf1 + primf2 - END DO - - DO n1 = 1,nindxc(l1,itype) - - rprod(:) = ( core1(:,n,l,itype)*core1(:,n1,l1,itype) & - + core2(:,n,l,itype)*core2(:,n1,l1,itype) )/rmsh(:,itype) - - integrand = rprod * sum_primf - - rdum1 = rdum*intgrf(integrand,jri,jmtd,rmsh,dx,ntype,itype,gridf) - - iatom = iatom0 - DO ieq = 1,neq(itype) - iatom = iatom + 1 - icst1 = point(n1,m1,l1,iatom) - icst2 = point(n2,m2,l2,iatom) - exch(icst1,icst2) = exch(icst1,icst2) + rdum1 - END DO - END DO !n1 - - END DO !n2 - END DO !n - - END DO !m - END DO !m1 - - END DO !ll - - END DO !l - END DO !l2 - END DO !l1 - iatom0 = iatom0 + neq(itype) - END DO !itype + + llmax = 2*lmaxcd + exch = 0 + iatom0 = 0 + DO itype = 1, ntype + ! Calculate the expansion coefficients of the potential in Legendre polynomials + d_ln(:, 0:2*lmaxc(itype), :) = calculate_coefficients(rmsh(:, itype), 2*lmaxc(itype), ncut, fac) + + DO l1 = 0, lmaxc(itype) ! left core state + + DO l2 = 0, lmaxc(itype) ! right core state + DO l = 0, lmaxc(itype) ! occupied core state + + DO ll = ABS(l1 - l), l1 + l + IF (ll < ABS(l - l2) .OR. ll > l + l2) CYCLE + IF (MOD(l + l1 + ll, 2) /= 0) CYCLE + IF (MOD(l + l2 + ll, 2) /= 0) CYCLE + + DO m1 = -l1, l1 + m2 = m1 + IF (ABS(m2) > l2) CYCLE + DO m = -l, l + mm = m - m1 + IF (ABS(mm) > ll) CYCLE + rdum = fpi_const/(2*ll + 1)*gaunt1(l, ll, l1, m, mm, m1, llmax)*gaunt1(l, ll, l2, m, mm, m2, llmax) + + DO n = 1, nindxc(l, itype) + DO n2 = 1, nindxc(l2, itype) + rprod(:) = (core1(:, n, l, itype)*core1(:, n2, l2, itype) & + + core2(:, n, l, itype)*core2(:, n2, l2, itype))/rmsh(:, itype) + + ! Initialization of n Summation + sum_primf = 0.0 + ! Integration over r' + DO cn = 0, ncut ! Summation over Legendre polynomials + primf1 = 0.0 + primf2 = 0.0 + ! Calculate integral for 0 < r' < r + CALL primitivef(primf1, rprod(:)*rmsh(:, itype)**(ll + 2*cn + 1), rmsh, dx, jri, jmtd, itype, ntype) + ! Calculate integral for r < r' < R + !-itype is to enforce inward integration + CALL primitivef(primf2, d_ln(:, ll, cn)*rprod(:)/rmsh(:, itype)**(ll + 2*cn), rmsh, dx, jri, jmtd, -itype, ntype) + ! Multiplication with appropriate prefactors + primf1 = primf1/rmsh(:, itype)**(ll + 2*cn)*d_ln(:, ll, cn) + primf2 = primf2*rmsh(:, itype)**(ll + 2*cn + 1) + ! Summation over n + sum_primf = sum_primf + primf1 + primf2 + END DO + + DO n1 = 1, nindxc(l1, itype) + + rprod(:) = (core1(:, n, l, itype)*core1(:, n1, l1, itype) & + + core2(:, n, l, itype)*core2(:, n1, l1, itype))/rmsh(:, itype) + + integrand = rprod*sum_primf + + rdum1 = rdum*intgrf(integrand, jri, jmtd, rmsh, dx, ntype, itype, gridf) + + iatom = iatom0 + DO ieq = 1, neq(itype) + iatom = iatom + 1 + icst1 = point(n1, m1, l1, iatom) + icst2 = point(n2, m2, l2, iatom) + exch(icst1, icst2) = exch(icst1, icst2) + rdum1 + END DO + END DO !n1 + + END DO !n2 + END DO !n + + END DO !m + END DO !m1 + + END DO !ll + + END DO !l + END DO !l2 + END DO !l1 + iatom0 = iatom0 + neq(itype) + END DO !itype # ifdef CPP_INVERSION - CALL symmetrize(exch,ncstd,ncstd,3,.FALSE., & - ntype,ntype,neq,lmaxc,lmaxcd, & - nindxc,natd,invsat,invsatnr) - IF( ANY( ABS(aimag(exch)) .GT. 1E-6 ) ) STOP 'exchange_cccc: exch possesses significant imaginary part' + CALL symmetrize(exch, ncstd, ncstd, 3, .FALSE., & + ntype, ntype, neq, lmaxc, lmaxcd, & + nindxc, natd, invsat, invsatnr) + IF (ANY(ABS(aimag(exch)) > 1E-6)) STOP 'exchange_cccc: exch possesses significant imaginary part' # endif ! DO icst = 1,ncstd ! IF ( irank == 0 ) & ! WRITE(6,'( '' ('',F5.3,'','',F5.3,'','',F5.3,'')'',I4,1X,F12.5)')bkpt,icst,REAL(exch(icst,icst))*(-27.211608) ! END DO - ! add core exchange contributions to the te_hfex - - DO icst1 = 1,ncstd - te_hfex = te_hfex - a_ex * wtkpt(nk,nw)*exch(icst1,icst1) - END DO - - END SUBROUTINE exchange_ccccHSE - - - ! The expansion coefficients of the attenuated Coulomb interaction in Legendre polynomials are calculated. - ! The attenuation is expressed in terms of a complementary error function - ! - ! ----- l+2n - ! erfc(w|r-r'|) \ r / \ - ! --------------- = ) d (wr') --------- P ( cos(r,r') ) - ! |r-r'| / ln l+2n+1 l \ / - ! ----- r' - ! l,n - ! where w is omega of the HSE functional, P_l are the Legendre polynomials and r' > r - ! - ! The coefficients are given as - ! l-1 - ! 2 ----- i+1 2i+1 - ! 1 -x \ 2 x - ! d (x) = erfc(x) + ------- e ) ------------ - ! l,0 ____ / (2i + 1)!! - ! V Pi ----- - ! i=0 - ! - ! n-1 - ! n 2 ----- i+1 l+i+1 2l+2n+2i+1 - ! (-1) -x 2l+1 \ (-1) 2 x - ! d (x) = ------- e ------------- ) ---------------------------- - ! l,n>0 ____ n (2l+2n+1) / i! (n-i-1)! (2l+2i+1)!! - ! V Pi ----- - ! i=0 - ! - ! Input: rmsh - grid of radial position - ! lmax - maximum l value - ! ncut - maximum value for which coefficients are calculated - ! fac - (optional) known factorials - ! Return: d_ln's for all r in rmsh, all 0 <= l <= lmax and all n <= ncut - FUNCTION calculate_coefficients(rmsh,lmax,ncut,fac) RESULT (d_ln) - - USE m_constants - - IMPLICIT NONE - - REAL, INTENT(IN) :: rmsh(:) - INTEGER, INTENT(IN) :: lmax, ncut - REAL, INTENT(IN), OPTIONAL :: fac(0:) - - INTEGER :: ci, cn, cl, fac_size - REAL :: r1_spi, r2l_1, ri, r2l_2i_1, rn, r2l_2n_1 - REAL :: fn(0:MAX(0,ncut-1)) - REAL :: rx(SIZE(rmsh)), x2(SIZE(rmsh)), x2n(SIZE(rmsh)) - REAL :: init(SIZE(rmsh)), addend(SIZE(rmsh)) - REAL :: erfc_x(SIZE(rmsh)), exp_x2(SIZE(rmsh)) - REAL :: d_ln(SIZE(rmsh),0:lmax,0:ncut) - - ! Initialize factorials - IF ( PRESENT(fac) ) THEN - fac_size = MIN(ncut,SIZE(fac)) - fn(0:fac_size-1) = fac(0:fac_size-1) - ELSE - fac_size = 1 - fn(0) = 1.0 - END IF - DO cn=fac_size, ncut-1 - fn(cn) = fn(cn-1) * cn - END DO - - ! Initialize 1 / sqrt(pi) - r1_spi = 1.0 / SQRT( pi_const ) - - ! Calculate x and x^2 and the functions erfc(x) and exp(x^2) - rx = omega_HSe * rmsh - x2 = rx**2 - erfc_x = erfc(rx) - exp_x2 = EXP(-x2) - - ! Calculate the first coefficient - ! l-1 - ! 2 ----- i+1 2i+1 - ! 1 -x \ 2 x - ! d (x) = erfc(x) + ------- e ) ------------ - ! l,0 ____ / (2i + 1)!! - ! V Pi ----- - ! i=0 - ! Initialize the first coefficient - r2l_1 = 1.0 - init = 2.0 * rx * r1_spi * exp_x2 - addend = init - IF (lmax .GE. 0) d_ln(:,0,0) = erfc_x - IF (lmax .GE. 1) d_ln(:,1,0) = addend - ! Iterative calculation of the other coefficients - DO cl = 2,lmax - r2l_1 = r2l_1 + 2.0 - addend = 2.0 * addend * x2 / r2l_1 - d_ln(:,cl,0) = d_ln(:,cl-1,0) + addend - END DO - ! Adding the erfc(x) term which is present in all coefficients - FORALL ( cl=1:lmax ) - d_ln(:,cl,0) = erfc_x + d_ln(:,cl,0) - END FORALL - - ! Calculate all other coefficients - ! n-1 - ! n 2 ----- i+1 l+i+1 2l+2n+2i+1 - ! (-1) -x 2l+1 \ (-1) 2 x - ! d (x) = ------- e ------------- ) ---------------------------- - ! l,n>0 ____ n (2l+2n+1) / i! (n-i-1)! (2l+2i+1)!! - ! V Pi ----- - ! i=0 - ! Initialize helper variables - r2l_1 = -1.0 - DO cl = 0,lmax - ! Calculation of the l-dependent part - r2l_1 = r2l_1 + 2.0 - addend = init * x2 ! addend ~ 2^(l+1) x^(2l+1) / (2l-1)!! - init = 2.0 * addend / r2l_1 - ! Summation over all i - ! i = 0 term - DO cn=1,ncut - d_ln(:,cl,cn) = addend / fn(cn-1) - END DO - ! higher values of i - ri = 0.0 - r2l_2i_1 = r2l_1 - DO ci=1,ncut-1 - ri = ri + 1.0 - r2l_2i_1 = r2l_2i_1 + 2.0 - addend = -2.0 * addend * x2 / ( ri * r2l_2i_1 ) ! addend ~ (-1)^i+1 2^(l+i+1) x^(2l+2i+1) (2l+1) / i!(2l+2i+1)!! - DO cn=ci+1,ncut - d_ln(:,cl,cn) = d_ln(:,cl,cn) + addend / fn(cn-ci-1) - END DO - END DO - r2l_2n_1 = r2l_1 - ! Divide by n and l dependent part - DO cn=1,ncut - r2l_2n_1 = r2l_2n_1 + 2.0 - d_ln(:,cl,cn) = d_ln(:,cl,cn) / r2l_2n_1 - END DO - END DO - ! Resolve only-n dependent part - rn = 1.0 - x2n = x2 - IF (ncut .GE. 1) THEN - FORALL ( cl=0:lmax ) - d_ln(:,cl,1) = d_ln(:,cl,1) * x2 - END FORALL - END IF - DO cn=2,ncut - rn = rn + 1.0 - x2n = -x2n * x2 - FORALL ( cl=0:lmax ) - d_ln(:,cl,cn) = d_ln(:,cl,cn) * x2n / rn - END FORALL - END DO - - END FUNCTION calculate_coefficients + ! add core exchange contributions to the te_hfex + + DO icst1 = 1, ncstd + te_hfex = te_hfex - a_ex*wtkpt(nk, nw)*exch(icst1, icst1) + END DO + + END SUBROUTINE exchange_ccccHSE + + ! The expansion coefficients of the attenuated Coulomb interaction in Legendre polynomials are calculated. + ! The attenuation is expressed in terms of a complementary error function + ! + ! ----- l+2n + ! erfc(w|r-r'|) \ r / \ + ! --------------- = ) d (wr') --------- P ( cos(r,r') ) + ! |r-r'| / ln l+2n+1 l \ / + ! ----- r' + ! l,n + ! where w is omega of the HSE functional, P_l are the Legendre polynomials and r' > r + ! + ! The coefficients are given as + ! l-1 + ! 2 ----- i+1 2i+1 + ! 1 -x \ 2 x + ! d (x) = erfc(x) + ------- e ) ------------ + ! l,0 ____ / (2i + 1)!! + ! V Pi ----- + ! i=0 + ! + ! n-1 + ! n 2 ----- i+1 l+i+1 2l+2n+2i+1 + ! (-1) -x 2l+1 \ (-1) 2 x + ! d (x) = ------- e ------------- ) ---------------------------- + ! l,n>0 ____ n (2l+2n+1) / i! (n-i-1)! (2l+2i+1)!! + ! V Pi ----- + ! i=0 + ! + ! Input: rmsh - grid of radial position + ! lmax - maximum l value + ! ncut - maximum value for which coefficients are calculated + ! fac - (optional) known factorials + ! Return: d_ln's for all r in rmsh, all 0 <= l <= lmax and all n <= ncut + FUNCTION calculate_coefficients(rmsh, lmax, ncut, fac) RESULT(d_ln) + + USE m_constants + + IMPLICIT NONE + + REAL, INTENT(IN) :: rmsh(:) + INTEGER, INTENT(IN) :: lmax, ncut + REAL, INTENT(IN), OPTIONAL :: fac(0:) + + INTEGER :: ci, cn, cl, fac_size + REAL :: r1_spi, r2l_1, ri, r2l_2i_1, rn, r2l_2n_1 + REAL :: fn(0:MAX(0, ncut - 1)) + REAL :: rx(SIZE(rmsh)), x2(SIZE(rmsh)), x2n(SIZE(rmsh)) + REAL :: init(SIZE(rmsh)), addend(SIZE(rmsh)) + REAL :: erfc_x(SIZE(rmsh)), exp_x2(SIZE(rmsh)) + REAL :: d_ln(SIZE(rmsh), 0:lmax, 0:ncut) + + ! Initialize factorials + IF (PRESENT(fac)) THEN + fac_size = MIN(ncut, SIZE(fac)) + fn(0:fac_size - 1) = fac(0:fac_size - 1) + ELSE + fac_size = 1 + fn(0) = 1.0 + END IF + DO cn = fac_size, ncut - 1 + fn(cn) = fn(cn - 1)*cn + END DO + + ! Initialize 1 / sqrt(pi) + r1_spi = 1.0/SQRT(pi_const) + + ! Calculate x and x^2 and the functions erfc(x) and exp(x^2) + rx = omega_HSe*rmsh + x2 = rx**2 + erfc_x = erfc(rx) + exp_x2 = EXP(-x2) + + ! Calculate the first coefficient + ! l-1 + ! 2 ----- i+1 2i+1 + ! 1 -x \ 2 x + ! d (x) = erfc(x) + ------- e ) ------------ + ! l,0 ____ / (2i + 1)!! + ! V Pi ----- + ! i=0 + ! Initialize the first coefficient + r2l_1 = 1.0 + init = 2.0*rx*r1_spi*exp_x2 + addend = init + IF (lmax >= 0) d_ln(:, 0, 0) = erfc_x + IF (lmax >= 1) d_ln(:, 1, 0) = addend + ! Iterative calculation of the other coefficients + DO cl = 2, lmax + r2l_1 = r2l_1 + 2.0 + addend = 2.0*addend*x2/r2l_1 + d_ln(:, cl, 0) = d_ln(:, cl - 1, 0) + addend + END DO + ! Adding the erfc(x) term which is present in all coefficients + FORALL (cl=1:lmax) + d_ln(:, cl, 0) = erfc_x + d_ln(:, cl, 0) + END FORALL + + ! Calculate all other coefficients + ! n-1 + ! n 2 ----- i+1 l+i+1 2l+2n+2i+1 + ! (-1) -x 2l+1 \ (-1) 2 x + ! d (x) = ------- e ------------- ) ---------------------------- + ! l,n>0 ____ n (2l+2n+1) / i! (n-i-1)! (2l+2i+1)!! + ! V Pi ----- + ! i=0 + ! Initialize helper variables + r2l_1 = -1.0 + DO cl = 0, lmax + ! Calculation of the l-dependent part + r2l_1 = r2l_1 + 2.0 + addend = init*x2 ! addend ~ 2^(l+1) x^(2l+1) / (2l-1)!! + init = 2.0*addend/r2l_1 + ! Summation over all i + ! i = 0 term + DO cn = 1, ncut + d_ln(:, cl, cn) = addend/fn(cn - 1) + END DO + ! higher values of i + ri = 0.0 + r2l_2i_1 = r2l_1 + DO ci = 1, ncut - 1 + ri = ri + 1.0 + r2l_2i_1 = r2l_2i_1 + 2.0 + addend = -2.0*addend*x2/(ri*r2l_2i_1) ! addend ~ (-1)^i+1 2^(l+i+1) x^(2l+2i+1) (2l+1) / i!(2l+2i+1)!! + DO cn = ci + 1, ncut + d_ln(:, cl, cn) = d_ln(:, cl, cn) + addend/fn(cn - ci - 1) + END DO + END DO + r2l_2n_1 = r2l_1 + ! Divide by n and l dependent part + DO cn = 1, ncut + r2l_2n_1 = r2l_2n_1 + 2.0 + d_ln(:, cl, cn) = d_ln(:, cl, cn)/r2l_2n_1 + END DO + END DO + ! Resolve only-n dependent part + rn = 1.0 + x2n = x2 + IF (ncut >= 1) THEN + FORALL (cl=0:lmax) + d_ln(:, cl, 1) = d_ln(:, cl, 1)*x2 + END FORALL + END IF + DO cn = 2, ncut + rn = rn + 1.0 + x2n = -x2n*x2 + FORALL (cl=0:lmax) + d_ln(:, cl, cn) = d_ln(:, cl, cn)*x2n/rn + END FORALL + END DO + + END FUNCTION calculate_coefficients END MODULE m_hsefunctional diff --git a/hybrid/hsfock.F90 b/hybrid/hsfock.F90 index 78aaa3df60f1a8c706a69768d4defa98c09c4c65..a38749db0a47af7593c3c2a46ebe2589b14a373c 100644 --- a/hybrid/hsfock.F90 +++ b/hybrid/hsfock.F90 @@ -44,190 +44,190 @@ MODULE m_hsfock CONTAINS -SUBROUTINE hsfock(nk,atoms,hybrid,lapw,dimension,kpts,jsp,input,hybdat,eig_irr,sym,cell,noco,& - results,it,mnobd,xcpot,mpi) - - USE m_types - USE m_symm_hf - USE m_util ,ONLY: intgrf,intgrf_init - USE m_exchange_valence_hf - USE m_exchange_core - USE m_symmetrizeh - USE m_wrapper - USE m_hsefunctional ,ONLY: exchange_vccvHSE,exchange_ccccHSE - USE m_io_hybrid - - IMPLICIT NONE - - TYPE(t_xcpot_inbuild), INTENT(IN) :: xcpot - TYPE(t_mpi), INTENT(IN) :: mpi - TYPE(t_dimension), INTENT(IN) :: dimension - TYPE(t_input), INTENT(IN) :: input - TYPE(t_noco), INTENT(IN) :: noco - TYPE(t_sym), INTENT(IN) :: sym - TYPE(t_cell), INTENT(IN) :: cell - TYPE(t_kpts), INTENT(IN) :: kpts - TYPE(t_atoms), INTENT(IN) :: atoms - TYPE(t_lapw), INTENT(IN) :: lapw - TYPE(t_hybrid), INTENT(INOUT) :: hybrid - TYPE(t_hybdat), INTENT(INOUT) :: hybdat - TYPE(t_results), INTENT(INOUT) :: results - - ! scalars - INTEGER, INTENT(IN) :: jsp - INTEGER, INTENT(IN) :: it - INTEGER, INTENT(IN) :: nk - INTEGER, INTENT(IN) :: mnobd - - ! arrays - REAL, INTENT(IN) :: eig_irr(dimension%neigd,kpts%nkpt) - - ! local scalars - INTEGER :: i,j,ic,ic1,l,itype,n,nn - INTEGER :: iband,iband1,iband2 - INTEGER :: ikpt,ikpt0 - INTEGER :: irec - INTEGER :: irecl_olap,irecl_z,irecl_vx - INTEGER :: nbasfcn - INTEGER :: nsymop - INTEGER :: nkpt_EIBZ - INTEGER :: ncstd - INTEGER :: ok - REAL :: a_ex - - ! local arrays - 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(:) - INTEGER,ALLOCATABLE :: pointer_EIBZ(:) - INTEGER,ALLOCATABLE :: n_q(:) - - REAL :: wl_iks(dimension%neigd,kpts%nkptf) - - TYPE(t_mat) :: olap,trafo,invtrafo,ex,tmp,v_x,z - COMPLEX :: exch(dimension%neigd,dimension%neigd) - COMPLEX,ALLOCATABLE :: carr(:) - - CALL timestart("total time hsfock") - - ! preparations - - ! initialize gridf for radial integration - !CALL intgrf_init(atoms%ntype,atoms%jmtd,atoms%jri,atoms%dx,atoms%rmsh,hybdat%gridf) - - ! initialize weighting factor for HF exchange part - a_ex=xcpot%get_exchange_weight() - - ! read in lower triangle part of overlap matrix from direct acces file olap - call timestart("read in 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) - call read_olap(olap, kpts%nkpt*(jsp-1)+nk) - IF (olap%l_real) THEN - DO i=1,nbasfcn - DO j=1,i - olap%data_r(i,j) = olap%data_r(j,i) - END DO - END DO - ELSE - DO i=1,nbasfcn - DO j=1,i - olap%data_c(i,j) = CONJG(olap%data_c(j,i)) - END DO - END DO - olap%data_c=conjg(olap%data_c) - END IF - call timestop("read in olap") - - IF(hybrid%l_calhf) THEN - ncstd = sum( (/ ( (hybdat%nindxc(l,itype)*(2*l+1)*atoms%neq(itype),l=0,hybdat%lmaxc(itype)), itype = 1,atoms%ntype) /) ) - IF( nk .eq. 1 .and. mpi%irank == 0 ) WRITE(*,*) 'calculate new HF matrix' - IF( nk .eq. 1 .and. jsp .eq. 1 .and. input%imix .gt. 10) CALL system('rm -f broyd*') - ! calculate all symmetrie operations, which yield k invariant - - ALLOCATE(parent(kpts%nkptf), stat=ok) - IF(ok.NE.0) STOP 'mhsfock: failure allocation parent' - parent = 0 - - CALL timestart("symm_hf") - CALL symm_hf_init(sym,kpts,nk,nsymop,rrot,psym) - - CALL symm_hf(kpts,nk,sym,dimension,hybdat,eig_irr,atoms,hybrid,cell,lapw,jsp,mpi,& - rrot,nsymop,psym,nkpt_EIBZ,n_q,parent,pointer_EIBZ,nsest,indx_sest) - CALL timestop("symm_hf") - - ! remove weights(wtkpt) in w_iks - DO ikpt=1,kpts%nkptf - DO iband=1,dimension%neigd - ikpt0 = kpts%bkp(ikpt) - wl_iks(iband,ikpt) = results%w_iks(iband,ikpt0,jsp) / (kpts%wtkpt(ikpt0)*kpts%nkptf) + SUBROUTINE hsfock(nk, atoms, hybrid, lapw, dimension, kpts, jsp, input, hybdat, eig_irr, sym, cell, noco, & + results, it, mnobd, xcpot, mpi) + + USE m_types + USE m_symm_hf + USE m_util, ONLY: intgrf, intgrf_init + USE m_exchange_valence_hf + USE m_exchange_core + USE m_symmetrizeh + USE m_wrapper + USE m_hsefunctional, ONLY: exchange_vccvHSE, exchange_ccccHSE + USE m_io_hybrid + + IMPLICIT NONE + + TYPE(t_xcpot_inbuild), INTENT(IN) :: xcpot + TYPE(t_mpi), INTENT(IN) :: mpi + TYPE(t_dimension), INTENT(IN) :: dimension + TYPE(t_input), INTENT(IN) :: input + TYPE(t_noco), INTENT(IN) :: noco + TYPE(t_sym), INTENT(IN) :: sym + TYPE(t_cell), INTENT(IN) :: cell + TYPE(t_kpts), INTENT(IN) :: kpts + TYPE(t_atoms), INTENT(IN) :: atoms + TYPE(t_lapw), INTENT(IN) :: lapw + TYPE(t_hybrid), INTENT(INOUT) :: hybrid + TYPE(t_hybdat), INTENT(INOUT) :: hybdat + TYPE(t_results), INTENT(INOUT) :: results + + ! scalars + INTEGER, INTENT(IN) :: jsp + INTEGER, INTENT(IN) :: it + INTEGER, INTENT(IN) :: nk + INTEGER, INTENT(IN) :: mnobd + + ! arrays + REAL, INTENT(IN) :: eig_irr(dimension%neigd, kpts%nkpt) + + ! local scalars + INTEGER :: i, j, ic, ic1, l, itype, n, nn + INTEGER :: iband, iband1, iband2 + INTEGER :: ikpt, ikpt0 + INTEGER :: irec + INTEGER :: irecl_olap, irecl_z, irecl_vx + INTEGER :: nbasfcn + INTEGER :: nsymop + INTEGER :: nkpt_EIBZ + INTEGER :: ncstd + INTEGER :: ok + REAL :: a_ex + + ! local arrays + 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(:) + INTEGER, ALLOCATABLE :: pointer_EIBZ(:) + INTEGER, ALLOCATABLE :: n_q(:) + + REAL :: wl_iks(dimension%neigd, kpts%nkptf) + + TYPE(t_mat) :: olap, trafo, invtrafo, ex, tmp, v_x, z + COMPLEX :: exch(dimension%neigd, dimension%neigd) + COMPLEX, ALLOCATABLE :: carr(:) + + CALL timestart("total time hsfock") + + ! preparations + + ! initialize gridf for radial integration + !CALL intgrf_init(atoms%ntype,atoms%jmtd,atoms%jri,atoms%dx,atoms%rmsh,hybdat%gridf) + + ! initialize weighting factor for HF exchange part + a_ex = xcpot%get_exchange_weight() + + ! read in lower triangle part of overlap matrix from direct acces file olap + call timestart("read in 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) + call read_olap(olap, kpts%nkpt*(jsp - 1) + nk) + IF (olap%l_real) THEN + DO i = 1, nbasfcn + DO j = 1, i + olap%data_r(i, j) = olap%data_r(j, i) + END DO END DO - END DO - - ! calculate contribution from valence electrons to the - ! HF exchange - 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,ex) - - CALL timestart("core exchange calculation") - - ! calculate contribution from the core states to the HF exchange - IF (xcpot%is_name("hse").OR.xcpot%is_name("vhse")) THEN -#ifdef CPP_NEVER - CALL exchange_vccvHSE(nk,atoms,hybrid,hybdat,dimension,jsp,lapw,nsymop,nsest,indx_sest,mpi,a_ex,results,mat_ex%core) - CALL exchange_ccccHSE(nk,obsolete,atoms,hybdat,ncstd,kpts(:,nk),sym,a_ex,mpi,results%core) -#endif - STOP "HSE not implemented in hsfock" ELSE - CALL exchange_vccv1(nk,atoms,hybrid,hybdat,dimension,jsp,lapw,nsymop,nsest,indx_sest,mpi,a_ex,results,ex) - CALL exchange_cccc(nk,atoms,hybdat,ncstd,sym,kpts,a_ex,mpi,results) + DO i = 1, nbasfcn + DO j = 1, i + olap%data_c(i, j) = CONJG(olap%data_c(j, i)) + END DO + END DO + olap%data_c = conjg(olap%data_c) END IF + call timestop("read in olap") + + IF (hybrid%l_calhf) THEN + ncstd = sum((/((hybdat%nindxc(l, itype)*(2*l + 1)*atoms%neq(itype), l=0, hybdat%lmaxc(itype)), itype=1, atoms%ntype)/)) + IF (nk == 1 .and. mpi%irank == 0) WRITE (*, *) 'calculate new HF matrix' + IF (nk == 1 .and. jsp == 1 .and. input%imix > 10) CALL system('rm -f broyd*') + ! calculate all symmetrie operations, which yield k invariant + + ALLOCATE (parent(kpts%nkptf), stat=ok) + IF (ok /= 0) STOP 'mhsfock: failure allocation parent' + parent = 0 + + CALL timestart("symm_hf") + CALL symm_hf_init(sym, kpts, nk, nsymop, rrot, psym) + + CALL symm_hf(kpts, nk, sym, dimension, hybdat, eig_irr, atoms, hybrid, cell, lapw, jsp, mpi, & + rrot, nsymop, psym, nkpt_EIBZ, n_q, parent, pointer_EIBZ, nsest, indx_sest) + CALL timestop("symm_hf") + + ! remove weights(wtkpt) in w_iks + DO ikpt = 1, kpts%nkptf + DO iband = 1, dimension%neigd + ikpt0 = kpts%bkp(ikpt) + wl_iks(iband, ikpt) = results%w_iks(iband, ikpt0, jsp)/(kpts%wtkpt(ikpt0)*kpts%nkptf) + END DO + END DO - DEALLOCATE(n_q) - CALL timestop("core exchange calculation") - - CALL timestart("time for performing T^-1*mat_ex*T^-1*") - !calculate trafo from wavefunctions to APW basis - IF(dimension%neigd.LT.hybrid%nbands(nk)) STOP " mhsfock: neigd < nbands(nk) ;trafo from wavefunctions to APW requires at least nbands(nk)" - - call z%init(olap%l_real,nbasfcn,dimension%neigd) - call read_z(z,kpts%nkpt*(jsp-1)+nk) - z%matsize2 = hybrid%nbands(nk) ! reduce "visible matsize" for the following computations - - call olap%multiply(z,trafo) + ! calculate contribution from valence electrons to the + ! HF exchange + 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, ex) - CALL invtrafo%alloc(olap%l_real,hybrid%nbands(nk),nbasfcn) - CALL trafo%TRANSPOSE(invtrafo) - IF(.NOT.invtrafo%l_real) invtrafo%data_c = CONJG(invtrafo%data_c) + CALL timestart("core exchange calculation") - DO i=1,hybrid%nbands(nk) - DO j=1,i-1 - IF (ex%l_real) THEN - ex%data_r(i,j)=ex%data_r(j,i) - ELSE - ex%data_c(i,j)=conjg(ex%data_c(j,i)) - END IF + ! calculate contribution from the core states to the HF exchange + IF (xcpot%is_name("hse") .OR. xcpot%is_name("vhse")) THEN +#ifdef CPP_NEVER + CALL exchange_vccvHSE(nk, atoms, hybrid, hybdat, dimension, jsp, lapw, nsymop, nsest, indx_sest, mpi, a_ex, results, mat_ex%core) + CALL exchange_ccccHSE(nk, obsolete, atoms, hybdat, ncstd, kpts(:, nk), sym, a_ex, mpi, results%core) +#endif + STOP "HSE not implemented in hsfock" + ELSE + CALL exchange_vccv1(nk, atoms, hybrid, hybdat, dimension, jsp, lapw, nsymop, nsest, indx_sest, mpi, a_ex, results, ex) + CALL exchange_cccc(nk, atoms, hybdat, ncstd, sym, kpts, a_ex, mpi, results) + END IF + + DEALLOCATE (n_q) + CALL timestop("core exchange calculation") + + CALL timestart("time for performing T^-1*mat_ex*T^-1*") + !calculate trafo from wavefunctions to APW basis + IF (dimension%neigd < hybrid%nbands(nk)) STOP " mhsfock: neigd < nbands(nk) ;trafo from wavefunctions to APW requires at least nbands(nk)" + + call z%init(olap%l_real, nbasfcn, dimension%neigd) + call read_z(z, kpts%nkpt*(jsp - 1) + nk) + z%matsize2 = hybrid%nbands(nk) ! reduce "visible matsize" for the following computations + + call olap%multiply(z, trafo) + + CALL invtrafo%alloc(olap%l_real, hybrid%nbands(nk), nbasfcn) + CALL trafo%TRANSPOSE(invtrafo) + IF (.NOT. invtrafo%l_real) invtrafo%data_c = CONJG(invtrafo%data_c) + + DO i = 1, hybrid%nbands(nk) + DO j = 1, i - 1 + IF (ex%l_real) THEN + ex%data_r(i, j) = ex%data_r(j, i) + ELSE + ex%data_c(i, j) = conjg(ex%data_c(j, i)) + END IF + ENDDO ENDDO - ENDDO - CALL ex%multiply(invtrafo,tmp) - CALL trafo%multiply(tmp,v_x) - - CALL timestop("time for performing T^-1*mat_ex*T^-1*") + CALL ex%multiply(invtrafo, tmp) + CALL trafo%multiply(tmp, v_x) + + CALL timestop("time for performing T^-1*mat_ex*T^-1*") - call timestart("symmetrizeh") - CALL symmetrizeh(atoms,kpts%bkf(:,nk),dimension,jsp,lapw,sym,hybdat%kveclo_eig,cell,nsymop,psym,v_x) - call timestop("symmetrizeh") + call timestart("symmetrizeh") + CALL symmetrizeh(atoms, kpts%bkf(:, nk), dimension, jsp, lapw, sym, hybdat%kveclo_eig, cell, nsymop, psym, v_x) + call timestop("symmetrizeh") - CALL write_v_x(v_x,kpts%nkpt*(jsp-1) + nk) - END IF ! hybrid%l_calhf + CALL write_v_x(v_x, kpts%nkpt*(jsp - 1) + nk) + END IF ! hybrid%l_calhf - CALL timestop("total time hsfock") + CALL timestop("total time hsfock") -END SUBROUTINE hsfock + END SUBROUTINE hsfock END MODULE m_hsfock diff --git a/hybrid/hyb_abcrot.F90 b/hybrid/hyb_abcrot.F90 index b9d9ae8be3d2175e52b7a16daae6fb4a0dedb7d3..507cc938fb18e63e654fd62bfa59bd8a771ede20 100644 --- a/hybrid/hyb_abcrot.F90 +++ b/hybrid/hyb_abcrot.F90 @@ -1,8 +1,8 @@ MODULE m_hyb_abcrot - CONTAINS - SUBROUTINE hyb_abcrot(hybrid,atoms,neig,sym,cell,oneD,& - & acof,bcof,ccof) +CONTAINS + SUBROUTINE hyb_abcrot(hybrid, atoms, neig, sym, cell, oneD,& + & acof, bcof, ccof) ! *************************************************************** ! * This routine transforms a/b/cof which are given wrt rotated * ! * MT functions (according to invsat/ngopr) into a/b/cof wrt * @@ -13,80 +13,80 @@ MODULE m_hyb_abcrot USE m_dwigner USE m_types IMPLICIT NONE - TYPE(t_hybrid),INTENT(IN) :: hybrid - TYPE(t_oneD),INTENT(IN) :: oneD - TYPE(t_sym),INTENT(IN) :: sym - TYPE(t_cell),INTENT(IN) :: cell - TYPE(t_atoms),INTENT(IN) :: atoms + TYPE(t_hybrid), INTENT(IN) :: hybrid + TYPE(t_oneD), INTENT(IN) :: oneD + TYPE(t_sym), INTENT(IN) :: sym + TYPE(t_cell), INTENT(IN) :: cell + TYPE(t_atoms), INTENT(IN) :: atoms ! .. ! .. Scalar Arguments .. - INTEGER, INTENT (IN) :: neig + INTEGER, INTENT(IN) :: neig ! .. ! .. Array Arguments .. - COMPLEX, INTENT (INOUT) :: acof(:,0:,:) !(dimension%neigd,0:dimension%lmd,atoms%natd) - COMPLEX, INTENT (INOUT) :: bcof(:,0:,:) !(dimension%neigd,0:dimension%lmd,atoms%natd) - COMPLEX, INTENT (INOUT) :: ccof(-atoms%llod:,:,:,:)!(-llod:llod,dimension%neigd,atoms%nlod,atoms%natd) + COMPLEX, INTENT(INOUT) :: acof(:, 0:, :) !(dimension%neigd,0:dimension%lmd,atoms%natd) + COMPLEX, INTENT(INOUT) :: bcof(:, 0:, :) !(dimension%neigd,0:dimension%lmd,atoms%natd) + COMPLEX, INTENT(INOUT) :: ccof(-atoms%llod:, :, :, :)!(-llod:llod,dimension%neigd,atoms%nlod,atoms%natd) ! .. ! .. Local Scalars .. - INTEGER itype,ineq,iatom,iop,ilo,i,l ,lm,lmp,ifac + INTEGER itype, ineq, iatom, iop, ilo, i, l, lm, lmp, ifac ! .. ! .. Local Arrays .. !***** COMPLEX, ALLOCATABLE :: d_wgn(:,:,:,:) !put into module m_savewigner ! - IF ( .NOT.ALLOCATED(hybrid%d_wgn2) ) THEN !calculate sym%d_wgn only once + IF (.NOT. ALLOCATED(hybrid%d_wgn2)) THEN !calculate sym%d_wgn only once #ifndef CPP_MPI - PRINT*,"calculate wigner-matrix" + PRINT *, "calculate wigner-matrix" #endif - STOP "WIGNER MATRIX should be available in hybrid part" - !IF (.NOT.oneD%odi%d1) THEN - ! ALLOCATE (sym%d_wgn(-atoms%lmaxd:atoms%lmaxd,-atoms%lmaxd:atoms%lmaxd,atoms%lmaxd,sym%nop)) - ! CALL d_wigner(sym%nop,sym%mrot,cell%bmat,atoms%lmaxd,sym%d_wgn) - !ELSE - ! ALLOCATE (sym%d_wgn(-atoms%lmaxd:atoms%lmaxd,-atoms%lmaxd:atoms%lmaxd,atoms%lmaxd,oneD%ods%nop)) - ! CALL d_wigner(oneD%ods%nop,oneD%ods%mrot,cell%bmat,atoms%lmaxd,sym%d_wgn) - !ENDIF + STOP "WIGNER MATRIX should be available in hybrid part" + !IF (.NOT.oneD%odi%d1) THEN + ! ALLOCATE (sym%d_wgn(-atoms%lmaxd:atoms%lmaxd,-atoms%lmaxd:atoms%lmaxd,atoms%lmaxd,sym%nop)) + ! CALL d_wigner(sym%nop,sym%mrot,cell%bmat,atoms%lmaxd,sym%d_wgn) + !ELSE + ! ALLOCATE (sym%d_wgn(-atoms%lmaxd:atoms%lmaxd,-atoms%lmaxd:atoms%lmaxd,atoms%lmaxd,oneD%ods%nop)) + ! CALL d_wigner(oneD%ods%nop,oneD%ods%mrot,cell%bmat,atoms%lmaxd,sym%d_wgn) + !ENDIF ENDIF - iatom=0 - DO itype=1,atoms%ntype - DO ineq=1,atoms%neq(itype) - iatom=iatom+1 - IF (.NOT.oneD%odi%d1) THEN - iop=atoms%ngopr(iatom) - ELSE - iop=oneD%ods%ngopr(iatom) - ENDIF + iatom = 0 + DO itype = 1, atoms%ntype + DO ineq = 1, atoms%neq(itype) + iatom = iatom + 1 + IF (.NOT. oneD%odi%d1) THEN + iop = atoms%ngopr(iatom) + ELSE + iop = oneD%ods%ngopr(iatom) + ENDIF ! l l l ! inversion of spherical harmonics: Y (pi-theta,pi+phi) = (-1) * Y (theta,phi) ! m m - ifac = 1 - IF(atoms%invsat(iatom).EQ.2) THEN - IF (.NOT.oneD%odi%d1) THEN - iop=atoms%ngopr(sym%invsatnr(iatom)) - ELSE - iop=oneD%ods%ngopr(sym%invsatnr(iatom)) + ifac = 1 + IF (atoms%invsat(iatom) == 2) THEN + IF (.NOT. oneD%odi%d1) THEN + iop = atoms%ngopr(sym%invsatnr(iatom)) + ELSE + iop = oneD%ods%ngopr(sym%invsatnr(iatom)) + ENDIF + ifac = -1 ENDIF - ifac = -1 - ENDIF - DO l=1,atoms%lmax(itype) + DO l = 1, atoms%lmax(itype) ! replaced d_wgn by conjg(d_wgn),FF October 2006 - DO i=1,neig - acof(i,l**2:l*(l+2),iatom) = ifac**l * matmul(conjg(hybrid%d_wgn2(-l:l,-l:l,l,iop)), acof(i,l**2:l*(l+2),iatom)) - bcof(i,l**2:l*(l+2),iatom) = ifac**l * matmul(conjg(hybrid%d_wgn2(-l:l,-l:l,l,iop)), bcof(i,l**2:l*(l+2),iatom)) + DO i = 1, neig + acof(i, l**2:l*(l + 2), iatom) = ifac**l*matmul(conjg(hybrid%d_wgn2(-l:l, -l:l, l, iop)), acof(i, l**2:l*(l + 2), iatom)) + bcof(i, l**2:l*(l + 2), iatom) = ifac**l*matmul(conjg(hybrid%d_wgn2(-l:l, -l:l, l, iop)), bcof(i, l**2:l*(l + 2), iatom)) + ENDDO ENDDO - ENDDO - DO ilo=1,atoms%nlo(itype) - l=atoms%llo(ilo,itype) - IF(l.gt.0) THEN - DO i=1,neig - ccof(-l:l,i,ilo,iatom) = ifac**l * matmul(conjg(hybrid%d_wgn2(-l:l,-l:l,l,iop)), ccof(-l:l,i,ilo,iatom)) - ENDDO - ENDIF - ENDDO - ENDDO + DO ilo = 1, atoms%nlo(itype) + l = atoms%llo(ilo, itype) + IF (l > 0) THEN + DO i = 1, neig + ccof(-l:l, i, ilo, iatom) = ifac**l*matmul(conjg(hybrid%d_wgn2(-l:l, -l:l, l, iop)), ccof(-l:l, i, ilo, iatom)) + ENDDO + ENDIF + ENDDO + ENDDO ENDDO - END SUBROUTINE hyb_abcrot - END MODULE m_hyb_abcrot + END SUBROUTINE hyb_abcrot +END MODULE m_hyb_abcrot diff --git a/hybrid/hybrid.F90 b/hybrid/hybrid.F90 index 76c4fa2bf8f9244f6b5b918cb11c327fceae5270..2ba07db0239ac17b085839c7d340f3908ff7da1d 100644 --- a/hybrid/hybrid.F90 +++ b/hybrid/hybrid.F90 @@ -6,138 +6,137 @@ MODULE m_calc_hybrid - USE m_judft + USE m_judft CONTAINS - SUBROUTINE calc_hybrid(eig_id,hybrid,kpts,atoms,input,DIMENSION,mpi,noco,cell,oneD,& - enpara,results,sym,xcpot,v,iter,iterHF) - - USE m_types - USE m_mixedbasis - USE m_coulombmatrix - USE m_hf_init - USE m_hf_setup - USE m_hsfock - USE m_eig66_io - USE m_io_hybrid - - IMPLICIT NONE - - TYPE(t_xcpot_inbuild), 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_input), INTENT(IN) :: input - TYPE(t_noco), INTENT(IN) :: noco - TYPE(t_enpara), INTENT(IN) :: enpara - TYPE(t_results), INTENT(INOUT) :: results - TYPE(t_sym), INTENT(IN) :: sym - TYPE(t_cell), INTENT(IN) :: cell - TYPE(t_kpts), INTENT(IN) :: kpts - TYPE(t_atoms), INTENT(IN) :: atoms - TYPE(t_potden), INTENT(IN) :: v - - INTEGER, INTENT(IN) :: iter - INTEGER, INTENT(INOUT) :: iterHF - INTEGER, INTENT(IN) :: eig_id - - ! local variables - INTEGER :: jsp,nk,nred - TYPE(t_hybdat) :: hybdat - type(t_lapw) :: lapw - LOGICAL :: init_vex=.TRUE. !In first call we have to init v_nonlocal - LOGICAL :: l_restart=.FALSE. - LOGICAL :: l_zref - - REAL :: bkpt(3) - REAL, ALLOCATABLE :: eig_irr(:,:) - - CALL timestart("Hybrid code") - INQUIRE(file="v_x.mat",exist=hybrid%l_addhf) - CALL open_hybrid_io1(DIMENSION,sym%invs) - - IF (kpts%nkptf==0) THEN - CALL judft_error("kpoint-set of full BZ not available",& - hint="to generate kpts in the full BZ you should specify a k-mesh in inp.xml") - END IF - - !Check if new non-local potential shall be generated - hybrid%l_subvxc = hybrid%l_hybrid.AND.(.NOT.xcpot%is_name("exx")) - !If this is the first iteration loop we can not calculate a new non-local potential - hybrid%l_calhf = (results%last_distance.GE.0.0).AND.(results%last_distance.LT.input%minDistance) - IF(.NOT.hybrid%l_calhf) THEN - hybrid%l_subvxc = hybrid%l_subvxc.AND.hybrid%l_addhf - CALL timestop("Hybrid code") - RETURN - ENDIF - - results%te_hfex%core = 0 - - !Check if we are converged well enough to calculate a new potential + SUBROUTINE calc_hybrid(eig_id, hybrid, kpts, atoms, input, DIMENSION, mpi, noco, cell, oneD, & + enpara, results, sym, xcpot, v, iter, iterHF) + + USE m_types + USE m_mixedbasis + USE m_coulombmatrix + USE m_hf_init + USE m_hf_setup + USE m_hsfock + USE m_eig66_io + USE m_io_hybrid + + IMPLICIT NONE + + TYPE(t_xcpot_inbuild), 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_input), INTENT(IN) :: input + TYPE(t_noco), INTENT(IN) :: noco + TYPE(t_enpara), INTENT(IN) :: enpara + TYPE(t_results), INTENT(INOUT) :: results + TYPE(t_sym), INTENT(IN) :: sym + TYPE(t_cell), INTENT(IN) :: cell + TYPE(t_kpts), INTENT(IN) :: kpts + TYPE(t_atoms), INTENT(IN) :: atoms + TYPE(t_potden), INTENT(IN) :: v + + INTEGER, INTENT(IN) :: iter + INTEGER, INTENT(INOUT) :: iterHF + INTEGER, INTENT(IN) :: eig_id + + ! local variables + INTEGER :: jsp, nk, nred + TYPE(t_hybdat) :: hybdat + type(t_lapw) :: lapw + LOGICAL :: init_vex = .TRUE. !In first call we have to init v_nonlocal + LOGICAL :: l_restart = .FALSE. + LOGICAL :: l_zref + + REAL :: bkpt(3) + REAL, ALLOCATABLE :: eig_irr(:, :) + + CALL timestart("Hybrid code") + INQUIRE (file="v_x.mat", exist=hybrid%l_addhf) + CALL open_hybrid_io1(DIMENSION, sym%invs) + + IF (kpts%nkptf == 0) THEN + CALL judft_error("kpoint-set of full BZ not available", & + hint="to generate kpts in the full BZ you should specify a k-mesh in inp.xml") + END IF + + !Check if new non-local potential shall be generated + hybrid%l_subvxc = hybrid%l_hybrid .AND. (.NOT. xcpot%is_name("exx")) + !If this is the first iteration loop we can not calculate a new non-local potential + hybrid%l_calhf = (results%last_distance >= 0.0) .AND. (results%last_distance < input%minDistance) + IF (.NOT. hybrid%l_calhf) THEN + hybrid%l_subvxc = hybrid%l_subvxc .AND. hybrid%l_addhf + CALL timestop("Hybrid code") + RETURN + ENDIF + + results%te_hfex%core = 0 + + !Check if we are converged well enough to calculate a new potential #if defined(CPP_MPI)&&defined(CPP_NEVER) - CALL judft_error("Hybrid functionals do not work in parallel version yet") - CALL MPI_BCAST(results%last_distance .... + CALL judft_error("Hybrid functionals do not work in parallel version yet") + CALL MPI_BCAST(results%last_distance.... #endif - CALL open_hybrid_io1b(DIMENSION,sym%invs) - hybrid%l_addhf = .TRUE. - - !In first iteration allocate some memory - IF (init_vex) THEN - ALLOCATE(hybrid%ne_eig(kpts%nkpt),hybrid%nbands(kpts%nkpt),hybrid%nobd(kpts%nkptf)) - ALLOCATE(hybrid%nbasm(kpts%nkptf)) - ALLOCATE(hybrid%div_vv(DIMENSION%neigd,kpts%nkpt,input%jspins)) - init_vex=.FALSE. - END IF - - hybrid%l_subvxc = (hybrid%l_subvxc.AND.hybrid%l_addhf) - IF(.NOT.ALLOCATED(results%w_iks)) ALLOCATE (results%w_iks(DIMENSION%neigd2,kpts%nkpt,input%jspins)) - - IF (hybrid%l_calhf) THEN - iterHF = iterHF + 1 - - !Delete broyd files - CALL system("rm -f broyd*") - - !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) - - CALL timestart("Preparation for Hybrid functionals") - ! CALL juDFT_WARN ("Hybrid functionals not working in this version") - - !construct the mixed-basis - CALL timestart("generation of mixed basis") - CALL mixedbasis(atoms,kpts,dimension,input,cell,sym,xcpot,hybrid,enpara,mpi,v,l_restart) - CALL timestop("generation of mixed basis") - - CALL open_hybrid_io2(hybrid,DIMENSION,atoms,sym%invs) - - CALL coulombmatrix(mpi,atoms,kpts,cell,sym,hybrid,xcpot,l_restart) - - CALL hf_init(hybrid,kpts,atoms,input,DIMENSION,hybdat,sym%invs) - CALL timestop("Preparation for Hybrid functionals") - CALL timestart("Calculation of non-local HF potential") - DO jsp = 1,input%jspins - call timestart("HF_setup") - CALL HF_setup(hybrid,input,sym,kpts,dimension,atoms,mpi,noco,cell,oneD,results,jsp,enpara,eig_id,& - hybdat,iterHF,sym%invs,v%mt(:,0,:,:),eig_irr) - call timestop("HF_setup") - - - DO nk = 1,kpts%nkpt - !DO nk = mpi%n_start,kpts%nkpt,mpi%n_stride - CALL lapw%init(input,noco, kpts,atoms,sym,nk,cell,l_zref) - CALL hsfock(nk,atoms,hybrid,lapw,DIMENSION,kpts,jsp,input,hybdat,eig_irr,sym,cell,& - noco,results,iterHF,MAXVAL(hybrid%nobd),xcpot,mpi) - END DO - END DO - CALL timestop("Calculation of non-local HF potential") - CALL close_eig(eig_id) - - ENDIF - CALL timestop("Hybrid code") - END SUBROUTINE calc_hybrid + CALL open_hybrid_io1b(DIMENSION, sym%invs) + hybrid%l_addhf = .TRUE. + + !In first iteration allocate some memory + IF (init_vex) THEN + ALLOCATE (hybrid%ne_eig(kpts%nkpt), hybrid%nbands(kpts%nkpt), hybrid%nobd(kpts%nkptf)) + ALLOCATE (hybrid%nbasm(kpts%nkptf)) + ALLOCATE (hybrid%div_vv(DIMENSION%neigd, kpts%nkpt, input%jspins)) + init_vex = .FALSE. + END IF + + hybrid%l_subvxc = (hybrid%l_subvxc .AND. hybrid%l_addhf) + IF (.NOT. ALLOCATED(results%w_iks)) ALLOCATE (results%w_iks(DIMENSION%neigd2, kpts%nkpt, input%jspins)) + + IF (hybrid%l_calhf) THEN + iterHF = iterHF + 1 + + !Delete broyd files + CALL system("rm -f broyd*") + + !check if z-reflection trick can be used + + l_zref = (sym%zrfs .AND. (SUM(ABS(kpts%bk(3, :kpts%nkpt))) < 1e-9) .AND. .NOT. noco%l_noco) + + CALL timestart("Preparation for Hybrid functionals") + ! CALL juDFT_WARN ("Hybrid functionals not working in this version") + + !construct the mixed-basis + CALL timestart("generation of mixed basis") + CALL mixedbasis(atoms, kpts, dimension, input, cell, sym, xcpot, hybrid, enpara, mpi, v, l_restart) + CALL timestop("generation of mixed basis") + + CALL open_hybrid_io2(hybrid, DIMENSION, atoms, sym%invs) + + CALL coulombmatrix(mpi, atoms, kpts, cell, sym, hybrid, xcpot, l_restart) + + CALL hf_init(hybrid, kpts, atoms, input, DIMENSION, hybdat, sym%invs) + CALL timestop("Preparation for Hybrid functionals") + CALL timestart("Calculation of non-local HF potential") + DO jsp = 1, input%jspins + call timestart("HF_setup") + CALL HF_setup(hybrid, input, sym, kpts, dimension, atoms, mpi, noco, cell, oneD, results, jsp, enpara, eig_id, & + hybdat, iterHF, sym%invs, v%mt(:, 0, :, :), eig_irr) + call timestop("HF_setup") + + DO nk = 1, kpts%nkpt + !DO nk = mpi%n_start,kpts%nkpt,mpi%n_stride + CALL lapw%init(input, noco, kpts, atoms, sym, nk, cell, l_zref) + CALL hsfock(nk, atoms, hybrid, lapw, DIMENSION, kpts, jsp, input, hybdat, eig_irr, sym, cell, & + noco, results, iterHF, MAXVAL(hybrid%nobd), xcpot, mpi) + END DO + END DO + CALL timestop("Calculation of non-local HF potential") + CALL close_eig(eig_id) + + ENDIF + CALL timestop("Hybrid code") + END SUBROUTINE calc_hybrid END MODULE m_calc_hybrid diff --git a/hybrid/kp_perturbation.F90 b/hybrid/kp_perturbation.F90 index 24fc61a84750f80d1122feda5803fb78bb2b3f30..2168daf545b10bef7fbc0c604a390d42d3a36b55 100644 --- a/hybrid/kp_perturbation.F90 +++ b/hybrid/kp_perturbation.F90 @@ -1,710 +1,687 @@ - MODULE m_kp_perturbation +MODULE m_kp_perturbation CONTAINS - SUBROUTINE ibs_correction(& - nk,atoms,& - dimension,input,jsp,& - hybdat,hybrid,& - lapw,kpts,nkpti,& - cell,mnobd,& - sym,& - proj_ibsc,olap_ibsc) - - USE m_sphbes - USE m_dsphbs - USE m_constants - USE m_ylm - USE m_gaunt - USE m_util - USE m_types - USE m_io_hybrid - IMPLICIT NONE - - TYPE(t_hybdat),INTENT(IN) :: hybdat - TYPE(t_dimension),INTENT(IN) :: dimension - TYPE(t_hybrid),INTENT(INOUT) :: hybrid - TYPE(t_input),INTENT(IN) :: input - TYPE(t_sym),INTENT(IN) :: sym - TYPE(t_cell),INTENT(IN) :: cell - TYPE(t_kpts),INTENT(IN) :: kpts - TYPE(t_atoms),INTENT(IN) :: atoms - TYPE(t_lapw),INTENT(IN) :: lapw - - ! - scalars - - INTEGER, INTENT(IN) :: jsp - INTEGER, INTENT(IN) :: mnobd - INTEGER, INTENT(IN) :: nk ,nkpti - - - + SUBROUTINE ibs_correction( & + nk, atoms, & + dimension, input, jsp, & + hybdat, hybrid, & + lapw, kpts, nkpti, & + cell, mnobd, & + sym, & + proj_ibsc, olap_ibsc) + + USE m_sphbes + USE m_dsphbs + USE m_constants + USE m_ylm + USE m_gaunt + USE m_util + USE m_types + USE m_io_hybrid + IMPLICIT NONE + + TYPE(t_hybdat), INTENT(IN) :: hybdat + TYPE(t_dimension), INTENT(IN) :: dimension + TYPE(t_hybrid), INTENT(INOUT) :: hybrid + TYPE(t_input), INTENT(IN) :: input + TYPE(t_sym), INTENT(IN) :: sym + TYPE(t_cell), INTENT(IN) :: cell + TYPE(t_kpts), INTENT(IN) :: kpts + TYPE(t_atoms), INTENT(IN) :: atoms + TYPE(t_lapw), INTENT(IN) :: lapw + + ! - scalars - + INTEGER, INTENT(IN) :: jsp + INTEGER, INTENT(IN) :: mnobd + INTEGER, INTENT(IN) :: nk, nkpti + ! REAL , INTENT(INOUT):: ibs_corr(3,3,nbands) - - ! - arrays - - - - - COMPLEX, INTENT(INOUT):: olap_ibsc(3,3,mnobd,mnobd) - COMPLEX, INTENT(INOUT):: proj_ibsc(:,:,:)!(3,mnobd,hybrid%nbands(nk)) - ! - local scalars - - INTEGER :: i,itype,ieq,iatom,iatom1 ,iband,iband1 - INTEGER :: iband2,ilo,ibas,ic,ikpt,ikvec,invsfct - INTEGER :: irecl_cmt,irecl_z - INTEGER :: j,m - INTEGER :: l1,m1,p1,l2,m2,p2,l ,p,lm,& - lmp,lmp1,lmp2,lm1,lm2 - INTEGER :: ok,ig - INTEGER :: idum - REAL :: const - REAL :: ka,kb - REAL :: kvecn - REAL :: olap_udot,olap_uulo,olap_udotulo - REAL :: rdum - REAL :: ws - COMPLEX :: phase - COMPLEX :: cj,cdj - COMPLEX :: denom,enum - COMPLEX :: cdum,cdum1,cdum2 - COMPLEX, PARAMETER :: img = (0.0,1.0) - ! - local arrays - - INTEGER :: lmp_start(atoms%ntype) - REAL :: alo(atoms%nlod,atoms%ntype),blo(atoms%nlod,atoms%ntype),& - clo(atoms%nlod,atoms%ntype) - REAL :: u1_lo(atoms%jmtd,atoms%nlod,atoms%ntype),& - u2_lo(atoms%jmtd,atoms%nlod,atoms%ntype) - REAL :: kvec(3),qvec(3) - REAL :: sbes(0:atoms%lmaxd+1),dsbes(0:atoms%lmaxd+1) - REAL :: bas1_tmp(atoms%jmtd,hybrid%maxindx,0:atoms%lmaxd+1,atoms%ntype),& - bas2_tmp(atoms%jmtd,hybrid%maxindx,0:atoms%lmaxd+1,atoms%ntype) - REAL :: bas1_MT_tmp(hybrid%maxindx,0:atoms%lmaxd+1,atoms%ntype),& - drbas1_MT_tmp(hybrid%maxindx,0:atoms%lmaxd+1,atoms%ntype) - REAL :: ru1(atoms%jmtd,3,mnobd),ru2(atoms%jmtd,3,mnobd) - REAL :: iu1(atoms%jmtd,3,mnobd),iu2(atoms%jmtd,3,mnobd) - REAL :: rintegrand(atoms%jmtd),iintegrand(atoms%jmtd),& - integrand(atoms%jmtd) - - COMPLEX :: f(atoms%jmtd,mnobd) - COMPLEX :: carr(3),carr2(3,hybrid%nbands(nk)) - COMPLEX :: ylm( (atoms%lmaxd+2)**2 ) - COMPLEX,ALLOCATABLE :: u1(:,:,:,:,:),u2(:,:,:,:,:) - COMPLEX,ALLOCATABLE :: cmt_lo(:,:,:,:) - COMPLEX,ALLOCATABLE :: cmt_apw(:,:,:) - TYPE(t_mat) :: z - REAL :: work_r(dimension%neigd) - COMPLEX :: work_c(dimension%neigd) - - - !CALL intgrf_init(atoms%ntype,atoms%jmtd,atoms%jri,atoms%dx,atoms%rmsh,hybdat%gridf) - - - - bas1_tmp(:,:,0:atoms%lmaxd,:) = hybdat%bas1(:,:,0:atoms%lmaxd,:) - bas2_tmp(:,:,0:atoms%lmaxd,:) = hybdat%bas2(:,:,0:atoms%lmaxd,:) - - bas1_MT_tmp(:,0:atoms%lmaxd,:) = hybdat%bas1_MT(:,0:atoms%lmaxd,:) - drbas1_MT_tmp(:,0:atoms%lmaxd,:) = hybdat%drbas1_MT(:,0:atoms%lmaxd,:) - - bas1_tmp(:,:,atoms%lmaxd+1,:) = hybdat%bas1(:,:,atoms%lmaxd,:) - bas2_tmp(:,:,atoms%lmaxd+1,:) = hybdat%bas2(:,:,atoms%lmaxd,:) - - bas1_MT_tmp(:,atoms%lmaxd+1,:) = hybdat%bas1_MT(:,atoms%lmaxd,:) - drbas1_MT_tmp(:,atoms%lmaxd+1,:) = hybdat%drbas1_MT(:,atoms%lmaxd,:) - - - - ! read in z coefficient from direct access file z at k-point nk - - call read_z(z,nk) - - ! construct local orbital consisting of radial function times spherical harmonic - ! where the radial function vanishes on the MT sphere boundary - ! with this the local orbitals have a trivial k-dependence - - ! compute radial lo matching coefficients - hybrid%nindx = 2 - DO itype = 1,atoms%ntype - DO ilo = 1,atoms%nlo(itype) - l = atoms%llo(ilo,itype) - hybrid%nindx(l,itype) = hybrid%nindx(l,itype) + 1 - p = hybrid%nindx(l,itype) - - ws = -wronskian(hybdat%bas1_MT(1,l,itype),hybdat%drbas1_MT(1,l,itype), hybdat%bas1_MT(2,l,itype),hybdat%drbas1_MT(2,l,itype) ) - - ka = 1.0/ws*wronskian(hybdat%bas1_MT(p,l,itype),hybdat%drbas1_MT(p,l,itype), hybdat%bas1_MT(2,l,itype),hybdat%drbas1_MT(2,l,itype)) - - kb = 1.0/ws*wronskian(hybdat%bas1_MT(1,l,itype),hybdat%drbas1_MT(1,l,itype), hybdat%bas1_MT(p,l,itype),hybdat%drbas1_MT(p,l,itype)) - - integrand = hybdat%bas1(:,2,l,itype)*hybdat%bas1(:,2,l,itype) + hybdat%bas2(:,2,l,itype)*hybdat%bas2(:,2,l,itype) - olap_udot = intgrf(integrand,atoms%jri,atoms%jmtd,atoms%rmsh,atoms%dx,atoms%ntype,itype, hybdat%gridf) - - integrand = hybdat%bas1(:,1,l,itype)*hybdat%bas1(:,p,l,itype) + hybdat%bas2(:,1,l,itype)*hybdat%bas2(:,p,l,itype) - olap_uulo = intgrf(integrand,atoms%jri,atoms%jmtd,atoms%rmsh,atoms%dx,atoms%ntype,itype, hybdat%gridf) - - integrand = hybdat%bas1(:,2,l,itype)*hybdat%bas1(:,p,l,itype) + hybdat%bas2(:,2,l,itype)*hybdat%bas2(:,p,l,itype) - olap_udotulo = intgrf(integrand,atoms%jri,atoms%jmtd,atoms%rmsh,atoms%dx,atoms%ntype,itype, hybdat%gridf) - - rdum = ka**2 + (kb**2)*olap_udot + 1.0 + 2.0*ka*olap_uulo + 2.0*kb*olap_udotulo - clo(ilo,itype) = 1.0/sqrt( rdum ) - alo(ilo,itype) = ka*clo(ilo,itype) - blo(ilo,itype) = kb*clo(ilo,itype) - - u1_lo(:,ilo,itype) = alo(ilo,itype)*hybdat%bas1(:,1,l,itype) + blo(ilo,itype)*hybdat%bas1(:,2,l,itype) + clo(ilo,itype)*hybdat%bas1(:,p,l,itype) - - u2_lo(:,ilo,itype) = alo(ilo,itype)*hybdat%bas2(:,1,l,itype) + blo(ilo,itype)*hybdat%bas2(:,2,l,itype) + clo(ilo,itype)*hybdat%bas2(:,p,l,itype) - END DO - END DO - - - - ! calculate lo wavefunction coefficients - ALLOCATE( cmt_lo(dimension%neigd,-atoms%llod:atoms%llod,atoms%nlod,atoms%nat) ) - cmt_lo = 0 - iatom = 0 - ic = 0 - ibas = lapw%nv(jsp) - DO itype = 1,atoms%ntype - ! the program is in hartree units, therefore 1/wronskian is - ! (rmt**2)/2. - const = fpi_const*(atoms%rmt(itype)**2)/2/sqrt(cell%omtil) - DO ieq = 1,atoms%neq(itype) - iatom = iatom + 1 - IF( (atoms%invsat(iatom).eq.0) .or. (atoms%invsat(iatom) .eq. 1) ) THEN - IF( atoms%invsat(iatom) .eq. 0 ) invsfct = 1 - IF( atoms%invsat(iatom) .eq. 1 ) THEN - invsfct = 2 - iatom1 = sym%invsatnr(iatom) - END IF - - DO ilo = 1,atoms%nlo(itype) - l = atoms%llo(ilo,itype) - cdum = img**l*const - DO ikvec = 1,invsfct*(2*l+1) - ic = ic + 1 - ibas = ibas + 1 - kvec = kpts%bk(:,nk) +(/ lapw%k1(hybdat%kveclo_eig(ic,nk),jsp), lapw%k2(hybdat%kveclo_eig(ic,nk),jsp), lapw%k3(hybdat%kveclo_eig(ic,nk),jsp)/) - - phase=exp(img*tpi_const*dot_product(atoms%taual(:,iatom),kvec)) - cdum1 = cdum*phase - - CALL ylm4(l,matmul(kvec,cell%bmat),ylm) - - lm = l**2 - DO M = -l,l - lm = lm + 1 - cdum2 = cdum1*conjg(ylm(lm)) - if (z%l_real) THEN - work_r = z%data_r(ibas,:) - DO iband = 1,hybrid%nbands(nk) - cmt_lo(iband,M,ilo,iatom ) = cmt_lo(iband,M,ilo,iatom) + cdum2*work_r(iband) - IF( invsfct .eq. 2 ) THEN - ! the factor (-1)**l is necessary as we do not calculate - ! the cmt_lo in the local coordinate system of the atom - cmt_lo(iband,-M,ilo,iatom1) = cmt_lo(iband,-M,ilo,iatom1) + (-1)**(l+M)*conjg(cdum2)*work_r(iband) - END IF - END DO - else - work_c = z%data_c(ibas,:) - DO iband = 1,hybrid%nbands(nk) - cmt_lo(iband,M,ilo,iatom ) = cmt_lo(iband,M,ilo,iatom) + cdum2*work_c(iband) - IF( invsfct .eq. 2 ) THEN - ! the factor (-1)**l is necessary as we do not calculate - ! the cmt_lo in the local coordinate system of the atom - cmt_lo(iband,-M,ilo,iatom1) = cmt_lo(iband,-M,ilo,iatom1) + (-1)**(l+M)*conjg(cdum2)*work_c(iband) - END IF - END DO - end if - - END DO - - END DO !ikvec - END DO ! ilo - - END IF - - END DO !ieq - END DO !itype - - - - ! - ! calculate apw wavefunction coefficients up to lmax + 1 - ! note that the lo contribution is separated in cmt_lo - ! - - DO itype = 1,atoms%ntype - lmp_start(itype) = sum( (/ (2*(2*l+1), l=0,atoms%lmax(itype)+1) /) ) - END DO - idum = maxval(lmp_start) - - - ALLOCATE( cmt_apw(dimension%neigd,idum,atoms%nat) ) - cmt_apw = 0 - DO i = 1,lapw%nv(jsp) - kvec = kpts%bk(:,nk) + (/ lapw%k1(i,jsp),lapw%k2(i,jsp),lapw%k3(i,jsp) /) - kvecn = sqrt(dot_product(matmul(kvec,cell%bmat),matmul(kvec,cell%bmat))) - - iatom = 0 - DO itype = 1,atoms%ntype - !calculate spherical sperical harmonics - CALL ylm4(atoms%lmax(itype)+1,matmul(kvec,cell%bmat),ylm) - - !calculate spherical bessel function at |kvec|*R_MT(itype) - CALL sphbes(atoms%lmax(itype)+1,kvecn*atoms%rmt(itype),sbes) - - !calculate radial derivative of spherical bessel function at |kvec|*R_MT(itype) - CALL dsphbs(atoms%lmax(itype)+1,kvecn*atoms%rmt(itype),sbes,dsbes) - dsbes = kvecn*dsbes - - DO ieq = 1,atoms%neq(itype) - iatom = iatom + 1 - - phase = exp(img*tpi_const*dot_product(kvec,atoms%taual(:,iatom))) - - lm = 0 - lmp = 0 - DO l = 0,atoms%lmax(itype)+1 - denom = wronskian( bas1_MT_tmp(2,l,itype), drbas1_MT_tmp(2,l,itype),& - bas1_MT_tmp(1,l,itype), drbas1_MT_tmp(1,l,itype) ) - cdum1 = fpi_const*img**l* sbes(l) *phase /sqrt(cell%omtil) - cdum2 = fpi_const*img**l* dsbes(l) *phase /sqrt(cell%omtil) - DO M = -l,l - lm = lm + 1 - cj = cdum1 *conjg( ylm(lm) ) - cdj = cdum2 *conjg( ylm(lm) ) - DO p = 1,2 - lmp = lmp + 1 - p1 = p + (-1)**(p-1) - - enum = CMPLX(wronskian( bas1_MT_tmp(p1,l,itype), drbas1_MT_tmp(p1,l,itype), REAL(cj),REAL(cdj)),& - wronskian( bas1_MT_tmp(p1,l,itype), drbas1_MT_tmp(p1,l,itype), AIMAG(cj),AIMAG(cdj))) - - cdum = (-1)**(p+1)*enum/denom - if (z%l_real) THEN - work_r = z%data_r(i,:) - DO iband = 1,hybrid%nbands(nk) - cmt_apw(iband,lmp,iatom) = cmt_apw(iband,lmp,iatom) + cdum*work_r(iband) - END DO - else - work_c = z%data_c(i,:) - DO iband = 1,hybrid%nbands(nk) - cmt_apw(iband,lmp,iatom) = cmt_apw(iband,lmp,iatom) + cdum*work_c(iband) - END DO - end if - END DO !p - END DO !M - END DO !l - - END DO !iatom - END DO ! itype - END DO ! i - - - - - ! construct radial functions (complex) for the first order - ! incomplete basis set correction - - ALLOCATE( u1(atoms%jmtd,3,mnobd,(atoms%lmaxd+1)**2,atoms%nat),stat=ok )!hybrid%nbands - IF( ok .ne. 0 ) STOP 'kp_perturbation: failure allocation u1' - ALLOCATE( u2(atoms%jmtd,3,mnobd,(atoms%lmaxd+1)**2,atoms%nat),stat=ok )!hybrid%nbands - IF( ok .ne. 0 ) STOP 'kp_perturbation: failure allocation u2' - u1 = 0; u2 = 0 - - iatom = 0 - DO itype = 1,atoms%ntype - DO ieq = 1,atoms%neq(itype) - iatom = iatom + 1 - - lm1 = 0 - DO l1 = 0,atoms%lmax(itype)! + 1 - DO m1 = -l1,l1 - lm1 = lm1 + 1 - - DO p1 = 1,2 - - carr2 = 0 - l2 = l1 + 1 - lmp2 = 2*l2**2 + p1 - DO m2 = -l2,l2 - carr = gauntvec(l1,m1,l2,m2,atoms) - DO iband = 1,mnobd! hybrid%nbands - carr2(1:3,iband) = carr2(1:3,iband) + carr*cmt_apw(iband,lmp2,iatom) - END DO - lmp2 = lmp2 + 2 - END DO - - DO iband = 1,mnobd! hybrid%nbands - DO i = 1,3 - DO ig = 1,atoms%jri(itype) - ! the r factor is already included in bas1 - u1(ig,i,iband,lm1,iatom)= u1(ig,i,iband,lm1,iatom) - img*bas1_tmp(ig,p1,l2,itype)*carr2(i,iband) - u2(ig,i,iband,lm1,iatom)= u2(ig,i,iband,lm1,iatom) - img*bas2_tmp(ig,p1,l2,itype)*carr2(i,iband) - END DO - END DO - END DO - - l2 = l1-1 - IF( l2 .ge. 0 ) THEN - carr2 = 0 - lmp2 = 2*l2**2 + p1 - DO m2 = -l2,l2 - carr = gauntvec(l1,m1,l2,m2,atoms) - DO iband = 1,mnobd! hybrid%nbands - carr2(1:3,iband) = carr2(1:3,iband) + carr*cmt_apw(iband,lmp2,iatom) - END DO - lmp2 = lmp2 + 2 - END DO - - DO iband = 1,mnobd! hybrid%nbands - DO i = 1,3 - DO ig = 1,atoms%jri(itype) - ! the r factor is already included in bas1 - u1(ig,i,iband,lm1,iatom) = u1(ig,i,iband,lm1,iatom) - img*bas1_tmp(ig,p1,l2,itype)*carr2(i,iband) - u2(ig,i,iband,lm1,iatom) = u2(ig,i,iband,lm1,iatom) - img*bas2_tmp(ig,p1,l2,itype)*carr2(i,iband) - END DO - END DO - END DO - - END IF - - carr2 = 0 - l2 = l1 + 1 - lmp2 = 2*l2**2 - DO m2 = -l2,l2 - carr = gauntvec(l1,m1,l2,m2,atoms) - DO p2 = 1,2 - lmp2 = lmp2 + 1 - rdum = w(p1,l1,p2,l2,itype,bas1_MT_tmp, drbas1_MT_tmp,atoms%rmt) - DO iband = 1,mnobd! hybrid%nbands - carr2(1:3,iband) = carr2(1:3,iband) + img*carr*rdum*cmt_apw(iband,lmp2,iatom) - END DO - END DO - END DO - - DO iband = 1,mnobd! hybrid%nbands - DO i = 1,3 - DO ig = 1,atoms%jri(itype) - u1(ig,i,iband,lm1,iatom)= u1(ig,i,iband,lm1,iatom) + bas1_tmp(ig,p1,l1,itype) * carr2(i,iband)/atoms%rmsh(ig,itype) - u2(ig,i,iband,lm1,iatom)= u2(ig,i,iband,lm1,iatom) + bas2_tmp(ig,p1,l1,itype) * carr2(i,iband)/atoms%rmsh(ig,itype) - END DO - END DO - END DO - - l2 = l1 - 1 - IF( l2 .ge. 0 ) THEN - carr2 = 0 - lmp2 = 2*l2**2 - DO m2 = -l2,l2 - carr = gauntvec(l1,m1,l2,m2,atoms) - DO p2 = 1,2 - lmp2 = lmp2 + 1 - rdum = w(p1,l1,p2,l2,itype,bas1_MT_tmp, drbas1_MT_tmp,atoms%rmt) - DO iband = 1,mnobd! hybrid%nbands - carr2(1:3,iband) = carr2(1:3,iband) + img*carr*rdum*cmt_apw(iband,lmp2,iatom) - END DO - END DO - END DO - - DO iband = 1,mnobd! hybrid%nbands - DO i = 1,3 - DO ig = 1,atoms%jri(itype) - u1(ig,i,iband,lm1,iatom) = u1(ig,i,iband,lm1,iatom) & - + bas1_tmp(ig,p1,l1,itype) * carr2(i,iband)/atoms%rmsh(ig,itype) - u2(ig,i,iband,lm1,iatom) = u2(ig,i,iband,lm1,iatom) & - + bas2_tmp(ig,p1,l1,itype) * carr2(i,iband)/atoms%rmsh(ig,itype) - END DO - END DO - END DO - END IF - - END DO ! p1 - END DO !m1 - END DO !l1 - END DO !ieq - END DO !iatom - - ! construct lo contribtution - IF( any(atoms%llo .eq. atoms%lmaxd ) ) STOP 'ibs_correction: atoms%llo=atoms%lmaxd is not implemented' - - iatom = 0 - DO itype = 1,atoms%ntype - DO ieq = 1,atoms%neq(itype) - hybrid%nindx = 2 - iatom = iatom + 1 - DO ilo = 1,atoms%nlo(itype) - l1 = atoms%llo(ilo,itype) - hybrid%nindx(l1,itype) = hybrid%nindx(l1,itype) + 1 - p1 = hybrid%nindx(l1,itype) - - l2 = l1 + 1 - lm2 = l2**2 - DO m2 = -l2,l2 - lm2 = lm2 + 1 - carr2 = 0 - - DO m1 = -l1,l1 - carr = gauntvec(l2,m2,l1,m1,atoms) - DO iband = 1,mnobd - carr2(1:3,iband) = carr2(1:3,iband) + cmt_lo(iband,m1,ilo,iatom)*carr - END DO - END DO - - DO iband = 1,mnobd - DO i = 1,3 - DO ig = 1,atoms%jri(itype) - ! the r factor is already included in - u1(ig,i,iband,lm2,iatom) = u1(ig,i,iband,lm2,iatom) - img*u1_lo(ig,ilo,itype)*carr2(i,iband) - u2(ig,i,iband,lm2,iatom) = u2(ig,i,iband,lm2,iatom) - img*u2_lo(ig,ilo,itype)*carr2(i,iband) - END DO - END DO - END DO + ! - arrays - + + COMPLEX, INTENT(INOUT):: olap_ibsc(3, 3, mnobd, mnobd) + COMPLEX, INTENT(INOUT):: proj_ibsc(:, :, :)!(3,mnobd,hybrid%nbands(nk)) + ! - local scalars - + INTEGER :: i, itype, ieq, iatom, iatom1, iband, iband1 + INTEGER :: iband2, ilo, ibas, ic, ikpt, ikvec, invsfct + INTEGER :: irecl_cmt, irecl_z + INTEGER :: j, m + INTEGER :: l1, m1, p1, l2, m2, p2, l, p, lm, & + lmp, lmp1, lmp2, lm1, lm2 + INTEGER :: ok, ig + INTEGER :: idum + REAL :: const + REAL :: ka, kb + REAL :: kvecn + REAL :: olap_udot, olap_uulo, olap_udotulo + REAL :: rdum + REAL :: ws + COMPLEX :: phase + COMPLEX :: cj, cdj + COMPLEX :: denom, enum + COMPLEX :: cdum, cdum1, cdum2 + COMPLEX, PARAMETER :: img = (0.0, 1.0) + ! - local arrays - + INTEGER :: lmp_start(atoms%ntype) + REAL :: alo(atoms%nlod, atoms%ntype), blo(atoms%nlod, atoms%ntype), & + clo(atoms%nlod, atoms%ntype) + REAL :: u1_lo(atoms%jmtd, atoms%nlod, atoms%ntype), & + u2_lo(atoms%jmtd, atoms%nlod, atoms%ntype) + REAL :: kvec(3), qvec(3) + REAL :: sbes(0:atoms%lmaxd + 1), dsbes(0:atoms%lmaxd + 1) + REAL :: bas1_tmp(atoms%jmtd, hybrid%maxindx, 0:atoms%lmaxd + 1, atoms%ntype), & + bas2_tmp(atoms%jmtd, hybrid%maxindx, 0:atoms%lmaxd + 1, atoms%ntype) + REAL :: bas1_MT_tmp(hybrid%maxindx, 0:atoms%lmaxd + 1, atoms%ntype), & + drbas1_MT_tmp(hybrid%maxindx, 0:atoms%lmaxd + 1, atoms%ntype) + REAL :: ru1(atoms%jmtd, 3, mnobd), ru2(atoms%jmtd, 3, mnobd) + REAL :: iu1(atoms%jmtd, 3, mnobd), iu2(atoms%jmtd, 3, mnobd) + REAL :: rintegrand(atoms%jmtd), iintegrand(atoms%jmtd), & + integrand(atoms%jmtd) + + COMPLEX :: f(atoms%jmtd, mnobd) + COMPLEX :: carr(3), carr2(3, hybrid%nbands(nk)) + COMPLEX :: ylm((atoms%lmaxd + 2)**2) + COMPLEX, ALLOCATABLE :: u1(:, :, :, :, :), u2(:, :, :, :, :) + COMPLEX, ALLOCATABLE :: cmt_lo(:, :, :, :) + COMPLEX, ALLOCATABLE :: cmt_apw(:, :, :) + TYPE(t_mat) :: z + REAL :: work_r(dimension%neigd) + COMPLEX :: work_c(dimension%neigd) + + !CALL intgrf_init(atoms%ntype,atoms%jmtd,atoms%jri,atoms%dx,atoms%rmsh,hybdat%gridf) + + bas1_tmp(:, :, 0:atoms%lmaxd, :) = hybdat%bas1(:, :, 0:atoms%lmaxd, :) + bas2_tmp(:, :, 0:atoms%lmaxd, :) = hybdat%bas2(:, :, 0:atoms%lmaxd, :) + + bas1_MT_tmp(:, 0:atoms%lmaxd, :) = hybdat%bas1_MT(:, 0:atoms%lmaxd, :) + drbas1_MT_tmp(:, 0:atoms%lmaxd, :) = hybdat%drbas1_MT(:, 0:atoms%lmaxd, :) + + bas1_tmp(:, :, atoms%lmaxd + 1, :) = hybdat%bas1(:, :, atoms%lmaxd, :) + bas2_tmp(:, :, atoms%lmaxd + 1, :) = hybdat%bas2(:, :, atoms%lmaxd, :) + + bas1_MT_tmp(:, atoms%lmaxd + 1, :) = hybdat%bas1_MT(:, atoms%lmaxd, :) + drbas1_MT_tmp(:, atoms%lmaxd + 1, :) = hybdat%drbas1_MT(:, atoms%lmaxd, :) + + ! read in z coefficient from direct access file z at k-point nk + + call read_z(z, nk) + + ! construct local orbital consisting of radial function times spherical harmonic + ! where the radial function vanishes on the MT sphere boundary + ! with this the local orbitals have a trivial k-dependence + + ! compute radial lo matching coefficients + hybrid%nindx = 2 + DO itype = 1, atoms%ntype + DO ilo = 1, atoms%nlo(itype) + l = atoms%llo(ilo, itype) + hybrid%nindx(l, itype) = hybrid%nindx(l, itype) + 1 + p = hybrid%nindx(l, itype) + + ws = -wronskian(hybdat%bas1_MT(1, l, itype), hybdat%drbas1_MT(1, l, itype), hybdat%bas1_MT(2, l, itype), hybdat%drbas1_MT(2, l, itype)) + + ka = 1.0/ws*wronskian(hybdat%bas1_MT(p, l, itype), hybdat%drbas1_MT(p, l, itype), hybdat%bas1_MT(2, l, itype), hybdat%drbas1_MT(2, l, itype)) + + kb = 1.0/ws*wronskian(hybdat%bas1_MT(1, l, itype), hybdat%drbas1_MT(1, l, itype), hybdat%bas1_MT(p, l, itype), hybdat%drbas1_MT(p, l, itype)) + + integrand = hybdat%bas1(:, 2, l, itype)*hybdat%bas1(:, 2, l, itype) + hybdat%bas2(:, 2, l, itype)*hybdat%bas2(:, 2, l, itype) + olap_udot = intgrf(integrand, atoms%jri, atoms%jmtd, atoms%rmsh, atoms%dx, atoms%ntype, itype, hybdat%gridf) + + integrand = hybdat%bas1(:, 1, l, itype)*hybdat%bas1(:, p, l, itype) + hybdat%bas2(:, 1, l, itype)*hybdat%bas2(:, p, l, itype) + olap_uulo = intgrf(integrand, atoms%jri, atoms%jmtd, atoms%rmsh, atoms%dx, atoms%ntype, itype, hybdat%gridf) + + integrand = hybdat%bas1(:, 2, l, itype)*hybdat%bas1(:, p, l, itype) + hybdat%bas2(:, 2, l, itype)*hybdat%bas2(:, p, l, itype) + olap_udotulo = intgrf(integrand, atoms%jri, atoms%jmtd, atoms%rmsh, atoms%dx, atoms%ntype, itype, hybdat%gridf) + + rdum = ka**2 + (kb**2)*olap_udot + 1.0 + 2.0*ka*olap_uulo + 2.0*kb*olap_udotulo + clo(ilo, itype) = 1.0/sqrt(rdum) + alo(ilo, itype) = ka*clo(ilo, itype) + blo(ilo, itype) = kb*clo(ilo, itype) + + u1_lo(:, ilo, itype) = alo(ilo, itype)*hybdat%bas1(:, 1, l, itype) + blo(ilo, itype)*hybdat%bas1(:, 2, l, itype) + clo(ilo, itype)*hybdat%bas1(:, p, l, itype) + + u2_lo(:, ilo, itype) = alo(ilo, itype)*hybdat%bas2(:, 1, l, itype) + blo(ilo, itype)*hybdat%bas2(:, 2, l, itype) + clo(ilo, itype)*hybdat%bas2(:, p, l, itype) + END DO END DO - - l2 = l1 - 1 - IF( l2 .ge. 0 ) THEN - lm2 = l2**2 - DO m2 = -l2,l2 - lm2 = lm2 + 1 - carr2 = 0 - - DO m1 = -l1,l1 - carr = gauntvec(l2,m2,l1,m1,atoms) - DO iband = 1,mnobd - carr2(1:3,iband) = carr2(1:3,iband) + cmt_lo(iband,m1,ilo,iatom)*carr - END DO - END DO - - DO iband = 1,mnobd - DO i = 1,3 - DO ig = 1,atoms%jri(itype) - ! the r factor is already included in - u1(ig,i,iband,lm2,iatom)= u1(ig,i,iband,lm2,iatom) - img*u1_lo(ig,ilo,itype)*carr2(i,iband) - u2(ig,i,iband,lm2,iatom)= u2(ig,i,iband,lm2,iatom) - img*u2_lo(ig,ilo,itype)*carr2(i,iband) - END DO - END DO - END DO - - END DO - END IF - - END DO - END DO - END DO - - - - ! - ! calculate projection < phi(n',k)|phi^1(n,k)> - ! n' = iband1 , n= iband2 - ! - iatom = 0 - proj_ibsc = 0 - DO itype = 1,atoms%ntype - DO ieq = 1,atoms%neq(itype) - iatom = iatom + 1 - lm = 0 - lmp = 0 - DO l = 0,atoms%lmax(itype) - DO M = -l,l - lm = lm + 1 - ru1 = real( u1(:,:,:,lm,iatom) ) - iu1 = aimag( u1(:,:,:,lm,iatom) ) - ru2 = real( u2(:,:,:,lm,iatom) ) - iu2 = aimag( u2(:,:,:,lm,iatom) ) - DO p = 1,2 - lmp = lmp + 1 - - DO iband = 1,mnobd! hybrid%nbands - DO i = 1,3 - - rintegrand = atoms%rmsh(:,itype)*(hybdat%bas1(:,p,l,itype)*ru1(:,i,iband) +hybdat%bas2(:,p,l,itype)*ru2(:,i,iband)) - - iintegrand = atoms%rmsh(:,itype)*(hybdat%bas1(:,p,l,itype)*iu1(:,i,iband) +hybdat%bas2(:,p,l,itype)*iu2(:,i,iband)) - - carr2(i,iband)= intgrf(rintegrand,atoms%jri,atoms%jmtd,atoms%rmsh, atoms%dx,atoms%ntype,itype,hybdat%gridf)& - + img*intgrf(iintegrand,atoms%jri,atoms%jmtd,atoms%rmsh, atoms%dx,atoms%ntype,itype,hybdat%gridf) - + + ! calculate lo wavefunction coefficients + ALLOCATE (cmt_lo(dimension%neigd, -atoms%llod:atoms%llod, atoms%nlod, atoms%nat)) + cmt_lo = 0 + iatom = 0 + ic = 0 + ibas = lapw%nv(jsp) + DO itype = 1, atoms%ntype + ! the program is in hartree units, therefore 1/wronskian is + ! (rmt**2)/2. + const = fpi_const*(atoms%rmt(itype)**2)/2/sqrt(cell%omtil) + DO ieq = 1, atoms%neq(itype) + iatom = iatom + 1 + IF ((atoms%invsat(iatom) == 0) .or. (atoms%invsat(iatom) == 1)) THEN + IF (atoms%invsat(iatom) == 0) invsfct = 1 + IF (atoms%invsat(iatom) == 1) THEN + invsfct = 2 + iatom1 = sym%invsatnr(iatom) + END IF + + DO ilo = 1, atoms%nlo(itype) + l = atoms%llo(ilo, itype) + cdum = img**l*const + DO ikvec = 1, invsfct*(2*l + 1) + ic = ic + 1 + ibas = ibas + 1 + kvec = kpts%bk(:, nk) + (/lapw%k1(hybdat%kveclo_eig(ic, nk), jsp), lapw%k2(hybdat%kveclo_eig(ic, nk), jsp), lapw%k3(hybdat%kveclo_eig(ic, nk), jsp)/) + + phase = exp(img*tpi_const*dot_product(atoms%taual(:, iatom), kvec)) + cdum1 = cdum*phase + + CALL ylm4(l, matmul(kvec, cell%bmat), ylm) + + lm = l**2 + DO M = -l, l + lm = lm + 1 + cdum2 = cdum1*conjg(ylm(lm)) + if (z%l_real) THEN + work_r = z%data_r(ibas, :) + DO iband = 1, hybrid%nbands(nk) + cmt_lo(iband, M, ilo, iatom) = cmt_lo(iband, M, ilo, iatom) + cdum2*work_r(iband) + IF (invsfct == 2) THEN + ! the factor (-1)**l is necessary as we do not calculate + ! the cmt_lo in the local coordinate system of the atom + cmt_lo(iband, -M, ilo, iatom1) = cmt_lo(iband, -M, ilo, iatom1) + (-1)**(l + M)*conjg(cdum2)*work_r(iband) + END IF + END DO + else + work_c = z%data_c(ibas, :) + DO iband = 1, hybrid%nbands(nk) + cmt_lo(iband, M, ilo, iatom) = cmt_lo(iband, M, ilo, iatom) + cdum2*work_c(iband) + IF (invsfct == 2) THEN + ! the factor (-1)**l is necessary as we do not calculate + ! the cmt_lo in the local coordinate system of the atom + cmt_lo(iband, -M, ilo, iatom1) = cmt_lo(iband, -M, ilo, iatom1) + (-1)**(l + M)*conjg(cdum2)*work_c(iband) + END IF + END DO + end if + + END DO + + END DO !ikvec + END DO ! ilo + + END IF + + END DO !ieq + END DO !itype + + ! + ! calculate apw wavefunction coefficients up to lmax + 1 + ! note that the lo contribution is separated in cmt_lo + ! + + DO itype = 1, atoms%ntype + lmp_start(itype) = sum((/(2*(2*l + 1), l=0, atoms%lmax(itype) + 1)/)) + END DO + idum = maxval(lmp_start) + + ALLOCATE (cmt_apw(dimension%neigd, idum, atoms%nat)) + cmt_apw = 0 + DO i = 1, lapw%nv(jsp) + kvec = kpts%bk(:, nk) + (/lapw%k1(i, jsp), lapw%k2(i, jsp), lapw%k3(i, jsp)/) + kvecn = sqrt(dot_product(matmul(kvec, cell%bmat), matmul(kvec, cell%bmat))) + + iatom = 0 + DO itype = 1, atoms%ntype + !calculate spherical sperical harmonics + CALL ylm4(atoms%lmax(itype) + 1, matmul(kvec, cell%bmat), ylm) + + !calculate spherical bessel function at |kvec|*R_MT(itype) + CALL sphbes(atoms%lmax(itype) + 1, kvecn*atoms%rmt(itype), sbes) + + !calculate radial derivative of spherical bessel function at |kvec|*R_MT(itype) + CALL dsphbs(atoms%lmax(itype) + 1, kvecn*atoms%rmt(itype), sbes, dsbes) + dsbes = kvecn*dsbes + + DO ieq = 1, atoms%neq(itype) + iatom = iatom + 1 + + phase = exp(img*tpi_const*dot_product(kvec, atoms%taual(:, iatom))) + + lm = 0 + lmp = 0 + DO l = 0, atoms%lmax(itype) + 1 + denom = wronskian(bas1_MT_tmp(2, l, itype), drbas1_MT_tmp(2, l, itype), & + bas1_MT_tmp(1, l, itype), drbas1_MT_tmp(1, l, itype)) + cdum1 = fpi_const*img**l*sbes(l)*phase/sqrt(cell%omtil) + cdum2 = fpi_const*img**l*dsbes(l)*phase/sqrt(cell%omtil) + DO M = -l, l + lm = lm + 1 + cj = cdum1*conjg(ylm(lm)) + cdj = cdum2*conjg(ylm(lm)) + DO p = 1, 2 + lmp = lmp + 1 + p1 = p + (-1)**(p - 1) + + enum = CMPLX(wronskian(bas1_MT_tmp(p1, l, itype), drbas1_MT_tmp(p1, l, itype), REAL(cj), REAL(cdj)), & + wronskian(bas1_MT_tmp(p1, l, itype), drbas1_MT_tmp(p1, l, itype), AIMAG(cj), AIMAG(cdj))) + + cdum = (-1)**(p + 1)*enum/denom + if (z%l_real) THEN + work_r = z%data_r(i, :) + DO iband = 1, hybrid%nbands(nk) + cmt_apw(iband, lmp, iatom) = cmt_apw(iband, lmp, iatom) + cdum*work_r(iband) + END DO + else + work_c = z%data_c(i, :) + DO iband = 1, hybrid%nbands(nk) + cmt_apw(iband, lmp, iatom) = cmt_apw(iband, lmp, iatom) + cdum*work_c(iband) + END DO + end if + END DO !p + END DO !M + END DO !l + + END DO !iatom + END DO ! itype + END DO ! i + + ! construct radial functions (complex) for the first order + ! incomplete basis set correction + + ALLOCATE (u1(atoms%jmtd, 3, mnobd, (atoms%lmaxd + 1)**2, atoms%nat), stat=ok)!hybrid%nbands + IF (ok /= 0) STOP 'kp_perturbation: failure allocation u1' + ALLOCATE (u2(atoms%jmtd, 3, mnobd, (atoms%lmaxd + 1)**2, atoms%nat), stat=ok)!hybrid%nbands + IF (ok /= 0) STOP 'kp_perturbation: failure allocation u2' + u1 = 0; u2 = 0 + + iatom = 0 + DO itype = 1, atoms%ntype + DO ieq = 1, atoms%neq(itype) + iatom = iatom + 1 + + lm1 = 0 + DO l1 = 0, atoms%lmax(itype)! + 1 + DO m1 = -l1, l1 + lm1 = lm1 + 1 + + DO p1 = 1, 2 + + carr2 = 0 + l2 = l1 + 1 + lmp2 = 2*l2**2 + p1 + DO m2 = -l2, l2 + carr = gauntvec(l1, m1, l2, m2, atoms) + DO iband = 1, mnobd! hybrid%nbands + carr2(1:3, iband) = carr2(1:3, iband) + carr*cmt_apw(iband, lmp2, iatom) + END DO + lmp2 = lmp2 + 2 + END DO + + DO iband = 1, mnobd! hybrid%nbands + DO i = 1, 3 + DO ig = 1, atoms%jri(itype) + ! the r factor is already included in bas1 + u1(ig, i, iband, lm1, iatom) = u1(ig, i, iband, lm1, iatom) - img*bas1_tmp(ig, p1, l2, itype)*carr2(i, iband) + u2(ig, i, iband, lm1, iatom) = u2(ig, i, iband, lm1, iatom) - img*bas2_tmp(ig, p1, l2, itype)*carr2(i, iband) + END DO + END DO + END DO + + l2 = l1 - 1 + IF (l2 >= 0) THEN + carr2 = 0 + lmp2 = 2*l2**2 + p1 + DO m2 = -l2, l2 + carr = gauntvec(l1, m1, l2, m2, atoms) + DO iband = 1, mnobd! hybrid%nbands + carr2(1:3, iband) = carr2(1:3, iband) + carr*cmt_apw(iband, lmp2, iatom) + END DO + lmp2 = lmp2 + 2 + END DO + + DO iband = 1, mnobd! hybrid%nbands + DO i = 1, 3 + DO ig = 1, atoms%jri(itype) + ! the r factor is already included in bas1 + u1(ig, i, iband, lm1, iatom) = u1(ig, i, iband, lm1, iatom) - img*bas1_tmp(ig, p1, l2, itype)*carr2(i, iband) + u2(ig, i, iband, lm1, iatom) = u2(ig, i, iband, lm1, iatom) - img*bas2_tmp(ig, p1, l2, itype)*carr2(i, iband) + END DO + END DO + END DO + + END IF + + carr2 = 0 + l2 = l1 + 1 + lmp2 = 2*l2**2 + DO m2 = -l2, l2 + carr = gauntvec(l1, m1, l2, m2, atoms) + DO p2 = 1, 2 + lmp2 = lmp2 + 1 + rdum = w(p1, l1, p2, l2, itype, bas1_MT_tmp, drbas1_MT_tmp, atoms%rmt) + DO iband = 1, mnobd! hybrid%nbands + carr2(1:3, iband) = carr2(1:3, iband) + img*carr*rdum*cmt_apw(iband, lmp2, iatom) + END DO + END DO + END DO + + DO iband = 1, mnobd! hybrid%nbands + DO i = 1, 3 + DO ig = 1, atoms%jri(itype) + u1(ig, i, iband, lm1, iatom) = u1(ig, i, iband, lm1, iatom) + bas1_tmp(ig, p1, l1, itype)*carr2(i, iband)/atoms%rmsh(ig, itype) + u2(ig, i, iband, lm1, iatom) = u2(ig, i, iband, lm1, iatom) + bas2_tmp(ig, p1, l1, itype)*carr2(i, iband)/atoms%rmsh(ig, itype) + END DO + END DO + END DO + + l2 = l1 - 1 + IF (l2 >= 0) THEN + carr2 = 0 + lmp2 = 2*l2**2 + DO m2 = -l2, l2 + carr = gauntvec(l1, m1, l2, m2, atoms) + DO p2 = 1, 2 + lmp2 = lmp2 + 1 + rdum = w(p1, l1, p2, l2, itype, bas1_MT_tmp, drbas1_MT_tmp, atoms%rmt) + DO iband = 1, mnobd! hybrid%nbands + carr2(1:3, iband) = carr2(1:3, iband) + img*carr*rdum*cmt_apw(iband, lmp2, iatom) + END DO + END DO + END DO + + DO iband = 1, mnobd! hybrid%nbands + DO i = 1, 3 + DO ig = 1, atoms%jri(itype) + u1(ig, i, iband, lm1, iatom) = u1(ig, i, iband, lm1, iatom) & + + bas1_tmp(ig, p1, l1, itype)*carr2(i, iband)/atoms%rmsh(ig, itype) + u2(ig, i, iband, lm1, iatom) = u2(ig, i, iband, lm1, iatom) & + + bas2_tmp(ig, p1, l1, itype)*carr2(i, iband)/atoms%rmsh(ig, itype) + END DO + END DO + END DO + END IF + + END DO ! p1 + END DO !m1 + END DO !l1 + END DO !ieq + END DO !iatom + + ! construct lo contribtution + IF (any(atoms%llo == atoms%lmaxd)) STOP 'ibs_correction: atoms%llo=atoms%lmaxd is not implemented' + + iatom = 0 + DO itype = 1, atoms%ntype + DO ieq = 1, atoms%neq(itype) + hybrid%nindx = 2 + iatom = iatom + 1 + DO ilo = 1, atoms%nlo(itype) + l1 = atoms%llo(ilo, itype) + hybrid%nindx(l1, itype) = hybrid%nindx(l1, itype) + 1 + p1 = hybrid%nindx(l1, itype) + + l2 = l1 + 1 + lm2 = l2**2 + DO m2 = -l2, l2 + lm2 = lm2 + 1 + carr2 = 0 + + DO m1 = -l1, l1 + carr = gauntvec(l2, m2, l1, m1, atoms) + DO iband = 1, mnobd + carr2(1:3, iband) = carr2(1:3, iband) + cmt_lo(iband, m1, ilo, iatom)*carr + END DO + END DO + + DO iband = 1, mnobd + DO i = 1, 3 + DO ig = 1, atoms%jri(itype) + ! the r factor is already included in + u1(ig, i, iband, lm2, iatom) = u1(ig, i, iband, lm2, iatom) - img*u1_lo(ig, ilo, itype)*carr2(i, iband) + u2(ig, i, iband, lm2, iatom) = u2(ig, i, iband, lm2, iatom) - img*u2_lo(ig, ilo, itype)*carr2(i, iband) + END DO + END DO + END DO + + END DO + + l2 = l1 - 1 + IF (l2 >= 0) THEN + lm2 = l2**2 + DO m2 = -l2, l2 + lm2 = lm2 + 1 + carr2 = 0 + + DO m1 = -l1, l1 + carr = gauntvec(l2, m2, l1, m1, atoms) + DO iband = 1, mnobd + carr2(1:3, iband) = carr2(1:3, iband) + cmt_lo(iband, m1, ilo, iatom)*carr + END DO + END DO + + DO iband = 1, mnobd + DO i = 1, 3 + DO ig = 1, atoms%jri(itype) + ! the r factor is already included in + u1(ig, i, iband, lm2, iatom) = u1(ig, i, iband, lm2, iatom) - img*u1_lo(ig, ilo, itype)*carr2(i, iband) + u2(ig, i, iband, lm2, iatom) = u2(ig, i, iband, lm2, iatom) - img*u2_lo(ig, ilo, itype)*carr2(i, iband) + END DO + END DO + END DO + + END DO + END IF + END DO - END DO - - DO iband1 = 1,hybrid%nbands(nk) - cdum = conjg(cmt_apw(iband1,lmp,iatom)) - DO iband2 = 1,mnobd! hybrid%nbands - proj_ibsc(1:3,iband2,iband1)= proj_ibsc(1:3,iband2,iband1)+cdum*carr2(1:3,iband2) + END DO + END DO + + ! + ! calculate projection < phi(n',k)|phi^1(n,k)> + ! n' = iband1 , n= iband2 + ! + iatom = 0 + proj_ibsc = 0 + DO itype = 1, atoms%ntype + DO ieq = 1, atoms%neq(itype) + iatom = iatom + 1 + lm = 0 + lmp = 0 + DO l = 0, atoms%lmax(itype) + DO M = -l, l + lm = lm + 1 + ru1 = real(u1(:, :, :, lm, iatom)) + iu1 = aimag(u1(:, :, :, lm, iatom)) + ru2 = real(u2(:, :, :, lm, iatom)) + iu2 = aimag(u2(:, :, :, lm, iatom)) + DO p = 1, 2 + lmp = lmp + 1 + + DO iband = 1, mnobd! hybrid%nbands + DO i = 1, 3 + + rintegrand = atoms%rmsh(:, itype)*(hybdat%bas1(:, p, l, itype)*ru1(:, i, iband) + hybdat%bas2(:, p, l, itype)*ru2(:, i, iband)) + + iintegrand = atoms%rmsh(:, itype)*(hybdat%bas1(:, p, l, itype)*iu1(:, i, iband) + hybdat%bas2(:, p, l, itype)*iu2(:, i, iband)) + + carr2(i, iband) = intgrf(rintegrand, atoms%jri, atoms%jmtd, atoms%rmsh, atoms%dx, atoms%ntype, itype, hybdat%gridf) & + + img*intgrf(iintegrand, atoms%jri, atoms%jmtd, atoms%rmsh, atoms%dx, atoms%ntype, itype, hybdat%gridf) + + END DO + END DO + + DO iband1 = 1, hybrid%nbands(nk) + cdum = conjg(cmt_apw(iband1, lmp, iatom)) + DO iband2 = 1, mnobd! hybrid%nbands + proj_ibsc(1:3, iband2, iband1) = proj_ibsc(1:3, iband2, iband1) + cdum*carr2(1:3, iband2) + END DO + END DO + + END DO!p + END DO!M + END DO!l + + END DO!ieq + END DO!itype + + iatom = 0 + DO itype = 1, atoms%ntype + DO ieq = 1, atoms%neq(itype) + iatom = iatom + 1 + DO ilo = 1, atoms%nlo(itype) + l = atoms%llo(ilo, itype) + lm = l**2 + DO M = -l, l + lm = lm + 1 + ru1 = real(u1(:, :, :, lm, iatom)) + iu1 = aimag(u1(:, :, :, lm, iatom)) + ru2 = real(u2(:, :, :, lm, iatom)) + iu2 = aimag(u2(:, :, :, lm, iatom)) + + DO iband = 1, mnobd! hybrid%nbands + DO i = 1, 3 + + rintegrand = atoms%rmsh(:, itype)*(u1_lo(:, ilo, itype)*ru1(:, i, iband) + u2_lo(:, ilo, itype)*ru2(:, i, iband)) + + iintegrand = atoms%rmsh(:, itype)*(u1_lo(:, ilo, itype)*iu1(:, i, iband) + u2_lo(:, ilo, itype)*iu2(:, i, iband)) + + carr2(i, iband) = intgrf(rintegrand, atoms%jri, atoms%jmtd, atoms%rmsh, atoms%dx, atoms%ntype, itype, hybdat%gridf) & + + img*intgrf(iintegrand, atoms%jri, atoms%jmtd, atoms%rmsh, atoms%dx, atoms%ntype, itype, hybdat%gridf) + + END DO + END DO + + DO iband1 = 1, hybrid%nbands(nk) + cdum = conjg(cmt_lo(iband1, M, ilo, iatom)) + DO iband2 = 1, mnobd! hybrid%nbands + proj_ibsc(1:3, iband2, iband1) = proj_ibsc(1:3, iband2, iband1) + cdum*carr2(1:3, iband2) + END DO + END DO + + END DO + END DO - END DO - - END DO!p - END DO!M - END DO!l - - END DO!ieq - END DO!itype - - iatom = 0 - DO itype = 1,atoms%ntype - DO ieq = 1,atoms%neq(itype) - iatom = iatom + 1 - DO ilo = 1,atoms%nlo(itype) - l = atoms%llo(ilo,itype) - lm = l**2 - DO M = -l,l - lm = lm + 1 - ru1 = real( u1(:,:,:,lm,iatom) ) - iu1 = aimag( u1(:,:,:,lm,iatom) ) - ru2 = real( u2(:,:,:,lm,iatom) ) - iu2 = aimag( u2(:,:,:,lm,iatom) ) - - DO iband = 1,mnobd! hybrid%nbands - DO i = 1,3 - - rintegrand = atoms%rmsh(:,itype)*(u1_lo(:,ilo,itype)*ru1(:,i,iband) +u2_lo(:,ilo,itype)*ru2(:,i,iband) ) - - iintegrand = atoms%rmsh(:,itype)*(u1_lo(:,ilo,itype)*iu1(:,i,iband) +u2_lo(:,ilo,itype)*iu2(:,i,iband) ) - - carr2(i,iband) = intgrf(rintegrand,atoms%jri,atoms%jmtd,atoms%rmsh, atoms%dx,atoms%ntype,itype,hybdat%gridf)& - + img*intgrf(iintegrand,atoms%jri,atoms%jmtd,atoms%rmsh, atoms%dx,atoms%ntype,itype,hybdat%gridf) - - END DO - END DO - - DO iband1 = 1,hybrid%nbands(nk) - cdum = conjg(cmt_lo(iband1,M,ilo,iatom)) - DO iband2 = 1,mnobd! hybrid%nbands - proj_ibsc(1:3,iband2,iband1) = proj_ibsc(1:3,iband2,iband1) + cdum*carr2(1:3,iband2) - END DO - END DO - + END DO END DO - - END DO - END DO - END DO - - ! - ! calculate - ! n1 and n2 occupied - ! - iatom = 0 - olap_ibsc = 0 - DO itype = 1,atoms%ntype - DO ieq = 1,atoms%neq(itype) - iatom = iatom + 1 - lm = 0 - DO l = 0,atoms%lmax(itype)!+1 - DO M = -l,l - lm = lm + 1 - ru1 = real( u1(:,:,:,lm,iatom) ) - iu1 = aimag( u1(:,:,:,lm,iatom) ) - ru2 = real( u2(:,:,:,lm,iatom) ) - iu2 = aimag( u2(:,:,:,lm,iatom) ) - - DO iband1 = 1,mnobd ! hybrid%nbands - DO iband2 = 1,mnobd!iband1 - DO i = 1,3 - DO j = 1,3 - - rintegrand = atoms%rmsh(:,itype)**2*(ru1(:,i,iband1)*ru1(:,j,iband2) + ru2(:,i,iband1)*ru2(:,j,iband2)& - + iu1(:,i,iband1)*iu1(:,j,iband2) + iu2(:,i,iband1)*iu2(:,j,iband2) ) - - iintegrand = atoms%rmsh(:,itype)**2*(ru1(:,i,iband1)*iu1(:,j,iband2) + ru2(:,i,iband1)*iu2(:,j,iband2)& - - iu1(:,i,iband1)*ru1(:,j,iband2) - iu2(:,i,iband1)*ru2(:,j,iband2) ) - - olap_ibsc(i,j,iband2,iband1) = olap_ibsc(i,j,iband2,iband1) & - + intgrf(rintegrand,atoms%jri,atoms%jmtd,atoms%rmsh, atoms%dx,atoms%ntype,itype,hybdat%gridf)& - + img*intgrf(iintegrand,atoms%jri,atoms%jmtd,atoms%rmsh, atoms%dx,atoms%ntype,itype,hybdat%gridf) - - END DO + + ! + ! calculate + ! n1 and n2 occupied + ! + iatom = 0 + olap_ibsc = 0 + DO itype = 1, atoms%ntype + DO ieq = 1, atoms%neq(itype) + iatom = iatom + 1 + lm = 0 + DO l = 0, atoms%lmax(itype)!+1 + DO M = -l, l + lm = lm + 1 + ru1 = real(u1(:, :, :, lm, iatom)) + iu1 = aimag(u1(:, :, :, lm, iatom)) + ru2 = real(u2(:, :, :, lm, iatom)) + iu2 = aimag(u2(:, :, :, lm, iatom)) + + DO iband1 = 1, mnobd ! hybrid%nbands + DO iband2 = 1, mnobd!iband1 + DO i = 1, 3 + DO j = 1, 3 + + rintegrand = atoms%rmsh(:, itype)**2*(ru1(:, i, iband1)*ru1(:, j, iband2) + ru2(:, i, iband1)*ru2(:, j, iband2) & + + iu1(:, i, iband1)*iu1(:, j, iband2) + iu2(:, i, iband1)*iu2(:, j, iband2)) + + iintegrand = atoms%rmsh(:, itype)**2*(ru1(:, i, iband1)*iu1(:, j, iband2) + ru2(:, i, iband1)*iu2(:, j, iband2) & + - iu1(:, i, iband1)*ru1(:, j, iband2) - iu2(:, i, iband1)*ru2(:, j, iband2)) + + olap_ibsc(i, j, iband2, iband1) = olap_ibsc(i, j, iband2, iband1) & + + intgrf(rintegrand, atoms%jri, atoms%jmtd, atoms%rmsh, atoms%dx, atoms%ntype, itype, hybdat%gridf) & + + img*intgrf(iintegrand, atoms%jri, atoms%jmtd, atoms%rmsh, atoms%dx, atoms%ntype, itype, hybdat%gridf) + + END DO + END DO + + END DO + END DO + + END DO END DO - - END DO - END DO - + END DO + END DO + + END SUBROUTINE ibs_correction + + FUNCTION gauntvec(l1, m1, l2, m2, atoms) + + USE m_constants + USE m_gaunt + + USE m_types + IMPLICIT NONE + TYPE(t_atoms), INTENT(IN) :: atoms + + INTEGER, INTENT(IN) :: l1, m1, l2, m2 + + COMPLEX :: gauntvec(-1:1) + + INTEGER :: j, mj + INTEGER :: point(-1:1) + REAL :: rfac + COMPLEX :: cfac + COMPLEX, PARAMETER :: img = (0.0, 1.0) + + rfac = sqrt(tpi_const/3) + DO j = -1, 1 + ! j = -1 corresponds to x-direction + ! j = 0 corresponds to z-direction + ! j = 1 corresponds to y-direction + mj = abs(j) + cfac = img**((j + mj)/2.)*sqrt(2.)**(1 - mj)*rfac + gauntvec(j) = cfac*(gaunt1(1, l1, l2, -mj, m1, m2, atoms%lmaxd + 1) + j*gaunt1(1, l1, l2, mj, m1, m2, atoms%lmaxd + 1)) END DO - END DO - END DO - END DO - - - - END SUBROUTINE ibs_correction - - FUNCTION gauntvec(l1,m1,l2,m2,atoms) - - USE m_constants - USE m_gaunt - - USE m_types - IMPLICIT NONE - TYPE(t_atoms),INTENT(IN) :: atoms - - INTEGER , INTENT(IN) :: l1,m1,l2,m2 - - COMPLEX :: gauntvec(-1:1) - - INTEGER :: j,mj - INTEGER :: point(-1:1) - REAL :: rfac - COMPLEX :: cfac - COMPLEX , PARAMETER :: img = (0.0,1.0) - - rfac = sqrt(tpi_const/3) - DO j = -1,1 - ! j = -1 corresponds to x-direction - ! j = 0 corresponds to z-direction - ! j = 1 corresponds to y-direction - mj = abs(j) - cfac = img**( (j+mj)/2. ) * sqrt(2.)**(1-mj) * rfac - gauntvec(j) = cfac* ( gaunt1(1,l1,l2,-mj,m1,m2,atoms%lmaxd+1) + j*gaunt1(1,l1,l2, mj,m1,m2,atoms%lmaxd+1) ) - END DO - - ! transform onto cartesian coordinates - point(-1) = -1 - point( 0) = 1 - point( 1) = 0 - - gauntvec = gauntvec(point) - - END FUNCTION gauntvec - - FUNCTION w(p1,l1,p2,l2,itype,bas1_mt,drbas1_mt,& - rmt) - USE m_types - IMPLICIT NONE - - INTEGER , INTENT(IN) :: p1,l1,p2,l2 - INTEGER , INTENT(IN) :: itype - REAL,INTENT(IN) :: rmt(:),bas1_mt(:,0:,:),drbas1_mt(:,0:,:) - - REAL :: w - - INTEGER :: p - REAL :: denom,enum - - IF( p1 .gt. 2 .or. p2 .gt. 2 ) STOP 'w: the formalism is only valid for p<=2' - - denom = wronskian( bas1_MT(2,l1,itype),drbas1_MT(2,l1,itype), bas1_MT(1,l1,itype),drbas1_MT(1,l1,itype) ) - - p = p1 + (-1)**(p1-1) - - enum = bas1_MT(p,l1,itype)*bas1_MT(p2,l2,itype) + rmt(itype)*wronskian( bas1_MT(p ,l1,itype),& - drbas1_MT(p ,l1,itype), bas1_MT(p2,l2,itype), drbas1_MT(p2,l2,itype) ) - - w = (-1)**(p1+1)*enum/denom - - END FUNCTION - - - - PURE FUNCTION wronskian(f,df,g,dg) - IMPLICIT NONE - REAL , INTENT(IN) :: f,df,g,dg - REAL :: wronskian - - wronskian = f*dg - df*g - - END FUNCTION + + ! transform onto cartesian coordinates + point(-1) = -1 + point(0) = 1 + point(1) = 0 + + gauntvec = gauntvec(point) + + END FUNCTION gauntvec + + FUNCTION w(p1, l1, p2, l2, itype, bas1_mt, drbas1_mt, & + rmt) + USE m_types + IMPLICIT NONE + + INTEGER, INTENT(IN) :: p1, l1, p2, l2 + INTEGER, INTENT(IN) :: itype + REAL, INTENT(IN) :: rmt(:), bas1_mt(:, 0:, :), drbas1_mt(:, 0:, :) + + REAL :: w + + INTEGER :: p + REAL :: denom, enum + + IF (p1 > 2 .or. p2 > 2) STOP 'w: the formalism is only valid for p<=2' + + denom = wronskian(bas1_MT(2, l1, itype), drbas1_MT(2, l1, itype), bas1_MT(1, l1, itype), drbas1_MT(1, l1, itype)) + + p = p1 + (-1)**(p1 - 1) + + enum = bas1_MT(p, l1, itype)*bas1_MT(p2, l2, itype) + rmt(itype)*wronskian(bas1_MT(p, l1, itype), & + drbas1_MT(p, l1, itype), bas1_MT(p2, l2, itype), drbas1_MT(p2, l2, itype)) + + w = (-1)**(p1 + 1)*enum/denom + + END FUNCTION + + PURE FUNCTION wronskian(f, df, g, dg) + IMPLICIT NONE + REAL, INTENT(IN) :: f, df, g, dg + REAL :: wronskian + + wronskian = f*dg - df*g + + END FUNCTION ! Calculates the derivative ! ikr s s @@ -726,74 +703,69 @@ ! xyz dk dk dk ! x y z ! - SUBROUTINE dwavefproducts(& - dcprod,nk,bandi1,bandf1,bandi2,bandf2,lwrite,& - atoms,hybrid,& - cell,& - hybdat,kpts,nkpti,lapw,& - dimension,jsp,& - eig_irr) - - USE m_wrapper - USE m_types - IMPLICIT NONE - - TYPE(t_hybdat),INTENT(IN) :: hybdat - - TYPE(t_dimension),INTENT(IN) :: dimension - TYPE(t_hybrid),INTENT(IN) :: hybrid - TYPE(t_cell),INTENT(IN) :: cell - TYPE(t_kpts),INTENT(IN) :: kpts - TYPE(t_atoms),INTENT(IN) :: atoms - TYPE(t_lapw),INTENT(IN) :: lapw + SUBROUTINE dwavefproducts( & + dcprod, nk, bandi1, bandf1, bandi2, bandf2, lwrite, & + atoms, hybrid, & + cell, & + hybdat, kpts, nkpti, lapw, & + dimension, jsp, & + eig_irr) + + USE m_wrapper + USE m_types + IMPLICIT NONE + + TYPE(t_hybdat), INTENT(IN) :: hybdat + + TYPE(t_dimension), INTENT(IN) :: dimension + TYPE(t_hybrid), INTENT(IN) :: hybrid + TYPE(t_cell), INTENT(IN) :: cell + TYPE(t_kpts), INTENT(IN) :: kpts + TYPE(t_atoms), INTENT(IN) :: atoms + TYPE(t_lapw), INTENT(IN) :: lapw ! - scalars - - INTEGER,INTENT(IN) :: nk,bandi1,bandf1,bandi2,bandf2 - INTEGER,INTENT(IN) :: nkpti - INTEGER,INTENT(IN) :: jsp - + INTEGER, INTENT(IN) :: nk, bandi1, bandf1, bandi2, bandf2 + INTEGER, INTENT(IN) :: nkpti + INTEGER, INTENT(IN) :: jsp ! - arrays - - REAL,INTENT(IN) :: eig_irr(dimension%neigd,nkpti) - COMPLEX,INTENT(OUT) :: dcprod(bandi2:bandf2,bandi1:bandf1,3) + REAL, INTENT(IN) :: eig_irr(dimension%neigd, nkpti) + COMPLEX, INTENT(OUT) :: dcprod(bandi2:bandf2, bandi1:bandf1, 3) ! - local scalars - - INTEGER :: ikpt,ikpt1,iband1,iband2 - REAL :: rdum - LOGICAL :: lwrite - - - ! __ - ! Get momentum-matrix elements -i < uj | \/ | ui > - ! - CALL momentum_matrix(& - dcprod,nk,bandi1,bandf1,bandi2,bandf2,& - atoms,hybrid,& - cell,& - hybdat,kpts,lapw,& - dimension,jsp) - - - ! __ - ! Calculate expansion coefficients -i < uj | \/ | ui > / ( ei - ej ) for periodic function ui - ! - DO iband1 = bandi1,bandf1 - DO iband2 = bandi2,bandf2 - rdum = eig_irr(iband2,nk) - eig_irr(iband1,nk) - IF(abs(rdum).gt.10.0**-6) THEN !10.0**-6 - dcprod(iband2,iband1,:) = dcprod(iband2,iband1,:) / rdum - ELSE - dcprod(iband2,iband1,:) = 0.0 - END IF - END DO - END DO - - dcprod = dcprod / sqrt(cell%omtil) - - - - END SUBROUTINE dwavefproducts + INTEGER :: ikpt, ikpt1, iband1, iband2 + REAL :: rdum + LOGICAL :: lwrite + + ! __ + ! Get momentum-matrix elements -i < uj | \/ | ui > + ! + CALL momentum_matrix( & + dcprod, nk, bandi1, bandf1, bandi2, bandf2, & + atoms, hybrid, & + cell, & + hybdat, kpts, lapw, & + dimension, jsp) + + ! __ + ! Calculate expansion coefficients -i < uj | \/ | ui > / ( ei - ej ) for periodic function ui + ! + DO iband1 = bandi1, bandf1 + DO iband2 = bandi2, bandf2 + rdum = eig_irr(iband2, nk) - eig_irr(iband1, nk) + IF (abs(rdum) > 10.0**-6) THEN !10.0**-6 + dcprod(iband2, iband1, :) = dcprod(iband2, iband1, :)/rdum + ELSE + dcprod(iband2, iband1, :) = 0.0 + END IF + END DO + END DO + + dcprod = dcprod/sqrt(cell%omtil) + + END SUBROUTINE dwavefproducts ! - - - - - - - - - - - - - - - - - - - - - - - - - - - - - - - - - - - - - - - - - - - - - - - - - - - - - - - - - @@ -805,258 +777,249 @@ ! n' = unocc. ( bandi2 <= n' <= bandf2 ) ! ! - SUBROUTINE momentum_matrix(& - momentum,nk,bandi1,bandf1,bandi2,bandf2,& - atoms,hybrid,& - cell,& - hybdat,kpts,lapw,& - dimension,jsp) - - - - USE m_olap - USE m_wrapper - USE m_util ,only: derivative,intgrf_init,intgrf - USE m_dr2fdr - USE m_constants - USE m_types - USE m_io_hybrid - IMPLICIT NONE - - TYPE(t_hybdat),INTENT(IN) :: hybdat - TYPE(t_dimension),INTENT(IN) :: dimension - TYPE(t_hybrid),INTENT(IN) :: hybrid - TYPE(t_cell),INTENT(IN) :: cell - TYPE(t_kpts),INTENT(IN) :: kpts - TYPE(t_atoms),INTENT(IN) :: atoms - TYPE(t_lapw),INTENT(IN) :: lapw + SUBROUTINE momentum_matrix( & + momentum, nk, bandi1, bandf1, bandi2, bandf2, & + atoms, hybrid, & + cell, & + hybdat, kpts, lapw, & + dimension, jsp) + + USE m_olap + USE m_wrapper + USE m_util, only: derivative, intgrf_init, intgrf + USE m_dr2fdr + USE m_constants + USE m_types + USE m_io_hybrid + IMPLICIT NONE + + TYPE(t_hybdat), INTENT(IN) :: hybdat + TYPE(t_dimension), INTENT(IN) :: dimension + TYPE(t_hybrid), INTENT(IN) :: hybrid + TYPE(t_cell), INTENT(IN) :: cell + TYPE(t_kpts), INTENT(IN) :: kpts + TYPE(t_atoms), INTENT(IN) :: atoms + TYPE(t_lapw), INTENT(IN) :: lapw ! - scalars - - INTEGER,INTENT(IN) :: bandi1,bandf1,bandi2,bandf2 - INTEGER,INTENT(IN) :: nk - INTEGER,INTENT(IN) :: jsp - + INTEGER, INTENT(IN) :: bandi1, bandf1, bandi2, bandf2 + INTEGER, INTENT(IN) :: nk + INTEGER, INTENT(IN) :: jsp ! - arrays - - TYPE(t_mat):: z - COMPLEX,INTENT(OUT) :: momentum(bandi2:bandf2,bandi1:bandf1,3) + TYPE(t_mat):: z + COMPLEX, INTENT(OUT) :: momentum(bandi2:bandf2, bandi1:bandf1, 3) ! - local scalars - - INTEGER :: itype,ieq,ic,i,j,l ,lm,n1,n2,ikpt, iband1,iband2,ll,mm - INTEGER :: lm_0,lm_1,lm0,lm1,lm2,lm3,n0,nn,n, l1,l2,m1,m2,ikpt1 - INTEGER :: irecl_cmt,irecl_z,m - COMPLEX :: cdum - COMPLEX :: img=(0.0,1.0) + INTEGER :: itype, ieq, ic, i, j, l, lm, n1, n2, ikpt, iband1, iband2, ll, mm + INTEGER :: lm_0, lm_1, lm0, lm1, lm2, lm3, n0, nn, n, l1, l2, m1, m2, ikpt1 + INTEGER :: irecl_cmt, irecl_z, m + COMPLEX :: cdum + COMPLEX :: img = (0.0, 1.0) ! - local arrays - - INTEGER :: gpt(3,lapw%nv(jsp)) + INTEGER :: gpt(3, lapw%nv(jsp)) - REAL :: fcoeff((atoms%lmaxd+1)**2,-1:1), gcoeff((atoms%lmaxd+1)**2,-1:1) - REAL :: qmat1(hybrid%maxindx,hybrid%maxindx,0:atoms%lmaxd,atoms%ntype), dbas1(atoms%jmtd) - REAL :: qmat2(hybrid%maxindx,hybrid%maxindx,0:atoms%lmaxd,atoms%ntype), dbas2(atoms%jmtd) - REAL :: qg(lapw%nv(jsp),3) + REAL :: fcoeff((atoms%lmaxd + 1)**2, -1:1), gcoeff((atoms%lmaxd + 1)**2, -1:1) + REAL :: qmat1(hybrid%maxindx, hybrid%maxindx, 0:atoms%lmaxd, atoms%ntype), dbas1(atoms%jmtd) + REAL :: qmat2(hybrid%maxindx, hybrid%maxindx, 0:atoms%lmaxd, atoms%ntype), dbas2(atoms%jmtd) + REAL :: qg(lapw%nv(jsp), 3) - COMPLEX :: hlp(3,3) - COMPLEX :: cvec1(hybrid%maxlmindx),cvec2(hybrid%maxlmindx), cvec3(hybrid%maxlmindx) - COMPLEX :: cmt1(hybrid%maxlmindx,bandi1:bandf1), cmt2(hybrid%maxlmindx,bandi2:bandf2) - COMPLEX :: carr1(3),carr2(3) - COMPLEX :: cmt(dimension%neigd,hybrid%maxlmindx,atoms%nat) - REAL :: olap_r(lapw%nv(jsp)*(lapw%nv(jsp)+1)/2) - COMPLEX :: olap_c(lapw%nv(jsp)*(lapw%nv(jsp)+1)/2) - REAL :: vec1_r(lapw%nv(jsp)),vec2_r(lapw%nv(jsp)), vec3_r(lapw%nv(jsp)) - COMPLEX :: vec1_c(lapw%nv(jsp)),vec2_c(lapw%nv(jsp)), vec3_c(lapw%nv(jsp)) + COMPLEX :: hlp(3, 3) + COMPLEX :: cvec1(hybrid%maxlmindx), cvec2(hybrid%maxlmindx), cvec3(hybrid%maxlmindx) + COMPLEX :: cmt1(hybrid%maxlmindx, bandi1:bandf1), cmt2(hybrid%maxlmindx, bandi2:bandf2) + COMPLEX :: carr1(3), carr2(3) + COMPLEX :: cmt(dimension%neigd, hybrid%maxlmindx, atoms%nat) + REAL :: olap_r(lapw%nv(jsp)*(lapw%nv(jsp) + 1)/2) + COMPLEX :: olap_c(lapw%nv(jsp)*(lapw%nv(jsp) + 1)/2) + REAL :: vec1_r(lapw%nv(jsp)), vec2_r(lapw%nv(jsp)), vec3_r(lapw%nv(jsp)) + COMPLEX :: vec1_c(lapw%nv(jsp)), vec2_c(lapw%nv(jsp)), vec3_c(lapw%nv(jsp)) - ! read in cmt coefficients from direct access file cmt at kpoint nk - - call read_cmt(cmt,nk) - - ! read in z coefficients from direct access file z at kpoint nk + ! read in cmt coefficients from direct access file cmt at kpoint nk - call read_z(z,nk) + call read_cmt(cmt, nk) - !CALL intgrf_init(atoms%ntype,atoms%jmtd,atoms%jri,atoms%dx,atoms%rmsh,hybdat%gridf) + ! read in z coefficients from direct access file z at kpoint nk - gpt(1,1:lapw%nv(jsp)) = lapw%k1(1:lapw%nv(jsp),jsp) - gpt(2,1:lapw%nv(jsp)) = lapw%k2(1:lapw%nv(jsp),jsp) - gpt(3,1:lapw%nv(jsp)) = lapw%k3(1:lapw%nv(jsp),jsp) + call read_z(z, nk) + !CALL intgrf_init(atoms%ntype,atoms%jmtd,atoms%jri,atoms%dx,atoms%rmsh,hybdat%gridf) -! Define coefficients F and G - lm = 0 - DO l = 0,atoms%lmaxd - DO M = -l,l - lm = lm + 1 - fcoeff(lm,-1) = - sqrt( 1.0 * (l+M+1)*(l+M+2) / (2*(2*l+1)*(2*l+3)) ) - fcoeff(lm, 0) = sqrt( 1.0 * (l-M+1)*(l+M+1) / ((2*l+1)*(2*l+3)) ) - fcoeff(lm, 1) = - sqrt( 1.0 * (l-M+1)*(l-M+2) / (2*(2*l+1)*(2*l+3)) ) - gcoeff(lm,-1) = sqrt( 1.0 * (l-M)*(l-M-1) / (2*(2*l-1)*(2*l+1)) ) - gcoeff(lm, 0) = sqrt( 1.0 * (l-M)*(l+M) / ((2*l-1)*(2*l+1)) ) - gcoeff(lm, 1) = sqrt( 1.0 * (l+M)*(l+M-1) / (2*(2*l-1)*(2*l+1)) ) - END DO - END DO + gpt(1, 1:lapw%nv(jsp)) = lapw%k1(1:lapw%nv(jsp), jsp) + gpt(2, 1:lapw%nv(jsp)) = lapw%k2(1:lapw%nv(jsp), jsp) + gpt(3, 1:lapw%nv(jsp)) = lapw%k3(1:lapw%nv(jsp), jsp) +! Define coefficients F and G + lm = 0 + DO l = 0, atoms%lmaxd + DO M = -l, l + lm = lm + 1 + fcoeff(lm, -1) = -sqrt(1.0*(l + M + 1)*(l + M + 2)/(2*(2*l + 1)*(2*l + 3))) + fcoeff(lm, 0) = sqrt(1.0*(l - M + 1)*(l + M + 1)/((2*l + 1)*(2*l + 3))) + fcoeff(lm, 1) = -sqrt(1.0*(l - M + 1)*(l - M + 2)/(2*(2*l + 1)*(2*l + 3))) + gcoeff(lm, -1) = sqrt(1.0*(l - M)*(l - M - 1)/(2*(2*l - 1)*(2*l + 1))) + gcoeff(lm, 0) = sqrt(1.0*(l - M)*(l + M)/((2*l - 1)*(2*l + 1))) + gcoeff(lm, 1) = sqrt(1.0*(l + M)*(l + M - 1)/(2*(2*l - 1)*(2*l + 1))) + END DO + END DO ! Calculate olap int r**2*u*u' + w * int r*u*u, w = -l,l+1 ( -> qmat1/2 ) - qmat1 = 0 - qmat2 = 0 - ic = 0 - DO itype = 1,atoms%ntype - DO l = 0,atoms%lmax(itype) - DO n2 = 1,hybrid%nindx(l,itype) - !ic = ic + 1 - CALL derivative(dbas1,hybdat%bas1(:,n2,l,itype),atoms, itype) - dbas1 = dbas1 - hybdat%bas1(:,n2,l,itype)/atoms%rmsh(:,itype) - - CALL derivative(dbas2,hybdat%bas2(:,n2,l,itype),atoms, itype) - dbas2 = dbas2 - hybdat%bas2(:,n2,l,itype)/atoms%rmsh(:,itype) - - IF(l.ne.0) THEN - DO n1 = 1,hybrid%nindx(l-1,itype) - ic = ic + 1 - qmat1(n1,n2,l,itype) = intgrf( dbas1(:) * hybdat%bas1(:,n1,l-1,itype) +& - dbas2(:) * hybdat%bas2(:,n1,l-1,itype) , atoms%jri,atoms%jmtd,atoms%rmsh,atoms%dx,atoms%ntype,itype,hybdat%gridf )& - + intgrf( ( hybdat%bas1(:,n2,l,itype) * hybdat%bas1(:,n1,l-1,itype) + hybdat%bas2(:,n2,l,itype) * hybdat%bas2(:,n1,l-1,itype) ) & - / atoms%rmsh(:,itype) , atoms%jri,atoms%jmtd,atoms%rmsh,atoms%dx,atoms%ntype,itype,hybdat%gridf ) * (l+1) - - END DO - END IF - IF(l.ne.atoms%lmax(itype)) THEN - DO n1 = 1,hybrid%nindx(l+1,itype) - - - qmat2(n1,n2,l,itype) = intgrf( dbas1(:) * hybdat%bas1(:,n1,l+1,itype) + dbas2(:) * hybdat%bas2(:,n1,l+1,itype) , & - atoms%jri,atoms%jmtd,atoms%rmsh,atoms%dx,atoms%ntype,itype,hybdat%gridf )& - - intgrf( ( hybdat%bas1(:,n2,l,itype) * hybdat%bas1(:,n1,l+1,itype) + hybdat%bas2(:,n2,l,itype) * hybdat%bas2(:,n1,l+1,itype) ) & - / atoms%rmsh(:,itype) , atoms%jri,atoms%jmtd,atoms%rmsh,atoms%dx,atoms%ntype,itype,hybdat%gridf ) * l - - - END DO - END IF - - - - END DO - END DO - END DO - - ! __ - ! Calculate momentum matrix elements -i < uj | \/ | ui > wrt wave functions u (->momentum) - ! - - momentum = 0 - - ! MT contribution - - ic = 0 - DO itype = 1,atoms%ntype - DO ieq = 1,atoms%neq(itype) - ic = ic + 1 - nn = sum( (/ ((2*l+1)*hybrid%nindx(l,itype),l=0,atoms%lmax(itype)) /) ) - DO iband1 = bandi1,bandf1 - cmt1(:nn,iband1) = cmt(iband1,:nn,ic) - ENDDO - DO iband2 = bandi2,bandf2 - cmt2(:nn,iband2) = cmt(iband2,:nn,ic) - ENDDO - DO iband1 = bandi1,bandf1 - - cvec1 = 0 ; cvec2 = 0 ; cvec3 = 0 - ! build up left vector(s) ( -> cvec1/2/3 ) - lm_0 = 0 ! we start with s-functions (l=0) - lm_1 = hybrid%nindx(0,itype) ! we start with p-functions (l=0+1) - lm = 0 - DO l = 0,atoms%lmax(itype)-1 - n0 = hybrid%nindx(l, itype) - n1 = hybrid%nindx(l+1,itype) - DO M = -l,l - lm = lm + 1 - lm0 = lm_0 + (M+l) *n0 - lm1 = lm_1 + (M+1+l+1)*n1 - lm2 = lm_1 + (M +l+1)*n1 - lm3 = lm_1 + (M-1+l+1)*n1 - cvec1(lm0+1:lm0+n0) = fcoeff(lm,-1) * matmul ( cmt1(lm1+1:lm1+n1,iband1) , qmat2(:n1,:n0,l,itype) ) - cvec2(lm0+1:lm0+n0) = fcoeff(lm, 0) * matmul ( cmt1(lm2+1:lm2+n1,iband1) , qmat2(:n1,:n0,l,itype) ) - cvec3(lm0+1:lm0+n0) = fcoeff(lm, 1) * matmul ( cmt1(lm3+1:lm3+n1,iband1) , qmat2(:n1,:n0,l,itype) ) - END DO - lm_0 = lm_0 + (2*l+1)*n0 - lm_1 = lm_1 + (2*l+3)*n1 + qmat1 = 0 + qmat2 = 0 + ic = 0 + DO itype = 1, atoms%ntype + DO l = 0, atoms%lmax(itype) + DO n2 = 1, hybrid%nindx(l, itype) + !ic = ic + 1 + CALL derivative(dbas1, hybdat%bas1(:, n2, l, itype), atoms, itype) + dbas1 = dbas1 - hybdat%bas1(:, n2, l, itype)/atoms%rmsh(:, itype) + + CALL derivative(dbas2, hybdat%bas2(:, n2, l, itype), atoms, itype) + dbas2 = dbas2 - hybdat%bas2(:, n2, l, itype)/atoms%rmsh(:, itype) + + IF (l /= 0) THEN + DO n1 = 1, hybrid%nindx(l - 1, itype) + ic = ic + 1 + qmat1(n1, n2, l, itype) = intgrf(dbas1(:)*hybdat%bas1(:, n1, l - 1, itype) + & + dbas2(:)*hybdat%bas2(:, n1, l - 1, itype), atoms%jri, atoms%jmtd, atoms%rmsh, atoms%dx, atoms%ntype, itype, hybdat%gridf) & + + intgrf((hybdat%bas1(:, n2, l, itype)*hybdat%bas1(:, n1, l - 1, itype) + hybdat%bas2(:, n2, l, itype)*hybdat%bas2(:, n1, l - 1, itype)) & + /atoms%rmsh(:, itype), atoms%jri, atoms%jmtd, atoms%rmsh, atoms%dx, atoms%ntype, itype, hybdat%gridf)*(l + 1) + + END DO + END IF + IF (l /= atoms%lmax(itype)) THEN + DO n1 = 1, hybrid%nindx(l + 1, itype) + + qmat2(n1, n2, l, itype) = intgrf(dbas1(:)*hybdat%bas1(:, n1, l + 1, itype) + dbas2(:)*hybdat%bas2(:, n1, l + 1, itype), & + atoms%jri, atoms%jmtd, atoms%rmsh, atoms%dx, atoms%ntype, itype, hybdat%gridf) & + - intgrf((hybdat%bas1(:, n2, l, itype)*hybdat%bas1(:, n1, l + 1, itype) + hybdat%bas2(:, n2, l, itype)*hybdat%bas2(:, n1, l + 1, itype)) & + /atoms%rmsh(:, itype), atoms%jri, atoms%jmtd, atoms%rmsh, atoms%dx, atoms%ntype, itype, hybdat%gridf)*l + + END DO + END IF + + END DO + END DO + END DO + + ! __ + ! Calculate momentum matrix elements -i < uj | \/ | ui > wrt wave functions u (->momentum) + ! + + momentum = 0 + + ! MT contribution + + ic = 0 + DO itype = 1, atoms%ntype + DO ieq = 1, atoms%neq(itype) + ic = ic + 1 + nn = sum((/((2*l + 1)*hybrid%nindx(l, itype), l=0, atoms%lmax(itype))/)) + DO iband1 = bandi1, bandf1 + cmt1(:nn, iband1) = cmt(iband1, :nn, ic) + ENDDO + DO iband2 = bandi2, bandf2 + cmt2(:nn, iband2) = cmt(iband2, :nn, ic) + ENDDO + DO iband1 = bandi1, bandf1 + + cvec1 = 0; cvec2 = 0; cvec3 = 0 + ! build up left vector(s) ( -> cvec1/2/3 ) + lm_0 = 0 ! we start with s-functions (l=0) + lm_1 = hybrid%nindx(0, itype) ! we start with p-functions (l=0+1) + lm = 0 + DO l = 0, atoms%lmax(itype) - 1 + n0 = hybrid%nindx(l, itype) + n1 = hybrid%nindx(l + 1, itype) + DO M = -l, l + lm = lm + 1 + lm0 = lm_0 + (M + l)*n0 + lm1 = lm_1 + (M + 1 + l + 1)*n1 + lm2 = lm_1 + (M + l + 1)*n1 + lm3 = lm_1 + (M - 1 + l + 1)*n1 + cvec1(lm0 + 1:lm0 + n0) = fcoeff(lm, -1)*matmul(cmt1(lm1 + 1:lm1 + n1, iband1), qmat2(:n1, :n0, l, itype)) + cvec2(lm0 + 1:lm0 + n0) = fcoeff(lm, 0)*matmul(cmt1(lm2 + 1:lm2 + n1, iband1), qmat2(:n1, :n0, l, itype)) + cvec3(lm0 + 1:lm0 + n0) = fcoeff(lm, 1)*matmul(cmt1(lm3 + 1:lm3 + n1, iband1), qmat2(:n1, :n0, l, itype)) + END DO + lm_0 = lm_0 + (2*l + 1)*n0 + lm_1 = lm_1 + (2*l + 3)*n1 + END DO + + lm_0 = hybrid%nindx(0, itype) ! we start with p-functions (l=1) + lm_1 = 0 ! we start with s-functions (l=1-1) + lm = 1 + DO l = 1, atoms%lmax(itype) + n0 = hybrid%nindx(l, itype) + n1 = hybrid%nindx(l - 1, itype) + DO M = -l, l + lm = lm + 1 + lm0 = lm_0 + (M + l)*n0 + lm1 = lm_1 + (M + 1 + l - 1)*n1 + lm2 = lm_1 + (M + l - 1)*n1 + lm3 = lm_1 + (M - 1 + l - 1)*n1 + IF (abs(M + 1) <= l - 1) cvec1(lm0 + 1:lm0 + n0) = cvec1(lm0 + 1:lm0 + n0) + gcoeff(lm, -1)*matmul(cmt1(lm1 + 1:lm1 + n1, iband1), qmat1(:n1, :n0, l, itype)) + IF (abs(M) <= l - 1) cvec2(lm0 + 1:lm0 + n0) = cvec2(lm0 + 1:lm0 + n0) + gcoeff(lm, 0)*matmul(cmt1(lm2 + 1:lm2 + n1, iband1), qmat1(:n1, :n0, l, itype)) + IF (abs(M - 1) <= l - 1) cvec3(lm0 + 1:lm0 + n0) = cvec3(lm0 + 1:lm0 + n0) + gcoeff(lm, 1)*matmul(cmt1(lm3 + 1:lm3 + n1, iband1), qmat1(:n1, :n0, l, itype)) + END DO + lm_0 = lm_0 + (2*l + 1)*n0 + lm_1 = lm_1 + (2*l - 1)*n1 + END DO + ! multiply with right vector + DO iband2 = bandi2, bandf2 + momentum(iband2, iband1, 1) = momentum(iband2, iband1, 1) + dotprod(cvec1(:nn), cmt2(:nn, iband2)) + momentum(iband2, iband1, 2) = momentum(iband2, iband1, 2) + dotprod(cvec2(:nn), cmt2(:nn, iband2)) + momentum(iband2, iband1, 3) = momentum(iband2, iband1, 3) + dotprod(cvec3(:nn), cmt2(:nn, iband2)) + END DO ! iband2 + END DO ! iband1 + + END DO ! ieq + END DO ! itype + + ! Transform to cartesian coordinates + hlp = 0 + hlp(1, 1) = 1.0/sqrt(2.0) + hlp(1, 3) = -1.0/sqrt(2.0) + hlp(2, 1) = -img/sqrt(2.0) + hlp(2, 3) = -img/sqrt(2.0) + hlp(3, 2) = 1.0 + DO iband1 = bandi1, bandf1 + DO iband2 = bandi2, bandf2 + momentum(iband2, iband1, :) = -img*matmul(momentum(iband2, iband1, :), transpose(hlp)) + END DO + END DO + + ! plane-wave contribution + + CALL olap_pwp(z%l_real, olap_r, olap_c, gpt, lapw%nv(jsp), atoms, cell) + + DO nn = 1, lapw%nv(jsp) + qg(nn, :) = matmul(kpts%bk(:, nk) + gpt(:, nn), cell%bmat) END DO - lm_0 = hybrid%nindx(0,itype) ! we start with p-functions (l=1) - lm_1 = 0 ! we start with s-functions (l=1-1) - lm = 1 - DO l = 1,atoms%lmax(itype) - n0 = hybrid%nindx(l, itype) - n1 = hybrid%nindx(l-1,itype) - DO M = -l,l - lm = lm + 1 - lm0 = lm_0 + (M+l) *n0 - lm1 = lm_1 + (M+1+l-1)*n1 - lm2 = lm_1 + (M +l-1)*n1 - lm3 = lm_1 + (M-1+l-1)*n1 - IF(abs(M+1).le.l-1) cvec1(lm0+1:lm0+n0) = cvec1(lm0+1:lm0+n0) + gcoeff(lm,-1) * matmul ( cmt1(lm1+1:lm1+n1,iband1) , qmat1(:n1,:n0,l,itype) ) - IF(abs(M) .le.l-1) cvec2(lm0+1:lm0+n0) = cvec2(lm0+1:lm0+n0) + gcoeff(lm, 0) * matmul ( cmt1(lm2+1:lm2+n1,iband1) , qmat1(:n1,:n0,l,itype) ) - IF(abs(M-1).le.l-1) cvec3(lm0+1:lm0+n0) = cvec3(lm0+1:lm0+n0) + gcoeff(lm, 1) * matmul ( cmt1(lm3+1:lm3+n1,iband1) , qmat1(:n1,:n0,l,itype) ) - END DO - lm_0 = lm_0 + (2*l+1)*n0 - lm_1 = lm_1 + (2*l-1)*n1 + if (z%l_real) THEN + DO iband2 = bandi2, bandf2 + vec1_r = matvec(olap_r, z%data_r(:lapw%nv(jsp), iband2)*qg(:, 1)) + vec2_r = matvec(olap_r, z%data_r(:lapw%nv(jsp), iband2)*qg(:, 2)) + vec3_r = matvec(olap_r, z%data_r(:lapw%nv(jsp), iband2)*qg(:, 3)) + DO iband1 = bandi1, bandf1 + momentum(iband2, iband1, 1) = momentum(iband2, iband1, 1) + dotprod(z%data_r(:lapw%nv(jsp), iband1), vec1_r) + momentum(iband2, iband1, 2) = momentum(iband2, iband1, 2) + dotprod(z%data_r(:lapw%nv(jsp), iband1), vec2_r) + momentum(iband2, iband1, 3) = momentum(iband2, iband1, 3) + dotprod(z%data_r(:lapw%nv(jsp), iband1), vec3_r) + END DO + END DO + else + DO iband2 = bandi2, bandf2 + vec1_c = matvec(olap_c, z%data_c(:lapw%nv(jsp), iband2)*qg(:, 1)) + vec2_c = matvec(olap_c, z%data_c(:lapw%nv(jsp), iband2)*qg(:, 2)) + vec3_c = matvec(olap_c, z%data_c(:lapw%nv(jsp), iband2)*qg(:, 3)) + DO iband1 = bandi1, bandf1 + momentum(iband2, iband1, 1) = momentum(iband2, iband1, 1) + dotprod(z%data_c(:lapw%nv(jsp), iband1), vec1_c) + momentum(iband2, iband1, 2) = momentum(iband2, iband1, 2) + dotprod(z%data_c(:lapw%nv(jsp), iband1), vec2_c) + momentum(iband2, iband1, 3) = momentum(iband2, iband1, 3) + dotprod(z%data_c(:lapw%nv(jsp), iband1), vec3_c) + END DO END DO - ! multiply with right vector - DO iband2 = bandi2,bandf2 - momentum(iband2,iband1,1) = momentum(iband2,iband1,1) + dotprod(cvec1(:nn),cmt2(:nn,iband2)) - momentum(iband2,iband1,2) = momentum(iband2,iband1,2) + dotprod(cvec2(:nn),cmt2(:nn,iband2)) - momentum(iband2,iband1,3) = momentum(iband2,iband1,3) + dotprod(cvec3(:nn),cmt2(:nn,iband2)) - END DO ! iband2 - END DO ! iband1 - - END DO ! ieq - END DO ! itype - - ! Transform to cartesian coordinates - hlp = 0 - hlp( 1, 1) = 1.0/sqrt(2.0) - hlp( 1, 3) = -1.0/sqrt(2.0) - hlp( 2, 1) = -img/sqrt(2.0) - hlp( 2, 3) = -img/sqrt(2.0) - hlp( 3, 2) = 1.0 - DO iband1 = bandi1,bandf1 - DO iband2 = bandi2,bandf2 - momentum(iband2,iband1,:) = -img*matmul(momentum(iband2,iband1,:),transpose(hlp)) - END DO - END DO - - ! plane-wave contribution - - CALL olap_pwp(z%l_real,olap_r,olap_c,gpt,lapw%nv(jsp),atoms,cell) - - DO nn = 1,lapw%nv(jsp) - qg(nn,:) = matmul(kpts%bk(:,nk)+gpt(:,nn),cell%bmat) - END DO - - if (z%l_real) THEN - DO iband2 = bandi2,bandf2 - vec1_r = matvec( olap_r , z%data_r(:lapw%nv(jsp),iband2) * qg(:,1) ) - vec2_r = matvec( olap_r , z%data_r(:lapw%nv(jsp),iband2) * qg(:,2) ) - vec3_r = matvec( olap_r , z%data_r(:lapw%nv(jsp),iband2) * qg(:,3) ) - DO iband1 = bandi1,bandf1 - momentum(iband2,iband1,1) = momentum(iband2,iband1,1) + dotprod(z%data_r(:lapw%nv(jsp),iband1),vec1_r) - momentum(iband2,iband1,2) = momentum(iband2,iband1,2) + dotprod(z%data_r(:lapw%nv(jsp),iband1),vec2_r) - momentum(iband2,iband1,3) = momentum(iband2,iband1,3) + dotprod(z%data_r(:lapw%nv(jsp),iband1),vec3_r) - END DO - END DO - else - DO iband2 = bandi2,bandf2 - vec1_c = matvec( olap_c , z%data_c(:lapw%nv(jsp),iband2) * qg(:,1) ) - vec2_c = matvec( olap_c , z%data_c(:lapw%nv(jsp),iband2) * qg(:,2) ) - vec3_c = matvec( olap_c , z%data_c(:lapw%nv(jsp),iband2) * qg(:,3) ) - DO iband1 = bandi1,bandf1 - momentum(iband2,iband1,1) = momentum(iband2,iband1,1) + dotprod(z%data_c(:lapw%nv(jsp),iband1),vec1_c) - momentum(iband2,iband1,2) = momentum(iband2,iband1,2) + dotprod(z%data_c(:lapw%nv(jsp),iband1),vec2_c) - momentum(iband2,iband1,3) = momentum(iband2,iband1,3) + dotprod(z%data_c(:lapw%nv(jsp),iband1),vec3_c) - END DO - END DO - end if - - END SUBROUTINE momentum_matrix - + end if + + END SUBROUTINE momentum_matrix + END MODULE m_kp_perturbation diff --git a/hybrid/mixedbasis.F90 b/hybrid/mixedbasis.F90 index d34004ed44f93f0ae8b505423fb1cd22537dad2e..ba5d34c76f65b24c7922540e7e1f8441122863aa 100644 --- a/hybrid/mixedbasis.F90 +++ b/hybrid/mixedbasis.F90 @@ -38,862 +38,852 @@ MODULE m_mixedbasis CONTAINS -SUBROUTINE mixedbasis(atoms,kpts,DIMENSION,input,cell,sym,xcpot,hybrid,enpara,mpi,v,l_restart) - - USE m_judft - USE m_radfun, ONLY : radfun - USE m_radflo, ONLY : radflo - USE m_loddop, ONLY : loddop - USE m_util, ONLY : intgrf_init,intgrf,rorderpf - USE m_read_core - USE m_wrapper - USE m_eig66_io - USE m_types - - IMPLICIT NONE - - TYPE(t_xcpot_inbuild), INTENT(IN) :: xcpot - TYPE(t_mpi), INTENT(IN) :: mpi - TYPE(t_dimension), INTENT(IN) :: dimension - TYPE(t_hybrid), INTENT(INOUT) :: hybrid - TYPE(t_enpara), INTENT(IN) :: enpara - TYPE(t_input), INTENT(IN) :: input - TYPE(t_sym), INTENT(IN) :: sym - TYPE(t_cell), INTENT(IN) :: cell - TYPE(t_kpts), INTENT(IN) :: kpts - TYPE(t_atoms), INTENT(IN) :: atoms - TYPE(t_potden), INTENT(IN) :: v - - LOGICAL, INTENT(INOUT) :: l_restart - - ! local type variables - TYPE(t_usdus) :: usdus - - ! local scalars - INTEGER :: ilo,ikpt,ispin,itype,l1,l2,l,n,igpt,n1,n2,nn,i,j,ic,ng - INTEGER :: jsp,nodem,noded,m,nk,ok,x,y,z,maxindxc,lmaxcd - INTEGER :: divconq ! use Divide & Conquer algorithm for array sorting (>0: yes, =0: no) - REAL :: gcutm,wronk,rdum,rdum1,rdum2 - - LOGICAL :: ldum,ldum1 - - ! - local arrays - - INTEGER :: g(3) - INTEGER :: lmaxc(atoms%ntype) - INTEGER,ALLOCATABLE :: nindxc(:,:) - INTEGER,ALLOCATABLE :: ihelp(:) - INTEGER,ALLOCATABLE :: ptr(:) ! pointer for array sorting - INTEGER,ALLOCATABLE :: unsrt_pgptm(:,:) ! unsorted pointers to g vectors - - REAL :: kvec(3) - REAL :: flo(atoms%jmtd,2,atoms%nlod) - REAL :: uuilon(atoms%nlod,atoms%ntype), duilon(atoms%nlod,atoms%ntype) - REAL :: ulouilopn(atoms%nlod,atoms%nlod,atoms%ntype) - REAL :: potatom(atoms%jmtd,atoms%ntype) - REAL :: bashlp(atoms%jmtd) - - REAL, ALLOCATABLE :: f(:,:,:),df(:,:,:) - REAL, ALLOCATABLE :: olap(:,:),work(:),eig(:), eigv(:,:) - REAL, ALLOCATABLE :: bas1(:,:,:,:,:), bas2(:,:,:,:,:) - REAL, ALLOCATABLE :: basmhlp(:,:,:,:) - REAL, ALLOCATABLE :: gridf(:,:),vr0(:,:,:) - REAL, ALLOCATABLE :: core1(:,:,:,:,:), core2(:,:,:,:,:) - REAL, ALLOCATABLE :: eig_c(:,:,:,:) - REAL, ALLOCATABLE :: length_kg(:,:) ! length of the vectors k + G - - LOGICAL, ALLOCATABLE :: selecmat(:,:,:,:) - LOGICAL, ALLOCATABLE :: seleco(:,:),selecu(:,:) - - CHARACTER, PARAMETER :: lchar(0:38) = (/'s','p','d','f','g','h','i','j','k','l','m','n','o',& - 'x','x','x','x','x','x','x','x','x','x','x','x','x',& - 'x','x','x','x','x','x','x','x','x','x','x','x','x' /) - - CHARACTER(len=2) :: nchar - CHARACTER(len=2) :: noel(atoms%ntype) - CHARACTER(len=10) :: fname(atoms%ntype) - ! writing to a file - INTEGER, PARAMETER :: iounit = 125 - CHARACTER(10), PARAMETER :: ioname = 'mixbas' - LOGICAL :: l_found - - IF (mpi%irank == 0) WRITE(6,'(//A,I2,A)') '### subroutine: mixedbasis ###' - - IF (xcpot%is_name("exx")) CALL judft_error("EXX is not implemented in this version",calledby='mixedbasis') - - ! Deallocate arrays which might have been allocated in a previous run of this subroutine - IF(ALLOCATED(hybrid%ngptm)) DEALLOCATE(hybrid%ngptm) - IF(ALLOCATED(hybrid%ngptm1)) DEALLOCATE(hybrid%ngptm1) - IF(ALLOCATED(hybrid%nindxm1)) DEALLOCATE(hybrid%nindxm1) - IF(ALLOCATED(hybrid%pgptm)) DEALLOCATE(hybrid%pgptm) - IF(ALLOCATED(hybrid%pgptm1)) DEALLOCATE(hybrid%pgptm1) - IF(ALLOCATED(hybrid%gptm)) DEALLOCATE(hybrid%gptm) - IF(ALLOCATED(hybrid%basm1)) DEALLOCATE(hybrid%basm1) - - CALL usdus%init(atoms,input%jspins) - - ! If restart is specified read file if it already exists. If not create it. - IF (l_restart) THEN - - ! Test if file exists - INQUIRE(FILE=ioname,EXIST=l_found) - - IF (l_found.AND..FALSE.) THEN !reading not working yet - ! Open file - OPEN(UNIT=iounit,FILE=ioname,FORM='unformatted',STATUS='old') - - ! Read array sizes - !READ(iounit) kpts%nkptf,hybrid%gptmd - READ(iounit) hybrid%maxgptm,hybrid%maxindx - ! Allocate necessary array size and read arrays - ALLOCATE (hybrid%ngptm(kpts%nkptf),hybrid%gptm(3,hybrid%gptmd)) - ALLOCATE (hybrid%pgptm(hybrid%maxgptm,kpts%nkptf)) - READ(iounit) hybrid%ngptm,hybrid%gptm,hybrid%pgptm,hybrid%nindx - - ! Read array sizes - READ(iounit) hybrid%maxgptm1,hybrid%maxlcutm1,hybrid%maxindxm1,hybrid%maxindxp1 - ! Allocate necessary array size and read arrays - ALLOCATE (hybrid%ngptm1(kpts%nkptf),hybrid%pgptm1(hybrid%maxgptm1,kpts%nkptf)) - ALLOCATE (hybrid%nindxm1(0:hybrid%maxlcutm1,atoms%ntype)) - ALLOCATE (hybrid%basm1(atoms%jmtd,hybrid%maxindxm1,0:hybrid%maxlcutm1,atoms%ntype)) - READ(iounit) hybrid%ngptm1,hybrid%pgptm1,hybrid%nindxm1 - READ(iounit) hybrid%basm1 - - CLOSE(iounit) - - RETURN + SUBROUTINE mixedbasis(atoms, kpts, DIMENSION, input, cell, sym, xcpot, hybrid, enpara, mpi, v, l_restart) + + USE m_judft + USE m_radfun, ONLY: radfun + USE m_radflo, ONLY: radflo + USE m_loddop, ONLY: loddop + USE m_util, ONLY: intgrf_init, intgrf, rorderpf + USE m_read_core + USE m_wrapper + USE m_eig66_io + USE m_types + + IMPLICIT NONE + + TYPE(t_xcpot_inbuild), INTENT(IN) :: xcpot + TYPE(t_mpi), INTENT(IN) :: mpi + TYPE(t_dimension), INTENT(IN) :: dimension + TYPE(t_hybrid), INTENT(INOUT) :: hybrid + TYPE(t_enpara), INTENT(IN) :: enpara + TYPE(t_input), INTENT(IN) :: input + TYPE(t_sym), INTENT(IN) :: sym + TYPE(t_cell), INTENT(IN) :: cell + TYPE(t_kpts), INTENT(IN) :: kpts + TYPE(t_atoms), INTENT(IN) :: atoms + TYPE(t_potden), INTENT(IN) :: v + + LOGICAL, INTENT(INOUT) :: l_restart + + ! local type variables + TYPE(t_usdus) :: usdus + + ! local scalars + INTEGER :: ilo, ikpt, ispin, itype, l1, l2, l, n, igpt, n1, n2, nn, i, j, ic, ng + INTEGER :: jsp, nodem, noded, m, nk, ok, x, y, z, maxindxc, lmaxcd + INTEGER :: divconq ! use Divide & Conquer algorithm for array sorting (>0: yes, =0: no) + REAL :: gcutm, wronk, rdum, rdum1, rdum2 + + LOGICAL :: ldum, ldum1 + + ! - local arrays - + INTEGER :: g(3) + INTEGER :: lmaxc(atoms%ntype) + INTEGER, ALLOCATABLE :: nindxc(:, :) + INTEGER, ALLOCATABLE :: ihelp(:) + INTEGER, ALLOCATABLE :: ptr(:) ! pointer for array sorting + INTEGER, ALLOCATABLE :: unsrt_pgptm(:, :) ! unsorted pointers to g vectors + + REAL :: kvec(3) + REAL :: flo(atoms%jmtd, 2, atoms%nlod) + REAL :: uuilon(atoms%nlod, atoms%ntype), duilon(atoms%nlod, atoms%ntype) + REAL :: ulouilopn(atoms%nlod, atoms%nlod, atoms%ntype) + REAL :: potatom(atoms%jmtd, atoms%ntype) + REAL :: bashlp(atoms%jmtd) + + REAL, ALLOCATABLE :: f(:, :, :), df(:, :, :) + REAL, ALLOCATABLE :: olap(:, :), work(:), eig(:), eigv(:, :) + REAL, ALLOCATABLE :: bas1(:, :, :, :, :), bas2(:, :, :, :, :) + REAL, ALLOCATABLE :: basmhlp(:, :, :, :) + REAL, ALLOCATABLE :: gridf(:, :), vr0(:, :, :) + REAL, ALLOCATABLE :: core1(:, :, :, :, :), core2(:, :, :, :, :) + REAL, ALLOCATABLE :: eig_c(:, :, :, :) + REAL, ALLOCATABLE :: length_kg(:, :) ! length of the vectors k + G + + LOGICAL, ALLOCATABLE :: selecmat(:, :, :, :) + LOGICAL, ALLOCATABLE :: seleco(:, :), selecu(:, :) + + CHARACTER, PARAMETER :: lchar(0:38) = (/'s', 'p', 'd', 'f', 'g', 'h', 'i', 'j', 'k', 'l', 'm', 'n', 'o', & + 'x', 'x', 'x', 'x', 'x', 'x', 'x', 'x', 'x', 'x', 'x', 'x', 'x', & + 'x', 'x', 'x', 'x', 'x', 'x', 'x', 'x', 'x', 'x', 'x', 'x', 'x'/) + + CHARACTER(len=2) :: nchar + CHARACTER(len=2) :: noel(atoms%ntype) + CHARACTER(len=10) :: fname(atoms%ntype) + ! writing to a file + INTEGER, PARAMETER :: iounit = 125 + CHARACTER(10), PARAMETER :: ioname = 'mixbas' + LOGICAL :: l_found + + IF (mpi%irank == 0) WRITE (6, '(//A,I2,A)') '### subroutine: mixedbasis ###' + + IF (xcpot%is_name("exx")) CALL judft_error("EXX is not implemented in this version", calledby='mixedbasis') + + ! Deallocate arrays which might have been allocated in a previous run of this subroutine + IF (ALLOCATED(hybrid%ngptm)) DEALLOCATE (hybrid%ngptm) + IF (ALLOCATED(hybrid%ngptm1)) DEALLOCATE (hybrid%ngptm1) + IF (ALLOCATED(hybrid%nindxm1)) DEALLOCATE (hybrid%nindxm1) + IF (ALLOCATED(hybrid%pgptm)) DEALLOCATE (hybrid%pgptm) + IF (ALLOCATED(hybrid%pgptm1)) DEALLOCATE (hybrid%pgptm1) + IF (ALLOCATED(hybrid%gptm)) DEALLOCATE (hybrid%gptm) + IF (ALLOCATED(hybrid%basm1)) DEALLOCATE (hybrid%basm1) + + CALL usdus%init(atoms, input%jspins) + + ! If restart is specified read file if it already exists. If not create it. + IF (l_restart) THEN + + ! Test if file exists + INQUIRE (FILE=ioname, EXIST=l_found) + + IF (l_found .AND. .FALSE.) THEN !reading not working yet + ! Open file + OPEN (UNIT=iounit, FILE=ioname, FORM='unformatted', STATUS='old') + + ! Read array sizes + !READ(iounit) kpts%nkptf,hybrid%gptmd + READ (iounit) hybrid%maxgptm, hybrid%maxindx + ! Allocate necessary array size and read arrays + ALLOCATE (hybrid%ngptm(kpts%nkptf), hybrid%gptm(3, hybrid%gptmd)) + ALLOCATE (hybrid%pgptm(hybrid%maxgptm, kpts%nkptf)) + READ (iounit) hybrid%ngptm, hybrid%gptm, hybrid%pgptm, hybrid%nindx + + ! Read array sizes + READ (iounit) hybrid%maxgptm1, hybrid%maxlcutm1, hybrid%maxindxm1, hybrid%maxindxp1 + ! Allocate necessary array size and read arrays + ALLOCATE (hybrid%ngptm1(kpts%nkptf), hybrid%pgptm1(hybrid%maxgptm1, kpts%nkptf)) + ALLOCATE (hybrid%nindxm1(0:hybrid%maxlcutm1, atoms%ntype)) + ALLOCATE (hybrid%basm1(atoms%jmtd, hybrid%maxindxm1, 0:hybrid%maxlcutm1, atoms%ntype)) + READ (iounit) hybrid%ngptm1, hybrid%pgptm1, hybrid%nindxm1 + READ (iounit) hybrid%basm1 + + CLOSE (iounit) + + RETURN + END IF END IF - END IF - hybrid%maxindx = 0 - DO itype = 1, atoms%ntype - DO l = 0, atoms%lmax(itype) - hybrid%maxindx = MAX(hybrid%maxindx,2+COUNT(atoms%llo(:atoms%nlo(itype),itype).EQ.l)) + hybrid%maxindx = 0 + DO itype = 1, atoms%ntype + DO l = 0, atoms%lmax(itype) + hybrid%maxindx = MAX(hybrid%maxindx, 2 + COUNT(atoms%llo(:atoms%nlo(itype), itype) == l)) + END DO END DO - END DO - ! maxindx = maxval(nlo) + 2 + ! maxindx = maxval(nlo) + 2 - ! initialize gridf for radial integration - CALL intgrf_init(atoms%ntype,atoms%jmtd,atoms%jri,atoms%dx,atoms%rmsh,gridf) + ! initialize gridf for radial integration + CALL intgrf_init(atoms%ntype, atoms%jmtd, atoms%jri, atoms%dx, atoms%rmsh, gridf) - ALLOCATE (vr0(atoms%jmtd,atoms%ntype,input%jspins)) + ALLOCATE (vr0(atoms%jmtd, atoms%ntype, input%jspins)) - vr0(:,:,:) = v%mt(:,0,:,:) - - ! calculate radial basisfunctions u and u' with - ! the spherical part of the potential vr0 and store them in - ! bas1 = large component ,bas2 = small component + vr0(:, :, :) = v%mt(:, 0, :, :) - ALLOCATE(f(atoms%jmtd,2,0:atoms%lmaxd), df(atoms%jmtd,2,0:atoms%lmaxd)) - ALLOCATE(bas1(atoms%jmtd,hybrid%maxindx,0:atoms%lmaxd,atoms%ntype,input%jspins)) - ALLOCATE(bas2(atoms%jmtd,hybrid%maxindx,0:atoms%lmaxd,atoms%ntype,input%jspins)) + ! calculate radial basisfunctions u and u' with + ! the spherical part of the potential vr0 and store them in + ! bas1 = large component ,bas2 = small component - DO itype = 1, atoms%ntype - ng = atoms%jri(itype) - DO ispin = 1, input%jspins - DO l = 0, atoms%lmax(itype) - CALL radfun(l,itype,ispin,enpara%el0(l,itype,ispin),vr0(:,itype,ispin),atoms,& - f(:,:,l),df(:,:,l),usdus,nodem,noded,wronk) - END DO - bas1(1:ng,1,0:atoms%lmaxd,itype,ispin) = f(1:ng,1,0:atoms%lmaxd) - bas2(1:ng,1,0:atoms%lmaxd,itype,ispin) = f(1:ng,2,0:atoms%lmaxd) - bas1(1:ng,2,0:atoms%lmaxd,itype,ispin) = df(1:ng,1,0:atoms%lmaxd) - bas2(1:ng,2,0:atoms%lmaxd,itype,ispin) = df(1:ng,2,0:atoms%lmaxd) - - hybrid%nindx(:,itype) = 2 - ! generate radial functions for local orbitals - IF (atoms%nlo(itype).GE.1) THEN - CALL radflo(atoms,itype,ispin,enpara%ello0(1,1,ispin),vr0(:,itype,ispin),& - f,df,mpi,usdus,uuilon,duilon,ulouilopn,flo) - - DO ilo = 1, atoms%nlo(itype) - hybrid%nindx(atoms%llo(ilo,itype),itype) = hybrid%nindx(atoms%llo(ilo,itype),itype) + 1 - bas1(1:ng,hybrid%nindx(atoms%llo(ilo,itype),itype),atoms%llo(ilo,itype),itype,ispin) = flo(1:ng,1,ilo) - bas2(1:ng,hybrid%nindx(atoms%llo(ilo,itype),itype),atoms%llo(ilo,itype),itype,ispin) = flo(1:ng,2,ilo) + ALLOCATE (f(atoms%jmtd, 2, 0:atoms%lmaxd), df(atoms%jmtd, 2, 0:atoms%lmaxd)) + ALLOCATE (bas1(atoms%jmtd, hybrid%maxindx, 0:atoms%lmaxd, atoms%ntype, input%jspins)) + ALLOCATE (bas2(atoms%jmtd, hybrid%maxindx, 0:atoms%lmaxd, atoms%ntype, input%jspins)) + + DO itype = 1, atoms%ntype + ng = atoms%jri(itype) + DO ispin = 1, input%jspins + DO l = 0, atoms%lmax(itype) + CALL radfun(l, itype, ispin, enpara%el0(l, itype, ispin), vr0(:, itype, ispin), atoms, & + f(:, :, l), df(:, :, l), usdus, nodem, noded, wronk) END DO - END IF + bas1(1:ng, 1, 0:atoms%lmaxd, itype, ispin) = f(1:ng, 1, 0:atoms%lmaxd) + bas2(1:ng, 1, 0:atoms%lmaxd, itype, ispin) = f(1:ng, 2, 0:atoms%lmaxd) + bas1(1:ng, 2, 0:atoms%lmaxd, itype, ispin) = df(1:ng, 1, 0:atoms%lmaxd) + bas2(1:ng, 2, 0:atoms%lmaxd, itype, ispin) = df(1:ng, 2, 0:atoms%lmaxd) + + hybrid%nindx(:, itype) = 2 + ! generate radial functions for local orbitals + IF (atoms%nlo(itype) >= 1) THEN + CALL radflo(atoms, itype, ispin, enpara%ello0(1, 1, ispin), vr0(:, itype, ispin), & + f, df, mpi, usdus, uuilon, duilon, ulouilopn, flo) + + DO ilo = 1, atoms%nlo(itype) + hybrid%nindx(atoms%llo(ilo, itype), itype) = hybrid%nindx(atoms%llo(ilo, itype), itype) + 1 + bas1(1:ng, hybrid%nindx(atoms%llo(ilo, itype), itype), atoms%llo(ilo, itype), itype, ispin) = flo(1:ng, 1, ilo) + bas2(1:ng, hybrid%nindx(atoms%llo(ilo, itype), itype), atoms%llo(ilo, itype), itype, ispin) = flo(1:ng, 2, ilo) + END DO + END IF + END DO END DO - END DO - DEALLOCATE(f,df) + DEALLOCATE (f, df) - ! the radial functions are normalized - DO ispin = 1, input%jspins - DO itype = 1, atoms%ntype - DO l = 0, atoms%lmax(itype) - DO i = 1, hybrid%nindx(l,itype) - rdum = intgrf(bas1(:,i,l,itype,ispin)**2+bas2(:,i,l,itype,ispin)**2,& - atoms%jri,atoms%jmtd,atoms%rmsh,atoms%dx,atoms%ntype,itype,gridf) - bas1(:atoms%jri(itype),i,l,itype,ispin) = bas1(:atoms%jri(itype),i,l,itype,ispin) / SQRT(rdum) - bas2(:atoms%jri(itype),i,l,itype,ispin) = bas2(:atoms%jri(itype),i,l,itype,ispin) / SQRT(rdum) + ! the radial functions are normalized + DO ispin = 1, input%jspins + DO itype = 1, atoms%ntype + DO l = 0, atoms%lmax(itype) + DO i = 1, hybrid%nindx(l, itype) + rdum = intgrf(bas1(:, i, l, itype, ispin)**2 + bas2(:, i, l, itype, ispin)**2, & + atoms%jri, atoms%jmtd, atoms%rmsh, atoms%dx, atoms%ntype, itype, gridf) + bas1(:atoms%jri(itype), i, l, itype, ispin) = bas1(:atoms%jri(itype), i, l, itype, ispin)/SQRT(rdum) + bas2(:atoms%jri(itype), i, l, itype, ispin) = bas2(:atoms%jri(itype), i, l, itype, ispin)/SQRT(rdum) + END DO END DO END DO END DO - END DO - - ! - - - - - - SETUP OF THE MIXED BASIS IN THE IR - - - - - - - - - ! construct G-vectors with cutoff smaller than gcutm - gcutm = hybrid%gcutm1 - ALLOCATE (hybrid%ngptm(kpts%nkptf)) - - hybrid%ngptm = 0 - i = 0 - n = -1 - - rdum1 = MAXVAL((/ (SQRT(SUM(MATMUL(kpts%bkf(:,ikpt),cell%bmat)**2)),ikpt=1,kpts%nkptf) /)) - - ! a first run for the determination of the dimensions of the fields gptm,pgptm - - DO - n = n + 1 - ldum = .FALSE. - DO x = -n, n - n1 = n - ABS(x) - DO y = -n1, n1 - n2 = n1 - ABS(y) - DO z = -n2, n2,MAX(2*n2,1) - g = (/x,y,z/) - rdum = SQRT(SUM(MATMUL(g,cell%bmat)**2))-rdum1 - IF(rdum.GT.gcutm) CYCLE - ldum1 = .FALSE. - DO ikpt = 1, kpts%nkptf - kvec = kpts%bkf(:,ikpt) - rdum = SUM(MATMUL(kvec+g,cell%bmat)**2) - - IF(rdum.LE.gcutm**2) THEN - IF(.NOT.ldum1) THEN - i = i + 1 - ldum1 = .TRUE. + + ! - - - - - - SETUP OF THE MIXED BASIS IN THE IR - - - - - - - + + ! construct G-vectors with cutoff smaller than gcutm + gcutm = hybrid%gcutm1 + ALLOCATE (hybrid%ngptm(kpts%nkptf)) + + hybrid%ngptm = 0 + i = 0 + n = -1 + + rdum1 = MAXVAL((/(SQRT(SUM(MATMUL(kpts%bkf(:, ikpt), cell%bmat)**2)), ikpt=1, kpts%nkptf)/)) + + ! a first run for the determination of the dimensions of the fields gptm,pgptm + + DO + n = n + 1 + ldum = .FALSE. + DO x = -n, n + n1 = n - ABS(x) + DO y = -n1, n1 + n2 = n1 - ABS(y) + DO z = -n2, n2, MAX(2*n2, 1) + g = (/x, y, z/) + rdum = SQRT(SUM(MATMUL(g, cell%bmat)**2)) - rdum1 + IF (rdum > gcutm) CYCLE + ldum1 = .FALSE. + DO ikpt = 1, kpts%nkptf + kvec = kpts%bkf(:, ikpt) + rdum = SUM(MATMUL(kvec + g, cell%bmat)**2) + + IF (rdum <= gcutm**2) THEN + IF (.NOT. ldum1) THEN + i = i + 1 + ldum1 = .TRUE. + END IF + + hybrid%ngptm(ikpt) = hybrid%ngptm(ikpt) + 1 + ldum = .TRUE. END IF + END DO + END DO + END DO + END DO + IF (.NOT. ldum) EXIT + END DO + + hybrid%gptmd = i + hybrid%maxgptm = MAXVAL(hybrid%ngptm) + + ALLOCATE (hybrid%gptm(3, hybrid%gptmd)) + ALLOCATE (hybrid%pgptm(hybrid%maxgptm, kpts%nkptf)) + + hybrid%gptm = 0 + hybrid%pgptm = 0 + hybrid%ngptm = 0 + + i = 0 + n = -1 + + ! Allocate and initialize arrays needed for G vector ordering + ALLOCATE (unsrt_pgptm(hybrid%maxgptm, kpts%nkptf)) + ALLOCATE (length_kG(hybrid%maxgptm, kpts%nkptf)) + length_kG = 0 + unsrt_pgptm = 0 + + DO + n = n + 1 + ldum = .FALSE. + DO x = -n, n + n1 = n - ABS(x) + DO y = -n1, n1 + n2 = n1 - ABS(y) + DO z = -n2, n2, MAX(2*n2, 1) + g = (/x, y, z/) + rdum = SQRT(SUM(MATMUL(g, cell%bmat)**2)) - rdum1 + IF (rdum > gcutm) CYCLE + ldum1 = .FALSE. + DO ikpt = 1, kpts%nkptf + kvec = kpts%bkf(:, ikpt) + rdum = SUM(MATMUL(kvec + g, cell%bmat)**2) + + IF (rdum <= (gcutm)**2) THEN + IF (.NOT. ldum1) THEN + i = i + 1 + hybrid%gptm(:, i) = g + ldum1 = .TRUE. + END IF + + hybrid%ngptm(ikpt) = hybrid%ngptm(ikpt) + 1 + ldum = .TRUE. + + ! Position of the vector is saved as pointer + unsrt_pgptm(hybrid%ngptm(ikpt), ikpt) = i + ! Save length of vector k + G for array sorting + length_kG(hybrid%ngptm(ikpt), ikpt) = rdum + END IF + END DO + END DO + END DO + END DO + IF (.NOT. ldum) EXIT + END DO - hybrid%ngptm(ikpt) = hybrid%ngptm(ikpt) + 1 - ldum = .TRUE. + ! Sort pointers in array, so that shortest |k+G| comes first + DO ikpt = 1, kpts%nkptf + ALLOCATE (ptr(hybrid%ngptm(ikpt))) + ! Divide and conquer algorithm for arrays > 1000 entries + divconq = MAX(0, INT(1.443*LOG(0.001*hybrid%ngptm(ikpt)))) + ! create pointers which correspond to a sorted array + CALL rorderpf(ptr, length_kG(1:hybrid%ngptm(ikpt), ikpt), hybrid%ngptm(ikpt), divconq) + ! rearrange old pointers + DO igpt = 1, hybrid%ngptm(ikpt) + hybrid%pgptm(igpt, ikpt) = unsrt_pgptm(ptr(igpt), ikpt) + END DO + DEALLOCATE (ptr) + END DO + DEALLOCATE (unsrt_pgptm) + DEALLOCATE (length_kG) + + ! construct IR mixed basis set for the representation of the non local exchange elements with cutoff gcutm1 + + ! first run to determine dimension of pgptm1 + ALLOCATE (hybrid%ngptm1(kpts%nkptf)) + hybrid%ngptm1 = 0 + DO igpt = 1, hybrid%gptmd + g = hybrid%gptm(:, igpt) + DO ikpt = 1, kpts%nkptf + kvec = kpts%bkf(:, ikpt) + rdum = SUM(MATMUL(kvec + g, cell%bmat)**2) + IF (rdum <= hybrid%gcutm1**2) THEN + hybrid%ngptm1(ikpt) = hybrid%ngptm1(ikpt) + 1 + END IF + END DO + END DO + hybrid%maxgptm1 = MAXVAL(hybrid%ngptm1) + + ALLOCATE (hybrid%pgptm1(hybrid%maxgptm1, kpts%nkptf)) + hybrid%pgptm1 = 0 + hybrid%ngptm1 = 0 + + ! Allocate and initialize arrays needed for G vector ordering + ALLOCATE (unsrt_pgptm(hybrid%maxgptm1, kpts%nkptf)) + ALLOCATE (length_kG(hybrid%maxgptm1, kpts%nkptf)) + length_kG = 0 + unsrt_pgptm = 0 + DO igpt = 1, hybrid%gptmd + g = hybrid%gptm(:, igpt) + DO ikpt = 1, kpts%nkptf + kvec = kpts%bkf(:, ikpt) + rdum = SUM(MATMUL(kvec + g, cell%bmat)**2) + IF (rdum <= hybrid%gcutm1**2) THEN + hybrid%ngptm1(ikpt) = hybrid%ngptm1(ikpt) + 1 + unsrt_pgptm(hybrid%ngptm1(ikpt), ikpt) = igpt + length_kG(hybrid%ngptm1(ikpt), ikpt) = rdum + END IF + END DO + END DO + + ! Sort pointers in array, so that shortest |k+G| comes first + DO ikpt = 1, kpts%nkptf + ALLOCATE (ptr(hybrid%ngptm1(ikpt))) + ! Divide and conquer algorithm for arrays > 1000 entries + divconq = MAX(0, INT(1.443*LOG(0.001*hybrid%ngptm1(ikpt)))) + ! create pointers which correspond to a sorted array + CALL rorderpf(ptr, length_kG(1:hybrid%ngptm1(ikpt), ikpt), hybrid%ngptm1(ikpt), divconq) + ! rearrange old pointers + DO igpt = 1, hybrid%ngptm1(ikpt) + hybrid%pgptm1(igpt, ikpt) = unsrt_pgptm(ptr(igpt), ikpt) + END DO + DEALLOCATE (ptr) + END DO + DEALLOCATE (unsrt_pgptm) + DEALLOCATE (length_kG) + + IF (mpi%irank == 0) THEN + WRITE (6, '(/A)') 'Mixed basis' + WRITE (6, '(A,I5)') 'Number of unique G-vectors: ', hybrid%gptmd + WRITE (6, *) + WRITE (6, '(3x,A)') 'IR Plane-wave basis with cutoff of gcutm (hybrid%gcutm1/2*input%rkmax):' + WRITE (6, '(5x,A,I5)') 'Maximal number of G-vectors:', hybrid%maxgptm + WRITE (6, *) + WRITE (6, *) + WRITE (6, '(3x,A)') 'IR Plane-wave basis for non-local exchange potential:' + WRITE (6, '(5x,A,I5)') 'Maximal number of G-vectors:', hybrid%maxgptm1 + WRITE (6, *) + END IF + + ! - - - - - - - - Set up MT product basis for the non-local exchange potential - - - - - - - - - - + + IF (mpi%irank == 0) THEN + WRITE (6, '(A)') 'MT product basis for non-local exchange potential:' + WRITE (6, '(A)') 'Reduction due to overlap (quality of orthonormality, should be < 1.0E-06)' + END IF + + hybrid%maxlcutm1 = MAXVAL(hybrid%lcutm1) + + ALLOCATE (hybrid%nindxm1(0:hybrid%maxlcutm1, atoms%ntype)) + ALLOCATE (seleco(hybrid%maxindx, 0:atoms%lmaxd), selecu(hybrid%maxindx, 0:atoms%lmaxd)) + ALLOCATE (selecmat(hybrid%maxindx, 0:atoms%lmaxd, hybrid%maxindx, 0:atoms%lmaxd)) + hybrid%nindxm1 = 0 !!! 01/12/10 jij%M.b. + + ! determine maximal indices of (radial) mixed-basis functions (->nindxm1) + ! (will be reduced later-on due to overlap) + hybrid%maxindxp1 = 0 + DO itype = 1, atoms%ntype + seleco = .FALSE. + selecu = .FALSE. + seleco(1, 0:hybrid%select1(1, itype)) = .TRUE. + selecu(1, 0:hybrid%select1(3, itype)) = .TRUE. + seleco(2, 0:hybrid%select1(2, itype)) = .TRUE. + selecu(2, 0:hybrid%select1(4, itype)) = .TRUE. + + ! include local orbitals + IF (hybrid%maxindx >= 3) THEN + seleco(3:, :) = .TRUE. + selecu(3:, :) = .TRUE. + END IF + + DO l = 0, hybrid%lcutm1(itype) + n = 0 + M = 0 + + ! + ! valence * valence + ! + + ! Condense seleco and seleco into selecmat (each product corresponds to a matrix element) + selecmat = RESHAPE((/((((seleco(n1, l1) .AND. selecu(n2, l2), & + n1=1, hybrid%maxindx), l1=0, atoms%lmaxd), n2=1, hybrid%maxindx), l2=0, atoms%lmaxd)/), & + (/hybrid%maxindx, atoms%lmaxd + 1, hybrid%maxindx, atoms%lmaxd + 1/)) + + DO l1 = 0, atoms%lmax(itype) + DO l2 = 0, atoms%lmax(itype) + IF (l >= ABS(l1 - l2) .AND. l <= l1 + l2) THEN + DO n1 = 1, hybrid%nindx(l1, itype) + DO n2 = 1, hybrid%nindx(l2, itype) + M = M + 1 + IF (selecmat(n1, l1, n2, l2)) THEN + n = n + 1 + selecmat(n2, l2, n1, l1) = .FALSE. ! prevent double counting of products (a*b = b*a) + END IF + END DO + END DO END IF END DO END DO + IF (n == 0 .AND. mpi%irank == 0) & + WRITE (6, '(A)') 'mixedbasis: Warning! No basis-function product of '//lchar(l)// & + '-angular momentum defined.' + hybrid%maxindxp1 = MAX(hybrid%maxindxp1, M) + hybrid%nindxm1(l, itype) = n*input%jspins END DO END DO - IF(.NOT.ldum) EXIT - END DO - - hybrid%gptmd = i - hybrid%maxgptm = MAXVAL(hybrid%ngptm) - - ALLOCATE (hybrid%gptm(3,hybrid%gptmd)) - ALLOCATE (hybrid%pgptm(hybrid%maxgptm,kpts%nkptf)) - - hybrid%gptm = 0 - hybrid%pgptm = 0 - hybrid%ngptm = 0 - - i = 0 - n = -1 - - ! Allocate and initialize arrays needed for G vector ordering - ALLOCATE (unsrt_pgptm(hybrid%maxgptm,kpts%nkptf)) - ALLOCATE (length_kG(hybrid%maxgptm,kpts%nkptf)) - length_kG = 0 - unsrt_pgptm = 0 - - DO - n = n + 1 - ldum = .FALSE. - DO x = -n, n - n1 = n - ABS(x) - DO y = -n1, n1 - n2 = n1 - ABS(y) - DO z = -n2, n2,MAX(2*n2,1) - g = (/x,y,z/) - rdum = SQRT(SUM(MATMUL(g,cell%bmat)**2))-rdum1 - IF(rdum.GT.gcutm) CYCLE - ldum1 = .FALSE. - DO ikpt = 1, kpts%nkptf - kvec = kpts%bkf(:,ikpt) - rdum = SUM(MATMUL(kvec+g,cell%bmat)**2) - - IF(rdum.LE.(gcutm)**2) THEN - IF(.NOT.ldum1) THEN - i = i + 1 - hybrid%gptm(:,i) = g - ldum1 = .TRUE. + hybrid%maxindxm1 = MAXVAL(hybrid%nindxm1) + + ALLOCATE (hybrid%basm1(atoms%jmtd, hybrid%maxindxm1, 0:hybrid%maxlcutm1, atoms%ntype)) + hybrid%basm1 = 0 + + ! Define product bases and reduce them according to overlap + + DO itype = 1, atoms%ntype + seleco = .FALSE. + selecu = .FALSE. + seleco(1, 0:hybrid%select1(1, itype)) = .TRUE. + selecu(1, 0:hybrid%select1(3, itype)) = .TRUE. + seleco(2, 0:hybrid%select1(2, itype)) = .TRUE. + selecu(2, 0:hybrid%select1(4, itype)) = .TRUE. + ! include lo's + IF (hybrid%maxindx >= 3) THEN + seleco(3:, :) = .TRUE. + selecu(3:, :) = .TRUE. + END IF + IF (atoms%ntype > 1 .AND. mpi%irank == 0)& + & WRITE (6, '(6X,A,I3)') 'Atom type', itype + ng = atoms%jri(itype) + DO l = 0, hybrid%lcutm1(itype) + n = hybrid%nindxm1(l, itype) + ! allow for zero product-basis functions for + ! current l-quantum number + IF (n == 0) THEN + IF (mpi%irank == 0) WRITE (6, '(6X,A,'': 0 -> 0'')') lchar(l) + CYCLE + END IF + + ! set up the overlap matrix + ALLOCATE (olap(n, n), eigv(n, n), work(3*n), eig(n), ihelp(n)) + ihelp = 1 ! initialize to avoid a segfault + i = 0 + + ! valence*valence + + ! Condense seleco and seleco into selecmat (each product corresponds to a matrix element) + selecmat = RESHAPE((/((((seleco(n1, l1) .AND. selecu(n2, l2), & + n1=1, hybrid%maxindx), l1=0, atoms%lmaxd), n2=1, hybrid%maxindx), l2=0, atoms%lmaxd)/), & + (/hybrid%maxindx, atoms%lmaxd + 1, hybrid%maxindx, atoms%lmaxd + 1/)) + + DO l1 = 0, atoms%lmax(itype) + DO l2 = 0, atoms%lmax(itype) + IF (l < ABS(l1 - l2) .OR. l > l1 + l2) CYCLE + + DO n1 = 1, hybrid%nindx(l1, itype) + DO n2 = 1, hybrid%nindx(l2, itype) + + IF (selecmat(n1, l1, n2, l2)) THEN + DO ispin = 1, input%jspins + i = i + 1 + IF (i > n) call judft_error('got too many product functions', hint='This is a BUG, please report', calledby='mixedbasis') + + hybrid%basm1(:ng, i, l, itype) & + = (bas1(:ng, n1, l1, itype, ispin) & + *bas1(:ng, n2, l2, itype, ispin) & + + bas2(:ng, n1, l1, itype, ispin) & + *bas2(:ng, n2, l2, itype, ispin))/atoms%rmsh(:ng, itype) + + !normalize basm1 + rdum = SQRT(intgrf(hybrid%basm1(:, i, l, itype)**2, & + atoms%jri, atoms%jmtd, atoms%rmsh, atoms%dx, atoms%ntype, itype, gridf)) + + hybrid%basm1(:ng, i, l, itype) = hybrid%basm1(:ng, i, l, itype)/rdum + + END DO !ispin + ! prevent double counting of products (a*b = b*a) + selecmat(n2, l2, n1, l1) = .FALSE. + END IF + + END DO !n2 + END DO !n1 + + END DO !l2 + END DO !l1 + + IF (i /= n) call judft_error('counting error for product functions', hint='This is a BUG, please report', calledby='mixedbasis') + + ! In order to get ride of the linear dependencies in the + ! radial functions basm1 belonging to fixed l and itype + ! the overlap matrix is diagonalized and those eigenvectors + ! with a eigenvalue greater then hybrid%tolerance1 are retained + + ! Calculate overlap + olap = 0 + DO n2 = 1, n + DO n1 = 1, n2 + olap(n1, n2) = intgrf(hybrid%basm1(:, n1, l, itype)*hybrid%basm1(:, n2, l, itype), & + atoms%jri, atoms%jmtd, atoms%rmsh, atoms%dx, atoms%ntype, itype, gridf) + olap(n2, n1) = olap(n1, n2) + END DO + END DO + + ! Diagonalize + CALL diagonalize(eigv, eig, olap) + + ! Get rid of linear dependencies (eigenvalue <= hybrid%tolerance1) + nn = 0 + DO i = 1, hybrid%nindxm1(l, itype) + IF (eig(i) > hybrid%tolerance1) THEN + nn = nn + 1 + ihelp(nn) = i + END IF + END DO + hybrid%nindxm1(l, itype) = nn + eig = eig(ihelp) + eigv(:, :) = eigv(:, ihelp) + + DO i = 1, ng + hybrid%basm1(i, 1:nn, l, itype) = MATMUL(hybrid%basm1(i, 1:n, l, itype), eigv(:, 1:nn))/SQRT(eig(:nn)) + END DO + + ! Add constant function to l=0 basis and then do a Gram-Schmidt orthonormalization + IF (l == 0) THEN + + ! Check if basm1 must be reallocated + IF (nn + 1 > SIZE(hybrid%basm1, 2)) THEN + ALLOCATE (basmhlp(atoms%jmtd, nn + 1, 0:hybrid%maxlcutm1, atoms%ntype)) + basmhlp(:, 1:nn, :, :) = hybrid%basm1 + DEALLOCATE (hybrid%basm1) + ALLOCATE (hybrid%basm1(atoms%jmtd, nn + 1, 0:hybrid%maxlcutm1, atoms%ntype)) + hybrid%basm1(:, 1:nn, :, :) = basmhlp(:, 1:nn, :, :) + DEALLOCATE (basmhlp) + END IF + + hybrid%basm1(:ng, nn + 1, 0, itype) = atoms%rmsh(:ng, itype)/SQRT(atoms%rmsh(ng, itype)**3/3) + DO i = nn, 1, -1 + DO j = i + 1, nn + 1 + hybrid%basm1(:ng, i, 0, itype) = hybrid%basm1(:ng, i, 0, itype) & + - intgrf(hybrid%basm1(:ng, i, 0, itype)*hybrid%basm1(:ng, j, 0, itype), & + atoms%jri, atoms%jmtd, atoms%rmsh, atoms%dx, atoms%ntype, itype, gridf) & + *hybrid%basm1(:ng, j, 0, itype) + + END DO + hybrid%basm1(:ng, i, 0, itype) = hybrid%basm1(:ng, i, 0, itype) & + /SQRT(intgrf(hybrid%basm1(:ng, i, 0, itype)**2, & + atoms%jri, atoms%jmtd, atoms%rmsh, atoms%dx, atoms%ntype, itype, gridf)) + END DO + nn = nn + 1 + DEALLOCATE (olap) + ALLOCATE (olap(nn, nn)) + hybrid%nindxm1(l, itype) = nn + END IF + + ! Check orthonormality of product basis + rdum = 0 + DO i = 1, nn + DO j = 1, i + rdum1 = intgrf(hybrid%basm1(:, i, l, itype)*hybrid%basm1(:, j, l, itype), & + atoms%jri, atoms%jmtd, atoms%rmsh, atoms%dx, atoms%ntype, itype, gridf) + + IF (i == j) THEN + rdum1 = ABS(1 - rdum1) + rdum = rdum + rdum1**2 + ELSE + rdum1 = ABS(rdum1) + rdum = rdum + 2*rdum1**2 + END IF + + IF (rdum1 > 10.0**-6) THEN + IF (mpi%irank == 0) THEN + WRITE (6, '(A)') 'mixedbasis: Bad orthonormality of ' & + //lchar(l)//'-product basis. Increase tolerance.' + WRITE (6, '(12X,A,F9.6,A,2(I3.3,A))') 'Deviation of', & + rdum1, ' occurred for (', i, ',', j, ')-overlap.' END IF + CALL judft_error("Bad orthonormality of product basis", hint='Increase tolerance', calledby='mixedbasis') + END IF + + END DO + END DO + + IF (mpi%irank == 0) THEN + WRITE (6, '(6X,A,I4,'' ->'',I4,'' ('',ES8.1,'' )'')') lchar(l)//':', n, nn, SQRT(rdum)/nn + END IF + + DEALLOCATE (olap, eigv, work, eig, ihelp) + + END DO !l + IF (mpi%irank == 0) WRITE (6, '(6X,A,I7)') 'Total:', SUM(hybrid%nindxm1(0:hybrid%lcutm1(itype), itype)) + END DO ! itype + + hybrid%maxindxm1 = MAXVAL(hybrid%nindxm1) + + ALLOCATE (basmhlp(atoms%jmtd, hybrid%maxindxm1, 0:hybrid%maxlcutm1, atoms%ntype)) + basmhlp(1:atoms%jmtd, 1:hybrid%maxindxm1, 0:hybrid%maxlcutm1, 1:atoms%ntype) & + = hybrid%basm1(1:atoms%jmtd, 1:hybrid%maxindxm1, 0:hybrid%maxlcutm1, 1:atoms%ntype) + DEALLOCATE (hybrid%basm1) + ALLOCATE (hybrid%basm1(atoms%jmtd, hybrid%maxindxm1, 0:hybrid%maxlcutm1, atoms%ntype)) + hybrid%basm1 = basmhlp + + DEALLOCATE (basmhlp, seleco, selecu, selecmat) + + ! + ! now we build linear combinations of the radial functions + ! such that they possess no moment except one radial function in each l-channel + ! + IF (mpi%irank == 0) THEN + WRITE (6, '(/,A,/,A)') 'Build linear combinations of radial '// & + 'functions in each l-channel,', & + 'such that they possess no multipolmoment'// & + ' except the last function:' + + WRITE (6, '(/,17x,A)') 'moment (quality of orthonormality)' + END IF + DO itype = 1, atoms%ntype + ng = atoms%jri(itype) + + IF (atoms%ntype > 1 .AND. mpi%irank == 0) WRITE (6, '(6X,A,I3)') 'Atom type', itype + + DO l = 0, hybrid%lcutm1(itype) + ! determine radial function with the largest moment + ! this function is used to build the linear combinations + rdum = 0 + DO i = 1, hybrid%nindxm1(l, itype) + rdum1 = intgrf(atoms%rmsh(:ng, itype)**(l + 1)*hybrid%basm1(:ng, i, l, itype), & + atoms%jri, atoms%jmtd, atoms%rmsh, atoms%dx, atoms%ntype, itype, gridf) + IF (ABS(rdum1) > rdum) THEN + n = i + rdum = rdum1 + END IF + END DO + + ! rearrange order of radial functions such that the last function possesses the largest moment + j = 0 + bashlp(:ng) = hybrid%basm1(:ng, n, l, itype) + DO i = 1, hybrid%nindxm1(l, itype) + IF (i == n) CYCLE + j = j + 1 + hybrid%basm1(:ng, j, l, itype) = hybrid%basm1(:ng, i, l, itype) + END DO + hybrid%basm1(:ng, hybrid%nindxm1(l, itype), l, itype) = bashlp(:ng) + + END DO + + DO l = 0, hybrid%lcutm1(itype) + IF (mpi%irank == 0) WRITE (6, '(6X,A)') lchar(l)//':' + + IF (hybrid%nindxm1(l, itype) == 0) THEN + IF (mpi%irank == 0) WRITE (6, '(6X,A,'': 0 -> '')') lchar(l) + CYCLE + END IF + + n = hybrid%nindxm1(l, itype) + DO i = 1, hybrid%nindxm1(l, itype) + IF (i == n) CYCLE + ! calculate moment of radial function i + rdum1 = intgrf(atoms%rmsh(:ng, itype)**(l + 1)*hybrid%basm1(:ng, i, l, itype), & + atoms%jri, atoms%jmtd, atoms%rmsh, atoms%dx, atoms%ntype, itype, gridf) - hybrid%ngptm(ikpt) = hybrid%ngptm(ikpt) + 1 - ldum = .TRUE. + rdum = intgrf(atoms%rmsh(:ng, itype)**(l + 1)*hybrid%basm1(:ng, n, l, itype), & + atoms%jri, atoms%jmtd, atoms%rmsh, atoms%dx, atoms%ntype, itype, gridf) + + bashlp(:ng) = hybrid%basm1(:ng, n, l, itype) + + IF (SQRT(rdum**2 + rdum1**2) <= 1E-06 .AND. mpi%irank == 0) & + WRITE (6, *) 'Warning: Norm is smaller thann 1E-06!' + + ! change function n such that n is orthogonal to i + ! since the functions basm1 have been orthogonal on input + ! the linear combination does not destroy the orthogonality to the residual functions + hybrid%basm1(:ng, n, l, itype) = rdum/SQRT(rdum**2 + rdum1**2)*bashlp(:ng) & + + rdum1/SQRT(rdum**2 + rdum1**2)*hybrid%basm1(:ng, i, l, itype) + + ! combine basis function i and n so that they possess no momemt + hybrid%basm1(:ng, i, l, itype) = rdum1/SQRT(rdum**2 + rdum1**2)*bashlp(:ng) & + - rdum/SQRT(rdum**2 + rdum1**2)*hybrid%basm1(:ng, i, l, itype) + + rdum1 = intgrf(atoms%rmsh(:ng, itype)**(l + 1)*hybrid%basm1(:ng, i, l, itype), & + atoms%jri, atoms%jmtd, atoms%rmsh, atoms%dx, atoms%ntype, itype, gridf) + + IF (rdum1 > 1E-10) call judft_error('moment of radial function does not vanish', calledby='mixedbasis') + + IF (mpi%irank == 0) WRITE (6, '(6x,I4,'' -> '',ES8.1)') i, rdum1 + END DO - ! Position of the vector is saved as pointer - unsrt_pgptm(hybrid%ngptm(ikpt),ikpt) = i - ! Save length of vector k + G for array sorting - length_kG(hybrid%ngptm(ikpt),ikpt) = rdum + ! test orthogonality + rdum = 0 + DO i = 1, hybrid%nindxm1(l, itype) + DO j = 1, hybrid%nindxm1(l, itype) + rdum1 = intgrf(hybrid%basm1(:ng, i, l, itype)*hybrid%basm1(:ng, j, l, itype), & + atoms%jri, atoms%jmtd, atoms%rmsh, atoms%dx, atoms%ntype, itype, gridf) + IF (i /= j) THEN + rdum = rdum + rdum1 + ELSE + rdum = rdum + ABS(1 - rdum1) END IF END DO END DO + IF (mpi%irank == 0) & + WRITE (6, '(6x,I4,'' ->'',f10.5,'' ('',ES8.1,'' )'')') n, & + intgrf(atoms%rmsh(:ng, itype)**(l + 1)*hybrid%basm1(:ng, n, l, itype), atoms%jri, & + atoms%jmtd, atoms%rmsh, atoms%dx, atoms%ntype, itype, gridf), rdum END DO END DO - IF(.NOT.ldum) EXIT - END DO - - ! Sort pointers in array, so that shortest |k+G| comes first - DO ikpt = 1,kpts%nkptf - ALLOCATE(ptr(hybrid%ngptm(ikpt))) - ! Divide and conquer algorithm for arrays > 1000 entries - divconq = MAX( 0, INT( 1.443*LOG( 0.001*hybrid%ngptm(ikpt) ) ) ) - ! create pointers which correspond to a sorted array - CALL rorderpf(ptr, length_kG(1:hybrid%ngptm(ikpt),ikpt),hybrid%ngptm(ikpt), divconq ) - ! rearrange old pointers - DO igpt = 1,hybrid%ngptm(ikpt) - hybrid%pgptm(igpt,ikpt) = unsrt_pgptm(ptr(igpt),ikpt) - END DO - DEALLOCATE(ptr) - END DO - DEALLOCATE(unsrt_pgptm) - DEALLOCATE(length_kG) - - ! construct IR mixed basis set for the representation of the non local exchange elements with cutoff gcutm1 - - ! first run to determine dimension of pgptm1 - ALLOCATE(hybrid%ngptm1(kpts%nkptf)) - hybrid%ngptm1 = 0 - DO igpt = 1, hybrid%gptmd - g = hybrid%gptm(:,igpt) - DO ikpt = 1, kpts%nkptf - kvec = kpts%bkf(:,ikpt) - rdum = SUM(MATMUL(kvec+g,cell%bmat)**2) - IF(rdum.LE.hybrid%gcutm1**2) THEN - hybrid%ngptm1(ikpt) = hybrid%ngptm1(ikpt) + 1 - END IF + + DO itype = 1, atoms%ntype + IF (ANY(hybrid%nindxm1(0:hybrid%lcutm1(itype), itype) == 0)) call judft_error('any hybrid%nindxm1 eq 0', calledby='mixedbasis') END DO - END DO - hybrid%maxgptm1 = MAXVAL(hybrid%ngptm1) - - ALLOCATE(hybrid%pgptm1(hybrid%maxgptm1,kpts%nkptf)) - hybrid%pgptm1 = 0 - hybrid%ngptm1 = 0 - - ! Allocate and initialize arrays needed for G vector ordering - ALLOCATE (unsrt_pgptm(hybrid%maxgptm1,kpts%nkptf)) - ALLOCATE (length_kG(hybrid%maxgptm1,kpts%nkptf)) - length_kG = 0 - unsrt_pgptm = 0 - DO igpt = 1, hybrid%gptmd - g = hybrid%gptm(:,igpt) - DO ikpt = 1, kpts%nkptf - kvec = kpts%bkf(:,ikpt) - rdum = SUM(MATMUL(kvec+g,cell%bmat)**2) - IF(rdum.LE.hybrid%gcutm1**2) THEN - hybrid%ngptm1(ikpt) = hybrid%ngptm1(ikpt) + 1 - unsrt_pgptm(hybrid%ngptm1(ikpt),ikpt) = igpt - length_kG(hybrid%ngptm1(ikpt),ikpt) = rdum - END IF + + !count basis functions + hybrid%nbasp = 0 + DO itype = 1, atoms%ntype + DO i = 1, atoms%neq(itype) + DO l = 0, hybrid%lcutm1(itype) + DO M = -l, l + DO j = 1, hybrid%nindxm1(l, itype) + hybrid%nbasp = hybrid%nbasp + 1 + END DO + END DO + END DO + END DO END DO - END DO - - ! Sort pointers in array, so that shortest |k+G| comes first - DO ikpt = 1, kpts%nkptf - ALLOCATE(ptr(hybrid%ngptm1(ikpt))) - ! Divide and conquer algorithm for arrays > 1000 entries - divconq = MAX( 0, INT( 1.443*LOG( 0.001*hybrid%ngptm1(ikpt) ) ) ) - ! create pointers which correspond to a sorted array - CALL rorderpf(ptr,length_kG(1:hybrid%ngptm1(ikpt),ikpt),hybrid%ngptm1(ikpt),divconq) - ! rearrange old pointers - DO igpt = 1, hybrid%ngptm1(ikpt) - hybrid%pgptm1(igpt,ikpt) = unsrt_pgptm(ptr(igpt),ikpt) + hybrid%maxbasm1 = hybrid%nbasp + hybrid%maxgptm + DO nk = 1, kpts%nkptf + hybrid%nbasm(nk) = hybrid%nbasp + hybrid%ngptm(nk) END DO - DEALLOCATE(ptr) - END DO - DEALLOCATE(unsrt_pgptm) - DEALLOCATE(length_kG) - - - IF (mpi%irank == 0) THEN - WRITE(6,'(/A)') 'Mixed basis' - WRITE(6,'(A,I5)') 'Number of unique G-vectors: ',hybrid%gptmd - WRITE(6,*) - WRITE(6,'(3x,A)') 'IR Plane-wave basis with cutoff of gcutm (hybrid%gcutm1/2*input%rkmax):' - WRITE(6,'(5x,A,I5)') 'Maximal number of G-vectors:',hybrid%maxgptm - WRITE(6,*) - WRITE(6,*) - WRITE(6,'(3x,A)') 'IR Plane-wave basis for non-local exchange potential:' - WRITE(6,'(5x,A,I5)') 'Maximal number of G-vectors:',hybrid%maxgptm1 - WRITE(6,*) - END IF - - ! - - - - - - - - Set up MT product basis for the non-local exchange potential - - - - - - - - - - - - IF (mpi%irank == 0) THEN - WRITE(6,'(A)') 'MT product basis for non-local exchange potential:' - WRITE(6,'(A)') 'Reduction due to overlap (quality of orthonormality, should be < 1.0E-06)' - END IF - - hybrid%maxlcutm1 = MAXVAL(hybrid%lcutm1) - - ALLOCATE (hybrid%nindxm1(0:hybrid%maxlcutm1,atoms%ntype)) - ALLOCATE (seleco(hybrid%maxindx,0:atoms%lmaxd),selecu(hybrid%maxindx,0:atoms%lmaxd)) - ALLOCATE (selecmat(hybrid%maxindx,0:atoms%lmaxd,hybrid%maxindx,0:atoms%lmaxd)) - hybrid%nindxm1 = 0 !!! 01/12/10 jij%M.b. - - ! determine maximal indices of (radial) mixed-basis functions (->nindxm1) - ! (will be reduced later-on due to overlap) - hybrid%maxindxp1 = 0 - DO itype = 1,atoms%ntype - seleco = .FALSE. - selecu = .FALSE. - seleco(1,0:hybrid%select1(1,itype)) = .TRUE. - selecu(1,0:hybrid%select1(3,itype)) = .TRUE. - seleco(2,0:hybrid%select1(2,itype)) = .TRUE. - selecu(2,0:hybrid%select1(4,itype)) = .TRUE. - - ! include local orbitals - IF(hybrid%maxindx.GE.3) THEN - seleco(3:,:) = .TRUE. - selecu(3:,:) = .TRUE. - END IF - - DO l=0,hybrid%lcutm1(itype) - n = 0 - M = 0 - - ! - ! valence * valence - ! - - ! Condense seleco and seleco into selecmat (each product corresponds to a matrix element) - selecmat = RESHAPE ( (/ ((((seleco(n1,l1).AND.selecu(n2,l2),& - n1=1,hybrid%maxindx),l1=0,atoms%lmaxd), n2=1,hybrid%maxindx),l2=0,atoms%lmaxd) /) ,& - (/hybrid%maxindx,atoms%lmaxd+1,hybrid%maxindx,atoms%lmaxd+1/) ) - - DO l1=0,atoms%lmax(itype) - DO l2=0,atoms%lmax(itype) - IF( l.GE.ABS(l1-l2) .AND. l.LE.l1+l2) THEN - DO n1=1,hybrid%nindx(l1,itype) - DO n2=1,hybrid%nindx(l2,itype) - M = M + 1 - IF(selecmat(n1,l1,n2,l2)) THEN - n = n + 1 - selecmat(n2,l2,n1,l1) = .FALSE. ! prevent double counting of products (a*b = b*a) - END IF - END DO - END DO - END IF - END DO - END DO - IF(n.EQ.0 .AND. mpi%irank==0) & - WRITE(6,'(A)') 'mixedbasis: Warning! No basis-function product of ' // lchar(l) //& - '-angular momentum defined.' - hybrid%maxindxp1 = MAX(hybrid%maxindxp1,M) - hybrid%nindxm1(l,itype) = n*input%jspins - END DO - END DO - hybrid%maxindxm1 = MAXVAL(hybrid%nindxm1) - - ALLOCATE ( hybrid%basm1(atoms%jmtd,hybrid%maxindxm1,0:hybrid%maxlcutm1,atoms%ntype) ) - hybrid%basm1 = 0 - - ! Define product bases and reduce them according to overlap - - DO itype=1,atoms%ntype - seleco = .FALSE. - selecu = .FALSE. - seleco(1,0:hybrid%select1(1,itype)) = .TRUE. - selecu(1,0:hybrid%select1(3,itype)) = .TRUE. - seleco(2,0:hybrid%select1(2,itype)) = .TRUE. - selecu(2,0:hybrid%select1(4,itype)) = .TRUE. - ! include lo's - IF(hybrid%maxindx.GE.3) THEN - seleco(3:,:) = .TRUE. - selecu(3:,:) = .TRUE. - END IF - IF(atoms%ntype.GT.1 .AND. mpi%irank==0)& - & WRITE(6,'(6X,A,I3)') 'Atom type',itype - ng = atoms%jri(itype) - DO l=0,hybrid%lcutm1(itype) - n = hybrid%nindxm1(l,itype) - ! allow for zero product-basis functions for - ! current l-quantum number - IF(n.EQ.0) THEN - IF ( mpi%irank==0 ) WRITE(6,'(6X,A,'': 0 -> 0'')') lchar(l) - CYCLE - END IF - - ! set up the overlap matrix - ALLOCATE (olap(n,n),eigv(n,n),work(3*n),eig(n),ihelp(n)) - ihelp = 1 ! initialize to avoid a segfault - i = 0 - - - ! valence*valence - - ! Condense seleco and seleco into selecmat (each product corresponds to a matrix element) - selecmat = RESHAPE ( (/ ((((seleco(n1,l1).AND.selecu(n2,l2),& - n1=1,hybrid%maxindx),l1=0,atoms%lmaxd), n2=1,hybrid%maxindx),l2=0,atoms%lmaxd) /) , & - (/hybrid%maxindx,atoms%lmaxd+1,hybrid%maxindx,atoms%lmaxd+1/) ) - - DO l1=0,atoms%lmax(itype) - DO l2=0,atoms%lmax(itype) - IF( l .LT. ABS(l1-l2) .OR. l .GT. l1+l2 ) CYCLE - - DO n1=1,hybrid%nindx(l1,itype) - DO n2=1,hybrid%nindx(l2,itype) - - IF(selecmat(n1,l1,n2,l2)) THEN - DO ispin=1,input%jspins - i = i + 1 - IF(i.GT.n) call judft_error('got too many product functions',hint='This is a BUG, please report',calledby='mixedbasis') - - hybrid%basm1(:ng,i,l,itype) & - = ( bas1(:ng,n1,l1,itype,ispin)& - * bas1(:ng,n2,l2,itype,ispin) & - + bas2(:ng,n1,l1,itype,ispin)& - * bas2(:ng,n2,l2,itype,ispin) )/atoms%rmsh(:ng,itype) - - !normalize basm1 - rdum=SQRT(intgrf(hybrid%basm1(:,i,l,itype)**2,& - atoms%jri,atoms%jmtd,atoms%rmsh,atoms%dx,atoms%ntype,itype,gridf) ) - - hybrid%basm1(:ng,i,l,itype) = hybrid%basm1(:ng,i,l,itype)/rdum - - END DO !ispin - ! prevent double counting of products (a*b = b*a) - selecmat(n2,l2,n1,l1) = .FALSE. - END IF - - END DO !n2 - END DO !n1 - - - END DO !l2 - END DO !l1 - - IF(i .NE. n) call judft_error('counting error for product functions',hint='This is a BUG, please report',calledby='mixedbasis') - - ! In order to get ride of the linear dependencies in the - ! radial functions basm1 belonging to fixed l and itype - ! the overlap matrix is diagonalized and those eigenvectors - ! with a eigenvalue greater then hybrid%tolerance1 are retained - - - ! Calculate overlap - olap = 0 - DO n2=1,n - DO n1=1,n2 - olap(n1,n2) = intgrf(hybrid%basm1(:,n1,l,itype) *hybrid%basm1(:,n2,l,itype),& - atoms%jri,atoms%jmtd,atoms%rmsh,atoms%dx,atoms%ntype,itype,gridf) - olap(n2,n1) = olap(n1,n2) - END DO - END DO - - ! Diagonalize - CALL diagonalize(eigv,eig,olap) - - ! Get rid of linear dependencies (eigenvalue <= hybrid%tolerance1) - nn = 0 - DO i=1,hybrid%nindxm1(l,itype) - IF(eig(i).GT.hybrid%tolerance1) THEN - nn = nn + 1 - ihelp(nn) = i - END IF - END DO - hybrid%nindxm1(l,itype) = nn - eig = eig(ihelp) - eigv(:,:) = eigv(:,ihelp) - - DO i=1,ng - hybrid%basm1(i,1:nn,l,itype) = MATMUL(hybrid%basm1(i,1:n,l,itype), eigv(:,1:nn))/SQRT(eig(:nn)) - END DO - - ! Add constant function to l=0 basis and then do a Gram-Schmidt orthonormalization - IF(l.EQ.0) THEN - - ! Check if basm1 must be reallocated - IF(nn+1.GT.SIZE(hybrid%basm1,2)) THEN - ALLOCATE ( basmhlp(atoms%jmtd,nn+1,0:hybrid%maxlcutm1,atoms%ntype) ) - basmhlp(:,1:nn,:,:) = hybrid%basm1 - DEALLOCATE (hybrid%basm1) - ALLOCATE ( hybrid%basm1(atoms%jmtd,nn+1,0:hybrid%maxlcutm1,atoms%ntype) ) - hybrid%basm1(:,1:nn,:,:) = basmhlp(:,1:nn,:,:) - DEALLOCATE ( basmhlp ) - END IF - - hybrid%basm1(:ng,nn+1,0,itype) = atoms%rmsh(:ng,itype) / SQRT(atoms%rmsh(ng,itype)**3/3) - DO i = nn,1,-1 - DO j = i+1,nn+1 - hybrid%basm1(:ng,i,0,itype) = hybrid%basm1(:ng,i,0,itype)& - - intgrf(hybrid%basm1(:ng,i,0,itype)*hybrid%basm1(:ng,j,0,itype),& - atoms%jri,atoms%jmtd,atoms%rmsh,atoms%dx,atoms%ntype,itype,gridf)& - * hybrid%basm1(:ng,j,0,itype) - - END DO - hybrid%basm1(:ng,i,0,itype) = hybrid%basm1(:ng,i,0,itype)& - / SQRT(intgrf(hybrid%basm1(:ng,i,0,itype)**2,& - atoms%jri,atoms%jmtd,atoms%rmsh,atoms%dx,atoms%ntype,itype,gridf)) - END DO - nn = nn + 1 - DEALLOCATE ( olap ) - ALLOCATE ( olap(nn,nn) ) - hybrid%nindxm1(l,itype) = nn - END IF - - ! Check orthonormality of product basis - rdum = 0 - DO i=1,nn - DO j=1,i - rdum1 = intgrf(hybrid%basm1(:,i,l,itype)*hybrid%basm1(:,j,l,itype),& - atoms%jri,atoms%jmtd,atoms%rmsh,atoms%dx,atoms%ntype,itype,gridf) - - IF(i.EQ.j) THEN - rdum1 = ABS(1-rdum1) - rdum = rdum + rdum1**2 - ELSE - rdum1 = ABS(rdum1) - rdum = rdum + 2*rdum1**2 - END IF - - IF(rdum1.GT.10.0**-6) THEN - IF ( mpi%irank == 0 ) THEN - WRITE(6,'(A)') 'mixedbasis: Bad orthonormality of ' & - //lchar(l)//'-product basis. Increase tolerance.' - WRITE(6,'(12X,A,F9.6,A,2(I3.3,A))') 'Deviation of',& - rdum1,' occurred for (',i,',',j,')-overlap.' - END IF - CALL judft_error("Bad orthonormality of product basis",hint='Increase tolerance',calledby='mixedbasis') - END IF - END DO - END DO + hybrid%maxlmindx = MAXVAL((/(SUM((/(hybrid%nindx(l, itype)*(2*l + 1), l=0, atoms%lmax(itype))/)), itype=1, atoms%ntype)/)) - IF ( mpi%irank == 0 ) THEN - WRITE(6,'(6X,A,I4,'' ->'',I4,'' ('',ES8.1,'' )'')') lchar(l)//':',n,nn,SQRT(rdum)/nn - END IF + ! + ! + ! Write all information to a file to enable restarting + ! + IF (l_restart .AND. mpi%irank == 0) THEN - DEALLOCATE(olap,eigv,work,eig,ihelp) + OPEN (UNIT=iounit, FILE=ioname, FORM='unformatted', STATUS='replace') - END DO !l - IF ( mpi%irank == 0 ) WRITE(6,'(6X,A,I7)') 'Total:', SUM(hybrid%nindxm1(0:hybrid%lcutm1(itype),itype)) - END DO ! itype + WRITE (iounit) kpts%nkptf, hybrid%gptmd + WRITE (iounit) hybrid%maxgptm, hybrid%maxindx + WRITE (iounit) hybrid%ngptm, hybrid%gptm, hybrid%pgptm, hybrid%nindx - hybrid%maxindxm1 = MAXVAL(hybrid%nindxm1) + WRITE (iounit) hybrid%maxgptm1, hybrid%maxlcutm1, hybrid%maxindxm1, hybrid%maxindxp1 + WRITE (iounit) hybrid%ngptm1, hybrid%pgptm1, hybrid%nindxm1 + WRITE (iounit) hybrid%basm1 - ALLOCATE( basmhlp(atoms%jmtd,hybrid%maxindxm1,0:hybrid%maxlcutm1,atoms%ntype) ) - basmhlp(1:atoms%jmtd,1:hybrid%maxindxm1,0:hybrid%maxlcutm1,1:atoms%ntype)& - = hybrid%basm1(1:atoms%jmtd,1:hybrid%maxindxm1,0:hybrid%maxlcutm1,1:atoms%ntype) - DEALLOCATE(hybrid%basm1) - ALLOCATE( hybrid%basm1(atoms%jmtd,hybrid%maxindxm1,0:hybrid%maxlcutm1,atoms%ntype) ) - hybrid%basm1=basmhlp + CLOSE (iounit) - DEALLOCATE(basmhlp,seleco,selecu,selecmat) + l_restart = .FALSE. + END IF - ! - ! now we build linear combinations of the radial functions - ! such that they possess no moment except one radial function in each l-channel - ! - IF ( mpi%irank == 0 ) THEN - WRITE(6,'(/,A,/,A)')'Build linear combinations of radial '//& - 'functions in each l-channel,',& - 'such that they possess no multipolmoment'//& - ' except the last function:' + END SUBROUTINE mixedbasis + + SUBROUTINE read_atompotential(atoms, fname, potential) + + USE m_types + IMPLICIT NONE + TYPE(t_atoms), INTENT(IN) :: atoms + + ! - scalars - + CHARACTER(10), INTENT(IN) :: fname(atoms%ntype) + + ! - arrays - + REAL, INTENT(OUT):: potential(atoms%jmtd, atoms%ntype) + ! - local scalars - + INTEGER :: i, j, itype, ic, m + REAL :: rdum, r, n + ! - local arrays - + REAL, ALLOCATABLE :: v_atom(:), r_atom(:) + + potential = 0 + DO itype = 1, atoms%ntype + OPEN (331, file=fname(itype), form='formatted') + + ic = 0 + DO + READ (331, *) rdum + ic = ic + 1 + IF (rdum > (atoms%rmt(itype) + 0.2)) EXIT + END DO + + ALLOCATE (v_atom(ic), r_atom(ic)) + REWIND (331) + + DO i = 1, ic + READ (331, *) r_atom(i), v_atom(i) + END DO + + ! transfer potential from grid used in the atom program + ! to those used here + DO i = 1, atoms%jri(itype) + r = atoms%rmsh(i, itype) + DO j = 1, ic - 1 + IF (r_atom(j) > r) THEN + M = (v_atom(j) - v_atom(j + 1))/(r_atom(j) - r_atom(j + 1)) + n = v_atom(j) - M*r_atom(j) + potential(i, itype) = n + M*r + ! WRITE(333,'(4f25.10)') n + m*r_atom(j),v_atom(j),n + m*r_atom(j+1),v_atom(j+1) + EXIT + END IF + END DO + END DO + + DEALLOCATE (v_atom, r_atom) + CLOSE (331) + END DO - WRITE(6,'(/,17x,A)') 'moment (quality of orthonormality)' - END IF - DO itype = 1,atoms%ntype - ng = atoms%jri(itype) - - IF(atoms%ntype.GT.1 .AND. mpi%irank==0) WRITE(6,'(6X,A,I3)') 'Atom type',itype - - DO l = 0,hybrid%lcutm1(itype) - ! determine radial function with the largest moment - ! this function is used to build the linear combinations - rdum = 0 - DO i = 1,hybrid%nindxm1(l,itype) - rdum1 = intgrf(atoms%rmsh(:ng,itype)**(l+1)*hybrid%basm1(:ng,i,l,itype),& - atoms%jri,atoms%jmtd,atoms%rmsh,atoms%dx,atoms%ntype,itype,gridf) - IF( ABS(rdum1) .GT.rdum ) THEN - n = i - rdum = rdum1 - END IF - END DO - - ! rearrange order of radial functions such that the last function possesses the largest moment - j = 0 - bashlp(:ng) = hybrid%basm1(:ng,n,l,itype) - DO i = 1,hybrid%nindxm1(l,itype) - IF( i .EQ. n ) CYCLE - j = j + 1 - hybrid%basm1(:ng,j,l,itype) = hybrid%basm1(:ng,i,l,itype) - END DO - hybrid%basm1(:ng,hybrid%nindxm1(l,itype),l,itype) = bashlp(:ng) - - END DO - - - DO l = 0,hybrid%lcutm1(itype) - IF ( mpi%irank == 0 ) WRITE(6,'(6X,A)') lchar(l)//':' - - IF(hybrid%nindxm1(l,itype).EQ.0) THEN - IF( mpi%irank == 0 ) WRITE(6,'(6X,A,'': 0 -> '')') lchar(l) - CYCLE - END IF - - n = hybrid%nindxm1(l,itype) - DO i = 1,hybrid%nindxm1(l,itype) - IF(i.EQ.n) CYCLE - ! calculate moment of radial function i - rdum1 = intgrf(atoms%rmsh(:ng,itype)**(l+1)*hybrid%basm1(:ng,i,l,itype),& - atoms%jri,atoms%jmtd,atoms%rmsh,atoms%dx,atoms%ntype,itype,gridf) - - rdum = intgrf(atoms%rmsh(:ng,itype)**(l+1)*hybrid%basm1(:ng,n,l,itype),& - atoms%jri,atoms%jmtd,atoms%rmsh,atoms%dx,atoms%ntype,itype,gridf) - - bashlp(:ng) = hybrid%basm1(:ng,n,l,itype) - - IF( SQRT(rdum**2 + rdum1**2) .LE. 1E-06 .AND. mpi%irank == 0)& - WRITE(6,*) 'Warning: Norm is smaller thann 1E-06!' - - ! change function n such that n is orthogonal to i - ! since the functions basm1 have been orthogonal on input - ! the linear combination does not destroy the orthogonality to the residual functions - hybrid%basm1(:ng,n,l,itype) = rdum /SQRT(rdum**2+rdum1**2) * bashlp(:ng)& - + rdum1/SQRT(rdum**2+rdum1**2) * hybrid%basm1(:ng,i,l,itype) - - ! combine basis function i and n so that they possess no momemt - hybrid%basm1(:ng,i,l,itype) = rdum1/SQRT(rdum**2+rdum1**2) * bashlp(:ng)& - - rdum /SQRT(rdum**2+rdum1**2) * hybrid%basm1(:ng,i,l,itype) - - rdum1 = intgrf(atoms%rmsh(:ng,itype)**(l+1)*hybrid%basm1(:ng,i,l,itype),& - atoms%jri,atoms%jmtd,atoms%rmsh,atoms%dx,atoms%ntype,itype,gridf) - - IF( rdum1 .GT. 1E-10 ) call judft_error('moment of radial function does not vanish',calledby='mixedbasis') - - IF ( mpi%irank == 0 ) WRITE(6,'(6x,I4,'' -> '',ES8.1)') i,rdum1 - END DO - - ! test orthogonality - rdum = 0 - DO i = 1,hybrid%nindxm1(l,itype) - DO j = 1,hybrid%nindxm1(l,itype) - rdum1 = intgrf(hybrid%basm1(:ng,i,l,itype)*hybrid%basm1(:ng,j,l,itype),& - atoms%jri,atoms%jmtd,atoms%rmsh,atoms%dx,atoms%ntype,itype,gridf) - IF( i .NE. j ) THEN - rdum = rdum + rdum1 - ELSE - rdum = rdum + ABS(1 - rdum1) - END IF - END DO - END DO - IF ( mpi%irank == 0 )& - WRITE(6,'(6x,I4,'' ->'',f10.5,'' ('',ES8.1,'' )'')') n,& - intgrf(atoms%rmsh(:ng,itype)**(l+1)*hybrid%basm1(:ng,n,l,itype),atoms%jri,& - atoms%jmtd,atoms%rmsh,atoms%dx,atoms%ntype,itype,gridf),rdum - END DO - END DO - - - - DO itype = 1,atoms%ntype - IF ( ANY(hybrid%nindxm1(0:hybrid%lcutm1(itype),itype) == 0) ) call judft_error('any hybrid%nindxm1 eq 0',calledby='mixedbasis') - END DO - - !count basis functions - hybrid%nbasp = 0 - DO itype=1,atoms%ntype - DO i=1,atoms%neq(itype) - DO l=0,hybrid%lcutm1(itype) - DO M=-l,l - DO j=1,hybrid%nindxm1(l,itype) - hybrid%nbasp = hybrid%nbasp + 1 - END DO - END DO - END DO - END DO - END DO - hybrid%maxbasm1 = hybrid%nbasp + hybrid%maxgptm - DO nk = 1,kpts%nkptf - hybrid%nbasm(nk) = hybrid%nbasp + hybrid%ngptm(nk) - END DO - - hybrid%maxlmindx = MAXVAL((/ ( SUM( (/ (hybrid%nindx(l,itype)*(2*l+1), l=0,atoms%lmax(itype)) /) ),itype=1,atoms%ntype) /) ) - - ! - ! - ! Write all information to a file to enable restarting - ! - IF ( l_restart .AND. mpi%irank == 0 ) THEN - - OPEN(UNIT=iounit,FILE=ioname,FORM='unformatted', STATUS='replace') - - WRITE(iounit) kpts%nkptf,hybrid%gptmd - WRITE(iounit) hybrid%maxgptm,hybrid%maxindx - WRITE(iounit) hybrid%ngptm,hybrid%gptm,hybrid%pgptm,hybrid%nindx - - WRITE(iounit) hybrid%maxgptm1,hybrid%maxlcutm1,hybrid%maxindxm1,hybrid%maxindxp1 - WRITE(iounit) hybrid%ngptm1,hybrid%pgptm1,hybrid%nindxm1 - WRITE(iounit) hybrid%basm1 - - - CLOSE(iounit) - - l_restart = .FALSE. - - END IF - - END SUBROUTINE mixedbasis - - - SUBROUTINE read_atompotential(atoms,fname, potential) - - USE m_types - IMPLICIT NONE - TYPE(t_atoms),INTENT(IN) :: atoms - - ! - scalars - - CHARACTER(10),INTENT(IN) :: fname(atoms%ntype) - - ! - arrays - - REAL ,INTENT(OUT):: potential(atoms%jmtd,atoms%ntype) - ! - local scalars - - INTEGER :: i,j,itype,ic,m - REAL :: rdum,r ,n - ! - local arrays - - REAL ,ALLOCATABLE :: v_atom (:),r_atom(:) - - potential =0 - DO itype = 1,atoms%ntype - OPEN(331,file=fname(itype),form='formatted') - - ic = 0 - DO - READ(331,*) rdum - ic = ic + 1 - IF( rdum .GT. (atoms%rmt(itype)+0.2) ) EXIT - END DO - - ALLOCATE( v_atom(ic),r_atom(ic) ) - REWIND(331) - - DO i = 1,ic - READ(331,*) r_atom(i),v_atom(i) - END DO - - ! transfer potential from grid used in the atom program - ! to those used here - DO i = 1,atoms%jri(itype) - r = atoms%rmsh(i,itype) - DO j = 1,ic-1 - IF( r_atom(j) .GT. r ) THEN - M = (v_atom(j)-v_atom(j+1))/(r_atom(j)-r_atom(j+1)) - n = v_atom(j) - M*r_atom(j) - potential(i,itype) =n + M*r - ! WRITE(333,'(4f25.10)') n + m*r_atom(j),v_atom(j),n + m*r_atom(j+1),v_atom(j+1) - EXIT - END IF - END DO - END DO - - DEALLOCATE( v_atom,r_atom ) - CLOSE(331) - END DO - - END SUBROUTINE read_atompotential + END SUBROUTINE read_atompotential END MODULE m_mixedbasis diff --git a/hybrid/olap.F90 b/hybrid/olap.F90 index 460fda4c8750ff4c0abba391315b318a792cd146..4b3bb1ebce30f7ca13d7b8a69d7463f2aefb06f4 100644 --- a/hybrid/olap.F90 +++ b/hybrid/olap.F90 @@ -1,560 +1,541 @@ - MODULE m_olap +MODULE m_olap - CONTAINS +CONTAINS ! Calculates plane-wave overlap matrix olap defined by GPT(1:3,1:NGPT). ! (Muffin-tin spheres are cut out.) ! olap_pw calculates full overlap matrix - SUBROUTINE olap_pw(olap,gpt,ngpt,atoms,cell) - - USE m_constants + SUBROUTINE olap_pw(olap, gpt, ngpt, atoms, cell) + + USE m_constants USE m_types IMPLICIT NONE - TYPE(t_cell),INTENT(IN) :: cell - TYPE(t_atoms),INTENT(IN) :: atoms + TYPE(t_cell), INTENT(IN) :: cell + TYPE(t_atoms), INTENT(IN) :: atoms ! - scalars - - INTEGER,INTENT(IN) :: ngpt + INTEGER, INTENT(IN) :: ngpt ! - arrays - - INTEGER,INTENT(IN) :: gpt(3,ngpt) + INTEGER, INTENT(IN) :: gpt(3, ngpt) TYPE(t_mat) :: olap ! - local - - INTEGER :: i,j,itype,icent,ineq - REAL :: g,r,fgr - COMPLEX,PARAMETER :: img=(0.0,1.0) + INTEGER :: i, j, itype, icent, ineq + REAL :: g, r, fgr + COMPLEX, PARAMETER :: img = (0.0, 1.0) INTEGER :: dg(3) - - - DO i=1,ngpt - DO j=1,i - dg = gpt(:,j)-gpt(:,i) - g = gptnorm(dg,cell%bmat) - IF(g.eq.0) THEN - DO itype=1,atoms%ntype - r = atoms%rmt(itype) - if (olap%l_real) THEN - olap%data_r(i,j) = olap%data_r(i,j) - atoms%neq(itype) *fpi_const*r**3/3/cell%omtil - else - olap%data_c(i,j) = olap%data_c(i,j) - atoms%neq(itype) *fpi_const*r**3/3/cell%omtil - endif - END DO - ELSE - icent = 0 - DO itype=1,atoms%ntype - r = g * atoms%rmt(itype) - fgr = fpi_const* ( sin(r) - r*cos(r) ) /g**3 / cell%omtil - DO ineq=1,atoms%neq(itype) - icent = icent+1 - if (olap%l_real) THEN - olap%data_r(i,j) = olap%data_r(i,j) - fgr * exp(img*tpi_const*dot_product(dg,atoms%taual(:,icent))) - else - olap%data_c(i,j) = olap%data_c(i,j) - fgr * exp(img*tpi_const*dot_product(dg,atoms%taual(:,icent))) - endif - END DO - END DO - END IF - if (olap%l_real) THEN - IF(i.eq.j) olap%data_r(i,j) = olap%data_r(i,j) + 1 - olap%data_r(j,i) = olap%data_r(i,j) - else - IF(i.eq.j) olap%data_c(i,j) = olap%data_c(i,j) + 1 - olap%data_c(j,i) = conjg(olap%data_c(i,j)) - endif - END DO + + DO i = 1, ngpt + DO j = 1, i + dg = gpt(:, j) - gpt(:, i) + g = gptnorm(dg, cell%bmat) + IF (g == 0) THEN + DO itype = 1, atoms%ntype + r = atoms%rmt(itype) + if (olap%l_real) THEN + olap%data_r(i, j) = olap%data_r(i, j) - atoms%neq(itype)*fpi_const*r**3/3/cell%omtil + else + olap%data_c(i, j) = olap%data_c(i, j) - atoms%neq(itype)*fpi_const*r**3/3/cell%omtil + endif + END DO + ELSE + icent = 0 + DO itype = 1, atoms%ntype + r = g*atoms%rmt(itype) + fgr = fpi_const*(sin(r) - r*cos(r))/g**3/cell%omtil + DO ineq = 1, atoms%neq(itype) + icent = icent + 1 + if (olap%l_real) THEN + olap%data_r(i, j) = olap%data_r(i, j) - fgr*exp(img*tpi_const*dot_product(dg, atoms%taual(:, icent))) + else + olap%data_c(i, j) = olap%data_c(i, j) - fgr*exp(img*tpi_const*dot_product(dg, atoms%taual(:, icent))) + endif + END DO + END DO + END IF + if (olap%l_real) THEN + IF (i == j) olap%data_r(i, j) = olap%data_r(i, j) + 1 + olap%data_r(j, i) = olap%data_r(i, j) + else + IF (i == j) olap%data_c(i, j) = olap%data_c(i, j) + 1 + olap%data_c(j, i) = conjg(olap%data_c(i, j)) + endif + END DO END DO - END SUBROUTINE olap_pw + END SUBROUTINE olap_pw -! - - - - - - - - - - - - - - - - - - - - - - - - - - - - - - - - - - - +! - - - - - - - - - - - - - - - - - - - - - - - - - - - - - - - - - - - ! olap_pwp calculates upper triangular part of overlap matrix - SUBROUTINE olap_pwp(l_real,olap_r,olap_c,gpt,ngpt,atoms,cell) - + SUBROUTINE olap_pwp(l_real, olap_r, olap_c, gpt, ngpt, atoms, cell) - USE m_constants + USE m_constants USE m_types IMPLICIT NONE - TYPE(t_cell),INTENT(IN) :: cell - TYPE(t_atoms),INTENT(IN) :: atoms + TYPE(t_cell), INTENT(IN) :: cell + TYPE(t_atoms), INTENT(IN) :: atoms ! - scalars - - INTEGER,INTENT(IN) :: ngpt + INTEGER, INTENT(IN) :: ngpt ! - arrays - - INTEGER,INTENT(IN) :: gpt(3,ngpt) + INTEGER, INTENT(IN) :: gpt(3, ngpt) - LOGICAL,INTENT(IN) :: l_real - REAL,INTENT(OUT) :: olap_r(ngpt*(ngpt+1)/2) - COMPLEX,INTENT(OUT) :: olap_c(ngpt*(ngpt+1)/2) + LOGICAL, INTENT(IN) :: l_real + REAL, INTENT(OUT) :: olap_r(ngpt*(ngpt + 1)/2) + COMPLEX, INTENT(OUT) :: olap_c(ngpt*(ngpt + 1)/2) ! - local - - INTEGER :: i,j,k,itype,icent,ineq - REAL :: g,r,fgr - COMPLEX,PARAMETER :: img=(0.0,1.0) + INTEGER :: i, j, k, itype, icent, ineq + REAL :: g, r, fgr + COMPLEX, PARAMETER :: img = (0.0, 1.0) INTEGER :: dg(3) if (l_real) THEN - k = 0 - DO i=1,ngpt - DO j=1,i - k = k + 1 - dg = gpt(:,i)-gpt(:,j) - g = gptnorm(dg,cell%bmat) - olap_r(k) = 0 - IF(g.eq.0) THEN - DO itype=1,atoms%ntype - r = atoms%rmt(itype) - olap_r(k) = olap_r(k) - atoms%neq(itype) * fpi_const*r**3/3 / cell%omtil - END DO - ELSE - icent = 0 - DO itype=1,atoms%ntype - r = g * atoms%rmt(itype) - fgr = fpi_const* ( sin(r) - r*cos(r) ) /g**3 / cell%omtil - DO ineq=1,atoms%neq(itype) - icent = icent+1 - olap_r(k) = olap_r(k) - fgr * & - & exp( img*tpi_const*dot_product(dg,atoms%taual(:,icent)) ) - END DO + k = 0 + DO i = 1, ngpt + DO j = 1, i + k = k + 1 + dg = gpt(:, i) - gpt(:, j) + g = gptnorm(dg, cell%bmat) + olap_r(k) = 0 + IF (g == 0) THEN + DO itype = 1, atoms%ntype + r = atoms%rmt(itype) + olap_r(k) = olap_r(k) - atoms%neq(itype)*fpi_const*r**3/3/cell%omtil + END DO + ELSE + icent = 0 + DO itype = 1, atoms%ntype + r = g*atoms%rmt(itype) + fgr = fpi_const*(sin(r) - r*cos(r))/g**3/cell%omtil + DO ineq = 1, atoms%neq(itype) + icent = icent + 1 + olap_r(k) = olap_r(k) - fgr* & + & exp(img*tpi_const*dot_product(dg, atoms%taual(:, icent))) + END DO + END DO + END IF + IF (i == j) olap_r(k) = olap_r(k) + 1 END DO - END IF - IF(i.eq.j) olap_r(k) = olap_r(k) + 1 - END DO - END DO -else - k = 0 - DO i=1,ngpt - DO j=1,i - k = k + 1 - dg = gpt(:,i)-gpt(:,j) - g = gptnorm(dg,cell%bmat) - olap_c(k) = 0 - IF(g.eq.0) THEN - DO itype=1,atoms%ntype - r = atoms%rmt(itype) - olap_c(k) = olap_c(k) - atoms%neq(itype) * fpi_const*r**3/3 / cell%omtil - END DO - ELSE - icent = 0 - DO itype=1,atoms%ntype - r = g * atoms%rmt(itype) - fgr = fpi_const* ( sin(r) - r*cos(r) ) /g**3 / cell%omtil - DO ineq=1,atoms%neq(itype) - icent = icent+1 - olap_c(k) = olap_c(k) - fgr * & - & exp( img*tpi_const*dot_product(dg,atoms%taual(:,icent)) ) - END DO + END DO + else + k = 0 + DO i = 1, ngpt + DO j = 1, i + k = k + 1 + dg = gpt(:, i) - gpt(:, j) + g = gptnorm(dg, cell%bmat) + olap_c(k) = 0 + IF (g == 0) THEN + DO itype = 1, atoms%ntype + r = atoms%rmt(itype) + olap_c(k) = olap_c(k) - atoms%neq(itype)*fpi_const*r**3/3/cell%omtil + END DO + ELSE + icent = 0 + DO itype = 1, atoms%ntype + r = g*atoms%rmt(itype) + fgr = fpi_const*(sin(r) - r*cos(r))/g**3/cell%omtil + DO ineq = 1, atoms%neq(itype) + icent = icent + 1 + olap_c(k) = olap_c(k) - fgr* & + & exp(img*tpi_const*dot_product(dg, atoms%taual(:, icent))) + END DO + END DO + END IF + IF (i == j) olap_c(k) = olap_c(k) + 1 END DO - END IF - IF(i.eq.j) olap_c(k) = olap_c(k) + 1 - END DO - END DO + END DO - endif - END SUBROUTINE olap_pwp + endif + END SUBROUTINE olap_pwp + PURE FUNCTION gptnorm(gpt, bmat) + IMPLICIT NONE + REAL :: gptnorm + INTEGER, INTENT(IN) :: gpt(3) + REAL, INTENT(IN) :: bmat(3, 3) - PURE FUNCTION gptnorm(gpt,bmat) - IMPLICIT NONE - REAL :: gptnorm - INTEGER,INTENT(IN) :: gpt(3) - REAL,INTENT(IN) :: bmat(3,3) + gptnorm = sqrt(sum(matmul(gpt(:), bmat(:, :))**2)) - gptnorm = sqrt ( sum ( matmul ( gpt(:),bmat(:,:) ) **2 ) ) - - END FUNCTION gptnorm + END FUNCTION gptnorm ! - - - - - - - - - - - - - - - - - - - - - - - - - - - - - - - - - - - - - SUBROUTINE wfolap_init(olappw,olapmt,gpt,& - & atoms,hybrid,cell,& - & bas1,bas2) - - USE m_util ,ONLY: intgrf,intgrf_init + SUBROUTINE wfolap_init(olappw, olapmt, gpt,& + & atoms, hybrid, cell,& + & bas1, bas2) + + USE m_util, ONLY: intgrf, intgrf_init USE m_types IMPLICIT NONE - TYPE(t_hybrid),INTENT(IN) :: hybrid - TYPE(t_cell),INTENT(IN) :: cell - TYPE(t_atoms),INTENT(IN) :: atoms - + TYPE(t_hybrid), INTENT(IN) :: hybrid + TYPE(t_cell), INTENT(IN) :: cell + TYPE(t_atoms), INTENT(IN) :: atoms + ! - arrays - - INTEGER,INTENT(IN) :: gpt(:,:)!(3,ngpt) - REAL,INTENT(IN) :: bas1(atoms%jmtd,hybrid%maxindx,0:atoms%lmaxd,atoms%ntype),& - & bas2(atoms%jmtd,hybrid%maxindx,0:atoms%lmaxd,atoms%ntype) - REAL,INTENT(OUT) :: olapmt(hybrid%maxindx,hybrid%maxindx,0:atoms%lmaxd,atoms%ntype) - TYPE(t_mat),INTENT(INOUT):: olappw + INTEGER, INTENT(IN) :: gpt(:, :)!(3,ngpt) + REAL, INTENT(IN) :: bas1(atoms%jmtd, hybrid%maxindx, 0:atoms%lmaxd, atoms%ntype),& + & bas2(atoms%jmtd, hybrid%maxindx, 0:atoms%lmaxd, atoms%ntype) + REAL, INTENT(OUT) :: olapmt(hybrid%maxindx, hybrid%maxindx, 0:atoms%lmaxd, atoms%ntype) + TYPE(t_mat), INTENT(INOUT):: olappw ! - local - - INTEGER :: itype,l,nn,n1,n2 + INTEGER :: itype, l, nn, n1, n2 - REAL,ALLOCATABLE :: gridf(:,:) + REAL, ALLOCATABLE :: gridf(:, :) - - CALL intgrf_init(atoms%ntype,atoms%jmtd,atoms%jri,atoms%dx,atoms%rmsh,gridf) + CALL intgrf_init(atoms%ntype, atoms%jmtd, atoms%jri, atoms%dx, atoms%rmsh, gridf) olapmt = 0 - DO itype = 1,atoms%ntype - DO l = 0,atoms%lmax(itype) - nn = hybrid%nindx(l,itype) - DO n2 = 1,nn - DO n1 = 1,nn!n2 - !IF( n1 .gt. 2 .or. n2 .gt. 2) CYCLE - olapmt(n1,n2,l,itype) = intgrf ( & - & bas1(:,n1,l,itype)*bas1(:,n2,l,itype)& - & +bas2(:,n1,l,itype)*bas2(:,n2,l,itype),& - & atoms%jri,atoms%jmtd,atoms%rmsh,atoms%dx,atoms%ntype,itype,gridf) + DO itype = 1, atoms%ntype + DO l = 0, atoms%lmax(itype) + nn = hybrid%nindx(l, itype) + DO n2 = 1, nn + DO n1 = 1, nn!n2 + !IF( n1 .gt. 2 .or. n2 .gt. 2) CYCLE + olapmt(n1, n2, l, itype) = intgrf( & + & bas1(:, n1, l, itype)*bas1(:, n2, l, itype)& + & + bas2(:, n1, l, itype)*bas2(:, n2, l, itype),& + & atoms%jri, atoms%jmtd, atoms%rmsh, atoms%dx, atoms%ntype, itype, gridf) ! olapmt(n2,n1,l,itype) = olapmt(n1,n2,l,itype) + END DO END DO - END DO - END DO + END DO END DO - CALL olap_pw(olappw,gpt,size(gpt,2),atoms,cell) + CALL olap_pw(olappw, gpt, size(gpt, 2), atoms, cell) + + END SUBROUTINE wfolap_init + FUNCTION wfolap_inv(cmt1, cpw1, cmt2, cpw2, ngpt1, ngpt2, olappw, olapmt, atoms, hybrid) - END SUBROUTINE wfolap_init - - - - - FUNCTION wfolap_inv(cmt1,cpw1,cmt2,cpw2,ngpt1,ngpt2,olappw,olapmt,atoms,hybrid) - USE m_wrapper USE m_types IMPLICIT NONE - TYPE(t_hybrid),INTENT(IN) :: hybrid - TYPE(t_atoms),INTENT(IN) :: atoms - + TYPE(t_hybrid), INTENT(IN) :: hybrid + TYPE(t_atoms), INTENT(IN) :: atoms -! - scalars - +! - scalars - COMPLEX :: wfolap_inv - INTEGER,INTENT(IN) :: ngpt1,ngpt2 -! - arrays - - COMPLEX,INTENT(IN) :: cmt1(hybrid%maxlmindx,atoms%nat),& - & cmt2(hybrid%maxlmindx,atoms%nat) - REAL,INTENT(IN) :: cpw1(ngpt1) - COMPLEX,INTENT(IN) :: cpw2(ngpt2) - REAL,INTENT(IN) :: olappw(ngpt1,ngpt2) - REAL,INTENT(IN) :: olapmt(hybrid%maxindx,hybrid%maxindx,0:atoms%lmaxd,atoms%ntype) + INTEGER, INTENT(IN) :: ngpt1, ngpt2 +! - arrays - + COMPLEX, INTENT(IN) :: cmt1(hybrid%maxlmindx, atoms%nat),& + & cmt2(hybrid%maxlmindx, atoms%nat) + REAL, INTENT(IN) :: cpw1(ngpt1) + COMPLEX, INTENT(IN) :: cpw2(ngpt2) + REAL, INTENT(IN) :: olappw(ngpt1, ngpt2) + REAL, INTENT(IN) :: olapmt(hybrid%maxindx, hybrid%maxindx, 0:atoms%lmaxd, atoms%ntype) ! - local - - INTEGER :: itype,ieq,iatom,l,m,lm,nn - COMPLEX :: carr(ngpt1),cdum - REAL :: rarr1(ngpt1),rarr2(ngpt1),rdum1,rdum2 + INTEGER :: itype, ieq, iatom, l, m, lm, nn + COMPLEX :: carr(ngpt1), cdum + REAL :: rarr1(ngpt1), rarr2(ngpt1), rdum1, rdum2 wfolap_inv = 0 - iatom = 0 - DO itype = 1,atoms%ntype - DO ieq = 1,atoms%neq(itype) - iatom = iatom + 1 - lm = 0 - DO l = 0,atoms%lmax(itype) - DO M = -l,l - nn = hybrid%nindx(l,itype) - wfolap_inv = wfolap_inv + & - & dot_product ( cmt1(lm+1:lm+nn,iatom),& - & matmul( olapmt(:nn,:nn,l,itype),& - & cmt2(lm+1:lm+nn,iatom) )) - lm = lm + nn + iatom = 0 + DO itype = 1, atoms%ntype + DO ieq = 1, atoms%neq(itype) + iatom = iatom + 1 + lm = 0 + DO l = 0, atoms%lmax(itype) + DO M = -l, l + nn = hybrid%nindx(l, itype) + wfolap_inv = wfolap_inv + & + & dot_product(cmt1(lm + 1:lm + nn, iatom),& + & matmul(olapmt(:nn, :nn, l, itype),& + & cmt2(lm + 1:lm + nn, iatom))) + lm = lm + nn + END DO END DO - END DO - END DO + END DO END DO - - - wfolap_inv = wfolap_inv + dot_product(cpw1,matmul(olappw,cpw2)) + + wfolap_inv = wfolap_inv + dot_product(cpw1, matmul(olappw, cpw2)) ! CALL dgemv('N',ngpt1,ngpt2,1.0,olappw,ngpt1,real(cpw2),1,0.0,rarr1,1) ! CALL dgemv('N',ngpt1,ngpt2,1.0,olappw,ngpt1,aimag(cpw2),1,0.0,rarr2,1) -! +! ! rdum1 = dotprod(cpw1,rarr1) ! rdum2 = dotprod(cpw1,rarr2) ! cdum = cmplx( rdum1, rdum2 ) ! wfolap = wfolap + cdum - END FUNCTION wfolap_inv - FUNCTION wfolap_noinv(cmt1,cpw1,cmt2,cpw2,ngpt1,ngpt2,olappw,olapmt,atoms,hybrid) - + END FUNCTION wfolap_inv + FUNCTION wfolap_noinv(cmt1, cpw1, cmt2, cpw2, ngpt1, ngpt2, olappw, olapmt, atoms, hybrid) + USE m_wrapper USE m_types IMPLICIT NONE - TYPE(t_hybrid),INTENT(IN) :: hybrid - TYPE(t_atoms),INTENT(IN) :: atoms - + TYPE(t_hybrid), INTENT(IN) :: hybrid + TYPE(t_atoms), INTENT(IN) :: atoms -! - scalars - +! - scalars - COMPLEX :: wfolap_noinv - INTEGER,INTENT(IN) :: ngpt1,ngpt2 -! - arrays - - COMPLEX,INTENT(IN) :: cmt1(hybrid%maxlmindx,atoms%nat),& - & cmt2(hybrid%maxlmindx,atoms%nat) - COMPLEX,INTENT(IN) :: cpw1(ngpt1) - COMPLEX,INTENT(IN) :: cpw2(ngpt2) - COMPLEX,INTENT(IN) :: olappw(ngpt1,ngpt2) - REAL,INTENT(IN) :: olapmt(hybrid%maxindx,hybrid%maxindx,0:atoms%lmaxd,atoms%ntype) + INTEGER, INTENT(IN) :: ngpt1, ngpt2 +! - arrays - + COMPLEX, INTENT(IN) :: cmt1(hybrid%maxlmindx, atoms%nat),& + & cmt2(hybrid%maxlmindx, atoms%nat) + COMPLEX, INTENT(IN) :: cpw1(ngpt1) + COMPLEX, INTENT(IN) :: cpw2(ngpt2) + COMPLEX, INTENT(IN) :: olappw(ngpt1, ngpt2) + REAL, INTENT(IN) :: olapmt(hybrid%maxindx, hybrid%maxindx, 0:atoms%lmaxd, atoms%ntype) ! - local - - INTEGER :: itype,ieq,iatom,l,m,lm,nn - COMPLEX :: carr(ngpt1),cdum - REAL :: rarr1(ngpt1),rarr2(ngpt1),rdum1,rdum2 + INTEGER :: itype, ieq, iatom, l, m, lm, nn + COMPLEX :: carr(ngpt1), cdum + REAL :: rarr1(ngpt1), rarr2(ngpt1), rdum1, rdum2 wfolap_noinv = 0 - iatom = 0 - DO itype = 1,atoms%ntype - DO ieq = 1,atoms%neq(itype) - iatom = iatom + 1 - lm = 0 - DO l = 0,atoms%lmax(itype) - DO M = -l,l - nn = hybrid%nindx(l,itype) - wfolap_noinv = wfolap_noinv + & - & dot_product ( cmt1(lm+1:lm+nn,iatom),& - & matmul( olapmt(:nn,:nn,l,itype),& - & cmt2(lm+1:lm+nn,iatom) )) - lm = lm + nn + iatom = 0 + DO itype = 1, atoms%ntype + DO ieq = 1, atoms%neq(itype) + iatom = iatom + 1 + lm = 0 + DO l = 0, atoms%lmax(itype) + DO M = -l, l + nn = hybrid%nindx(l, itype) + wfolap_noinv = wfolap_noinv + & + & dot_product(cmt1(lm + 1:lm + nn, iatom),& + & matmul(olapmt(:nn, :nn, l, itype),& + & cmt2(lm + 1:lm + nn, iatom))) + lm = lm + nn + END DO END DO - END DO - END DO + END DO END DO - - - wfolap_noinv = wfolap_noinv + dot_product(cpw1,matmul(olappw,cpw2)) + + wfolap_noinv = wfolap_noinv + dot_product(cpw1, matmul(olappw, cpw2)) ! CALL dgemv('N',ngpt1,ngpt2,1.0,olappw,ngpt1,real(cpw2),1,0.0,rarr1,1) ! CALL dgemv('N',ngpt1,ngpt2,1.0,olappw,ngpt1,aimag(cpw2),1,0.0,rarr2,1) -! +! ! rdum1 = dotprod(cpw1,rarr1) ! rdum2 = dotprod(cpw1,rarr2) ! cdum = cmplx( rdum1, rdum2 ) ! wfolap = wfolap + cdum - END FUNCTION wfolap_noinv + END FUNCTION wfolap_noinv + FUNCTION wfolap1(cmt1, cpw1, cmt2, cpw2, ngpt1, ngpt2, olappw, olapmt,& + & atoms, hybrid) - FUNCTION wfolap1(cmt1,cpw1,cmt2,cpw2,ngpt1,ngpt2,olappw,olapmt,& - & atoms,hybrid) - - USE m_types + USE m_types IMPLICIT NONE - - TYPE(t_hybrid),INTENT(IN) :: hybrid - TYPE(t_atoms),INTENT(IN) :: atoms - -! -scalars - + + TYPE(t_hybrid), INTENT(IN) :: hybrid + TYPE(t_atoms), INTENT(IN) :: atoms + +! -scalars - COMPLEX :: wfolap1 - INTEGER,INTENT(IN) :: ngpt1,ngpt2 + INTEGER, INTENT(IN) :: ngpt1, ngpt2 ! - arrays - - COMPLEX,INTENT(IN) :: cmt1(hybrid%maxlmindx,atoms%nat),& - & cmt2(hybrid%maxlmindx,atoms%nat) + COMPLEX, INTENT(IN) :: cmt1(hybrid%maxlmindx, atoms%nat),& + & cmt2(hybrid%maxlmindx, atoms%nat) #if ( defined(CPP_INVERSION) ) - REAL,INTENT(IN) :: cpw1(ngpt1),cpw2(ngpt2) + REAL, INTENT(IN) :: cpw1(ngpt1), cpw2(ngpt2) #else - COMPLEX,INTENT(IN) :: cpw1(ngpt1),cpw2(ngpt2) + COMPLEX, INTENT(IN) :: cpw1(ngpt1), cpw2(ngpt2) #endif #if ( defined(CPP_INVERSION) ) - REAL,INTENT(IN) :: olappw(ngpt1,ngpt2) + REAL, INTENT(IN) :: olappw(ngpt1, ngpt2) #else - COMPLEX,INTENT(IN) :: olappw(ngpt1,ngpt2) + COMPLEX, INTENT(IN) :: olappw(ngpt1, ngpt2) #endif - REAL,INTENT(IN) :: olapmt(hybrid%maxindx,hybrid%maxindx,0:atoms%lmaxd,atoms%ntype) - + REAL, INTENT(IN) :: olapmt(hybrid%maxindx, hybrid%maxindx, 0:atoms%lmaxd, atoms%ntype) + ! - local - - INTEGER :: itype,ieq,iatom,l,m,lm,nn - + INTEGER :: itype, ieq, iatom, l, m, lm, nn + wfolap1 = 0 - iatom = 0 - DO itype = 1,atoms%ntype - DO ieq = 1,atoms%neq(itype) - iatom = iatom + 1 - lm = 0 - DO l = 0,atoms%lmax(itype) - DO M = -l,l - nn = hybrid%nindx(l,itype) - wfolap1 = wfolap1 + & - & dot_product ( cmt1(lm+1:lm+nn,iatom),& - & matmul( olapmt(:nn,:nn,l,itype),& - & cmt2(lm+1:lm+nn,iatom) )) - lm = lm + nn + iatom = 0 + DO itype = 1, atoms%ntype + DO ieq = 1, atoms%neq(itype) + iatom = iatom + 1 + lm = 0 + DO l = 0, atoms%lmax(itype) + DO M = -l, l + nn = hybrid%nindx(l, itype) + wfolap1 = wfolap1 + & + & dot_product(cmt1(lm + 1:lm + nn, iatom),& + & matmul(olapmt(:nn, :nn, l, itype),& + & cmt2(lm + 1:lm + nn, iatom))) + lm = lm + nn + END DO END DO - END DO - END DO + END DO END DO - - wfolap1 = wfolap1 + dot_product(cpw1,matmul(olappw,cpw2)) - - END FUNCTION wfolap1 + wfolap1 = wfolap1 + dot_product(cpw1, matmul(olappw, cpw2)) - FUNCTION wfolap2(cmt1,cpw1,cmt2,cpw2,ngpt1,ngpt2,olappw,olapmt,& - & atoms,hybrid) - USE m_types - IMPLICIT NONE + END FUNCTION wfolap1 - TYPE(t_hybrid),INTENT(IN) :: hybrid - TYPE(t_atoms),INTENT(IN) :: atoms + FUNCTION wfolap2(cmt1, cpw1, cmt2, cpw2, ngpt1, ngpt2, olappw, olapmt,& + & atoms, hybrid) + USE m_types + IMPLICIT NONE + TYPE(t_hybrid), INTENT(IN) :: hybrid + TYPE(t_atoms), INTENT(IN) :: atoms -! - scalars - +! - scalars - COMPLEX :: wfolap2 - INTEGER,INTENT(IN) :: ngpt1,ngpt2 -! - arrays - - COMPLEX,INTENT(IN) :: cmt1(hybrid%maxlmindx,atoms%nat),& - & cmt2(hybrid%maxlmindx,atoms%nat) + INTEGER, INTENT(IN) :: ngpt1, ngpt2 +! - arrays - + COMPLEX, INTENT(IN) :: cmt1(hybrid%maxlmindx, atoms%nat),& + & cmt2(hybrid%maxlmindx, atoms%nat) ! #if ( defined(CPP_INVERSION) ) ! REAL,INTENT(IN) :: cpw1(ngpt1) ! #else - COMPLEX,INTENT(IN) :: cpw1(ngpt1) + COMPLEX, INTENT(IN) :: cpw1(ngpt1) ! #endif - COMPLEX,INTENT(IN) :: cpw2(ngpt2) + COMPLEX, INTENT(IN) :: cpw2(ngpt2) #if ( defined(CPP_INVERSION) ) - REAL,INTENT(IN) :: olappw(ngpt1,ngpt2) + REAL, INTENT(IN) :: olappw(ngpt1, ngpt2) #else - COMPLEX,INTENT(IN) :: olappw(ngpt1,ngpt2) + COMPLEX, INTENT(IN) :: olappw(ngpt1, ngpt2) #endif - REAL,INTENT(IN) :: olapmt(hybrid%maxindx,hybrid%maxindx,0:atoms%lmaxd,atoms%ntype) + REAL, INTENT(IN) :: olapmt(hybrid%maxindx, hybrid%maxindx, 0:atoms%lmaxd, atoms%ntype) ! - local - - INTEGER :: itype,ieq,ic,l,m,lm,nn - + INTEGER :: itype, ieq, ic, l, m, lm, nn + wfolap2 = 0 - ic = 0 - DO itype = 1,atoms%ntype - DO ieq = 1,atoms%neq(itype) - ic = ic + 1 - lm = 0 - DO l = 0,atoms%lmax(itype) - DO M = -l,l - nn = hybrid%nindx(l,itype) - wfolap2 = wfolap2 + & - & dot_product ( cmt1(lm+1:lm+nn,ic),& - & matmul( olapmt(:nn,:nn,l,itype),& - & cmt2(lm+1:lm+nn,ic) ) ) - lm = lm + nn + ic = 0 + DO itype = 1, atoms%ntype + DO ieq = 1, atoms%neq(itype) + ic = ic + 1 + lm = 0 + DO l = 0, atoms%lmax(itype) + DO M = -l, l + nn = hybrid%nindx(l, itype) + wfolap2 = wfolap2 + & + & dot_product(cmt1(lm + 1:lm + nn, ic),& + & matmul(olapmt(:nn, :nn, l, itype),& + & cmt2(lm + 1:lm + nn, ic))) + lm = lm + nn + END DO END DO - END DO - END DO + END DO END DO - - wfolap2 = wfolap2 + dot_product(cpw1,matmul(olappw,cpw2)) - - END FUNCTION wfolap2 -! - - - - - - - - - - - - - - - - - - - - - - - - - - - - - - - - - - - - + wfolap2 = wfolap2 + dot_product(cpw1, matmul(olappw, cpw2)) + + END FUNCTION wfolap2 + +! - - - - - - - - - - - - - - - - - - - - - - - - - - - - - - - - - - - + ! Calculates overlap between core and valence wavefunctions - SUBROUTINE olap_cv(hybrid,kpts,maxlcutc,maxindxc,atoms,& - & lmaxc,lmaxcd,nindxc,& - & core1,core2,bas1,bas2,cmt,dimension,& - & gridf) - - USE m_util ,ONLY: intgrf,intgrf_init,chr + SUBROUTINE olap_cv(hybrid, kpts, maxlcutc, maxindxc, atoms,& + & lmaxc, lmaxcd, nindxc,& + & core1, core2, bas1, bas2, cmt, dimension,& + & gridf) + + USE m_util, ONLY: intgrf, intgrf_init, chr USE m_types IMPLICIT NONE - TYPE(t_dimension),INTENT(IN) :: dimension - TYPE(t_hybrid),INTENT(IN) :: hybrid - TYPE(t_kpts),INTENT(IN) :: kpts - TYPE(t_atoms),INTENT(IN) :: atoms + TYPE(t_dimension), INTENT(IN) :: dimension + TYPE(t_hybrid), INTENT(IN) :: hybrid + TYPE(t_kpts), INTENT(IN) :: kpts + TYPE(t_atoms), INTENT(IN) :: atoms ! - scalars - - INTEGER,INTENT(IN) :: maxlcutc,maxindxc , lmaxcd + INTEGER, INTENT(IN) :: maxlcutc, maxindxc, lmaxcd ! - arrays - - INTEGER,INTENT(IN) :: lmaxc(atoms%ntype) - INTEGER,INTENT(IN) :: nindxc(0:maxlcutc,atoms%ntype) - REAL,INTENT(IN) :: core1(atoms%jmtd,0:lmaxcd,maxindxc,atoms%ntype),& - & core2(atoms%jmtd,0:lmaxcd,maxindxc,atoms%ntype) - REAL,INTENT(IN) :: bas1(atoms%jmtd,hybrid%maxindx,0:atoms%lmaxd,atoms%ntype),& - & bas2(atoms%jmtd,hybrid%maxindx,0:atoms%lmaxd,atoms%ntype) - COMPLEX,INTENT(IN) :: cmt(dimension%neigd,kpts%nkpt,hybrid%maxlmindx,atoms%nat) + INTEGER, INTENT(IN) :: lmaxc(atoms%ntype) + INTEGER, INTENT(IN) :: nindxc(0:maxlcutc, atoms%ntype) + REAL, INTENT(IN) :: core1(atoms%jmtd, 0:lmaxcd, maxindxc, atoms%ntype),& + & core2(atoms%jmtd, 0:lmaxcd, maxindxc, atoms%ntype) + REAL, INTENT(IN) :: bas1(atoms%jmtd, hybrid%maxindx, 0:atoms%lmaxd, atoms%ntype),& + & bas2(atoms%jmtd, hybrid%maxindx, 0:atoms%lmaxd, atoms%ntype) + COMPLEX, INTENT(IN) :: cmt(dimension%neigd, kpts%nkpt, hybrid%maxlmindx, atoms%nat) ! - local scalars - - INTEGER :: itype,icent,l,m,lm,i,j + INTEGER :: itype, icent, l, m, lm, i, j ! - local arrays - - INTEGER,ALLOCATABLE :: olapcv_loc(:,:,:,:,:) - REAL,ALLOCATABLE :: gridf(:,:) - REAL,ALLOCATABLE :: olapcb(:) - REAL,ALLOCATABLE :: olapcv_avg(:,:,:,:),olapcv_max(:,:,:,:) - COMPLEX,ALLOCATABLE :: olapcv(:,:) + INTEGER, ALLOCATABLE :: olapcv_loc(:, :, :, :, :) + REAL, ALLOCATABLE :: gridf(:, :) + REAL, ALLOCATABLE :: olapcb(:) + REAL, ALLOCATABLE :: olapcv_avg(:, :, :, :), olapcv_max(:, :, :, :) + COMPLEX, ALLOCATABLE :: olapcv(:, :) CHARACTER, PARAMETER :: lchar(0:38) =& - & (/'s','p','d','f','g','h','i','j','k','l','m','n','o',& - & 'x','x','x','x','x','x','x','x','x','x','x','x','x',& - & 'x','x','x','x','x','x','x','x','x','x','x','x','x' /) - + & (/'s', 'p', 'd', 'f', 'g', 'h', 'i', 'j', 'k', 'l', 'm', 'n', 'o',& + & 'x', 'x', 'x', 'x', 'x', 'x', 'x', 'x', 'x', 'x', 'x', 'x', 'x',& + & 'x', 'x', 'x', 'x', 'x', 'x', 'x', 'x', 'x', 'x', 'x', 'x', 'x'/) ! CALL intgrf_init(ntype,jmtd,jri,dx,rmsh,gridf) - WRITE(6,'(/A)') 'Overlap ' - ALLOCATE ( olapcb(hybrid%maxindx),olapcv(dimension%neigd,kpts%nkpt),& - & olapcv_avg( -maxlcutc:maxlcutc,maxindxc,0:maxlcutc,atoms%ntype),& - & olapcv_max( -maxlcutc:maxlcutc,maxindxc,0:maxlcutc,atoms%ntype),& - & olapcv_loc(2,-maxlcutc:maxlcutc,maxindxc,0:maxlcutc,atoms%ntype) ) - - DO itype=1,atoms%ntype - IF(atoms%ntype.gt.1) WRITE(6,'(A,I3)') 'Atom type',itype - DO l=0,lmaxc(itype) - IF(l.gt.atoms%lmax(itype)) THEN - WRITE(*,*) 'l greater then atoms%lmax(itype)' - EXIT ! very improbable case - END IF + WRITE (6, '(/A)') 'Overlap ' + ALLOCATE (olapcb(hybrid%maxindx), olapcv(dimension%neigd, kpts%nkpt),& + & olapcv_avg(-maxlcutc:maxlcutc, maxindxc, 0:maxlcutc, atoms%ntype),& + & olapcv_max(-maxlcutc:maxlcutc, maxindxc, 0:maxlcutc, atoms%ntype),& + & olapcv_loc(2, -maxlcutc:maxlcutc, maxindxc, 0:maxlcutc, atoms%ntype)) + + DO itype = 1, atoms%ntype + IF (atoms%ntype > 1) WRITE (6, '(A,I3)') 'Atom type', itype + DO l = 0, lmaxc(itype) + IF (l > atoms%lmax(itype)) THEN + WRITE (*, *) 'l greater then atoms%lmax(itype)' + EXIT ! very improbable case + END IF ! WRITE(6,8001) (lchar(l),i=1,min(3,nindx(l,itype))) - DO i=1,nindxc(l,itype) - WRITE(6,'(I1,A,2X)',advance='no') i+l,lchar(l) - DO j=1,hybrid%nindx(l,itype) - olapcb(j) = intgrf( core1(:,l,i,itype)*bas1(:,j,l,itype)+& - & core2(:,l,i,itype)*bas2(:,j,l,itype),& - & atoms%jri,atoms%jmtd,atoms%rmsh,atoms%dx,atoms%ntype,itype,gridf ) - WRITE(6,'(F10.6)',advance='no') olapcb(j) - ENDDO - - lm = sum ( (/ (hybrid%nindx(j,itype)*(2*j+1),j=0,l-1) /) ) - icent = sum(atoms%neq(1:itype-1))+1 ! take first of group of equivalent atoms - DO M=-l,l - olapcv = 0 - DO j=1,hybrid%nindx(l,itype) - lm = lm + 1 - olapcv(:,:) = olapcv(:,:) + olapcb(j)*cmt(:,:,lm,icent) - END DO - olapcv_avg( M,i,l,itype) = sqrt( sum(abs(olapcv(:,:))**2)& - & /kpts%nkpt/dimension%neigd ) - olapcv_max( M,i,l,itype) = maxval(abs(olapcv(:,:))) - olapcv_loc(:,M,i,l,itype) = maxloc(abs(olapcv(:,:))) + DO i = 1, nindxc(l, itype) + WRITE (6, '(I1,A,2X)', advance='no') i + l, lchar(l) + DO j = 1, hybrid%nindx(l, itype) + olapcb(j) = intgrf(core1(:, l, i, itype)*bas1(:, j, l, itype) +& + & core2(:, l, i, itype)*bas2(:, j, l, itype),& + & atoms%jri, atoms%jmtd, atoms%rmsh, atoms%dx, atoms%ntype, itype, gridf) + WRITE (6, '(F10.6)', advance='no') olapcb(j) + ENDDO + + lm = sum((/(hybrid%nindx(j, itype)*(2*j + 1), j=0, l - 1)/)) + icent = sum(atoms%neq(1:itype - 1)) + 1 ! take first of group of equivalent atoms + DO M = -l, l + olapcv = 0 + DO j = 1, hybrid%nindx(l, itype) + lm = lm + 1 + olapcv(:, :) = olapcv(:, :) + olapcb(j)*cmt(:, :, lm, icent) + END DO + olapcv_avg(M, i, l, itype) = sqrt(sum(abs(olapcv(:, :))**2)& + & /kpts%nkpt/dimension%neigd) + olapcv_max(M, i, l, itype) = maxval(abs(olapcv(:, :))) + olapcv_loc(:, M, i, l, itype) = maxloc(abs(olapcv(:, :))) + END DO + WRITE (6, *) + END DO - WRITE(6,*) - - END DO - END DO + END DO END DO - - WRITE(6,'(/A)') 'Average overlap ' - - DO itype=1,atoms%ntype - IF(atoms%ntype.gt.1) write(6,'(A,I3)') 'Atom type',itype - DO l=0,lmaxc(itype) - DO i=1,nindxc(l,itype) - WRITE(6,'(I1,A,2X)',advance='no') i+l,lchar(l) - WRITE(6,'('//chr(2*l+1)//'F10.6)')olapcv_avg(-l:l,i,l,itype) - END DO - END DO + + WRITE (6, '(/A)') 'Average overlap ' + + DO itype = 1, atoms%ntype + IF (atoms%ntype > 1) write (6, '(A,I3)') 'Atom type', itype + DO l = 0, lmaxc(itype) + DO i = 1, nindxc(l, itype) + WRITE (6, '(I1,A,2X)', advance='no') i + l, lchar(l) + WRITE (6, '('//chr(2*l + 1)//'F10.6)') olapcv_avg(-l:l, i, l, itype) + END DO + END DO END DO - - WRITE(6,'(/A)') 'Maximum overlap at (band/kpoint)' - DO itype=1,atoms%ntype - IF(atoms%ntype.gt.1) write(6,'(A,I3)') 'Atom type',itype - DO l=0,lmaxc(itype) - DO i=1,nindxc(l,itype) - WRITE(6,'(I1,A,2X)',advance='no') i+l,lchar(l) - WRITE(6,'('//chr(2*l+1)//& - & '(F10.6,'' ('',I3.3,''/'',I4.3,'')''))')& - & (olapcv_max( M,i,l,itype),& - & olapcv_loc(:,M,i,l,itype),M=-l,l) - END DO - END DO + + WRITE (6, '(/A)') 'Maximum overlap at (band/kpoint)' + DO itype = 1, atoms%ntype + IF (atoms%ntype > 1) write (6, '(A,I3)') 'Atom type', itype + DO l = 0, lmaxc(itype) + DO i = 1, nindxc(l, itype) + WRITE (6, '(I1,A,2X)', advance='no') i + l, lchar(l) + WRITE (6, '('//chr(2*l + 1)//& + & '(F10.6,'' ('',I3.3,''/'',I4.3,'')''))')& + & (olapcv_max(M, i, l, itype),& + & olapcv_loc(:, M, i, l, itype), M=-l, l) + END DO + END DO END DO - - DEALLOCATE (olapcb,olapcv,olapcv_avg,olapcv_max,olapcv_loc) + DEALLOCATE (olapcb, olapcv, olapcv_avg, olapcv_max, olapcv_loc) - END SUBROUTINE olap_cv + END SUBROUTINE olap_cv - - END MODULE m_olap +END MODULE m_olap diff --git a/hybrid/plot_coulombmatrix.F90 b/hybrid/plot_coulombmatrix.F90 index b1e5a3907473768cbea321dfa45903687768d482..b8be57879b49a8429b29cb89a817a4d99e9ebdd2 100644 --- a/hybrid/plot_coulombmatrix.F90 +++ b/hybrid/plot_coulombmatrix.F90 @@ -1,47 +1,47 @@ ! ! plot matrix ! - IF( l_plot ) THEN - IF ( mpi%isize /= 1 ) STOP 'coulombmatrix: l_plot only works with one process' - DO ikpt = 1,kpts%nkpt + IF (l_plot) THEN + IF (mpi%isize /= 1) STOP 'coulombmatrix: l_plot only works with one process' + DO ikpt = 1, kpts%nkpt ic = 0 - DO i = 1,nbasm1(ikpt) - DO j = 1,i + DO i = 1, nbasm1(ikpt) + DO j = 1, i ic = ic + 1 - IF( ABS(coulomb(ic,ikpt)) .GT. 1E-8 ) THEN - WRITE(600+ikpt,'(2i6)') i,j - WRITE(600+ikpt,'(2i6)') j,i + IF (ABS(coulomb(ic, ikpt)) > 1E-8) THEN + WRITE (600 + ikpt, '(2i6)') i, j + WRITE (600 + ikpt, '(2i6)') j, i END IF END DO END DO - ALLOCATE( coulhlp(nbasm1(ikpt),nbasm1(ikpt)) ) - coulhlp = unpackmat(coulomb(:nbasm1(ikpt)*(nbasm1(ikpt)+1)/2,ikpt) ) + ALLOCATE (coulhlp(nbasm1(ikpt), nbasm1(ikpt))) + coulhlp = unpackmat(coulomb(:nbasm1(ikpt)*(nbasm1(ikpt) + 1)/2, ikpt)) ic = 0 - DO itype = 1,atoms%ntype - DO ineq = 1,atoms%neq(itype) - DO l = 0,hybrid%lcutm1(itype) - DO M = -l,l - WRITE(700+ikpt,*) l,M - DO n = 1,hybrid%nindxm1(l,itype) - WRITE(700+ikpt,'(16f8.4)') coulhlp(ic+n,ic+1:ic+hybrid%nindxm1(l,itype)) + DO itype = 1, atoms%ntype + DO ineq = 1, atoms%neq(itype) + DO l = 0, hybrid%lcutm1(itype) + DO M = -l, l + WRITE (700 + ikpt, *) l, M + DO n = 1, hybrid%nindxm1(l, itype) + WRITE (700 + ikpt, '(16f8.4)') coulhlp(ic + n, ic + 1:ic + hybrid%nindxm1(l, itype)) END DO - ic = ic + hybrid%nindxm1(l,itype) + ic = ic + hybrid%nindxm1(l, itype) ENDDO END DO END DO END DO - ALLOCATE( coulhlp1(nbasm1(ikpt),nbasm1(ikpt)) ) + ALLOCATE (coulhlp1(nbasm1(ikpt), nbasm1(ikpt))) coulhlp1 = 0 ic2 = 0 - DO itype = 1,atoms%ntype - DO ineq = 1,atoms%neq(itype) - DO l = 0,hybrid%lcutm1(itype) - DO M = -l,l - DO n = 1,hybrid%nindxm1(l,itype) - 1 + DO itype = 1, atoms%ntype + DO ineq = 1, atoms%neq(itype) + DO l = 0, hybrid%lcutm1(itype) + DO M = -l, l + DO n = 1, hybrid%nindxm1(l, itype) - 1 ic2 = ic2 + 1 END DO END DO @@ -49,22 +49,22 @@ END DO END DO - ic = 0 + ic = 0 ic1 = 0 - DO itype = 1,atoms%ntype - DO ineq = 1,atoms%neq(itype) - DO l = 0,hybrid%lcutm1(itype) - DO M = -l,l - DO n = 1,hybrid%nindxm1(l,itype) - 1 - coulhlp1(ic+n,ic+1:ic+hybrid%nindxm1(l,itype)-1)& - = coulhlp(ic1+n,ic1+1:ic1+hybrid%nindxm1(l,itype)-1) + DO itype = 1, atoms%ntype + DO ineq = 1, atoms%neq(itype) + DO l = 0, hybrid%lcutm1(itype) + DO M = -l, l + DO n = 1, hybrid%nindxm1(l, itype) - 1 + coulhlp1(ic + n, ic + 1:ic + hybrid%nindxm1(l, itype) - 1) & + = coulhlp(ic1 + n, ic1 + 1:ic1 + hybrid%nindxm1(l, itype) - 1) END DO - coulhlp1(ic2+1,ic+1:ic+hybrid%nindxm1(l,itype)-1)& - = coulhlp(ic1+hybrid%nindxm1(l,itype),ic1+1:ic1+hybrid%nindxm1(l,itype)-1) + coulhlp1(ic2 + 1, ic + 1:ic + hybrid%nindxm1(l, itype) - 1) & + = coulhlp(ic1 + hybrid%nindxm1(l, itype), ic1 + 1:ic1 + hybrid%nindxm1(l, itype) - 1) - ic = ic + hybrid%nindxm1(l,itype)-1 - ic1 = ic1 + hybrid%nindxm1(l,itype) + ic = ic + hybrid%nindxm1(l, itype) - 1 + ic1 = ic1 + hybrid%nindxm1(l, itype) ic2 = ic2 + 1 END DO @@ -72,31 +72,31 @@ END DO END DO - IF( ikpt .EQ. 1 ) THEN + IF (ikpt == 1) THEN ! add contributions from s channel and G=0 component ic = 0; ic1 = 0 - DO itype = 1,atoms%ntype - DO ineq = 1,atoms%neq(itype) - WRITE(*,*) ic+1,ic+hybrid%nindxm1(0,itype)-1,ic1+1,& - ic1+hybrid%nindxm1(0,itype)-1 - coulhlp1(ic+1:ic+hybrid%nindxm1(0,itype)-1,nbasp+1)& - = coulhlp(ic1+1:ic1+hybrid%nindxm1(0,itype)-1,nbasp+1) - coulhlp1(nbasp+1,ic+1:ic+hybrid%nindxm1(0,itype)-1)& - = coulhlp(nbasp+1,ic1+1:ic1+hybrid%nindxm1(0,itype)-1) - ic = ic + SUM( (/ ( (2*l+1)*(hybrid%nindxm1(l,itype)-1),& - l=0,hybrid%lcutm1(itype) ) /) ) - ic1= ic1 + SUM( (/ ( (2*l+1)*hybrid%nindxm1(l,itype),& - l=0,hybrid%lcutm1(itype) ) /) ) + DO itype = 1, atoms%ntype + DO ineq = 1, atoms%neq(itype) + WRITE (*, *) ic + 1, ic + hybrid%nindxm1(0, itype) - 1, ic1 + 1, & + ic1 + hybrid%nindxm1(0, itype) - 1 + coulhlp1(ic + 1:ic + hybrid%nindxm1(0, itype) - 1, nbasp + 1) & + = coulhlp(ic1 + 1:ic1 + hybrid%nindxm1(0, itype) - 1, nbasp + 1) + coulhlp1(nbasp + 1, ic + 1:ic + hybrid%nindxm1(0, itype) - 1) & + = coulhlp(nbasp + 1, ic1 + 1:ic1 + hybrid%nindxm1(0, itype) - 1) + ic = ic + SUM((/((2*l + 1)*(hybrid%nindxm1(l, itype) - 1), & + l=0, hybrid%lcutm1(itype))/)) + ic1 = ic1 + SUM((/((2*l + 1)*hybrid%nindxm1(l, itype), & + l=0, hybrid%lcutm1(itype))/)) END DO END DO ic2 = 0 - DO itype = 1,atoms%ntype - DO ineq = 1,atoms%neq(itype) - DO l = 0,hybrid%lcutm1(itype) - DO M = -l,l - DO n = 1,hybrid%nindxm1(l,itype) - 1 + DO itype = 1, atoms%ntype + DO ineq = 1, atoms%neq(itype) + DO l = 0, hybrid%lcutm1(itype) + DO M = -l, l + DO n = 1, hybrid%nindxm1(l, itype) - 1 ic2 = ic2 + 1 END DO END DO @@ -105,41 +105,40 @@ END DO ic1 = 0 - DO itype = 1,atoms%ntype - DO ineq = 1,atoms%neq(itype) - DO l = 0,hybrid%lcutm1(itype) - DO M = -l,l + DO itype = 1, atoms%ntype + DO ineq = 1, atoms%neq(itype) + DO l = 0, hybrid%lcutm1(itype) + DO M = -l, l ic2 = ic2 + 1 - ic1 = ic1 + hybrid%nindxm1(l,itype) + ic1 = ic1 + hybrid%nindxm1(l, itype) - IF( l .NE. 0 ) CYCLE - WRITE(900,*) ic2,ic1,itype,ineq + IF (l /= 0) CYCLE + WRITE (900, *) ic2, ic1, itype, ineq ic3 = 0 ic4 = 0 - DO itype1 = 1,atoms%ntype - ishift = SUM( (/ ( (2*l2+1)* hybrid%nindxm1(l2,itype1) ,& - l2 = 0,hybrid%lcutm1(itype1) ) /) ) - ishift1= SUM( (/ ( (2*l2+1)*(hybrid%nindxm1(l2,itype1)-1),& - l2 = 0,hybrid%lcutm1(itype1) ) /) ) - DO ineq1 = 1,atoms%neq(itype1) + DO itype1 = 1, atoms%ntype + ishift = SUM((/((2*l2 + 1)*hybrid%nindxm1(l2, itype1), & + l2=0, hybrid%lcutm1(itype1))/)) + ishift1 = SUM((/((2*l2 + 1)*(hybrid%nindxm1(l2, itype1) - 1), & + l2=0, hybrid%lcutm1(itype1))/)) + DO ineq1 = 1, atoms%neq(itype1) ic5 = ic3 + (ineq1 - 1)*ishift + 1 - ic6 = ic5 + hybrid%nindxm1(0,itype1) - 2 + ic6 = ic5 + hybrid%nindxm1(0, itype1) - 2 ic7 = ic4 + (ineq1 - 1)*ishift1 + 1 - ic8 = ic7 + hybrid%nindxm1(0,itype1) - 2 - WRITE(901,*)ic2,ic7,ic8,ic1,ic5,ic6,itype,itype1 - + ic8 = ic7 + hybrid%nindxm1(0, itype1) - 2 + WRITE (901, *) ic2, ic7, ic8, ic1, ic5, ic6, itype, itype1 - coulhlp1(ic2,ic7:ic8) = coulhlp(ic1,ic5:ic6) - IF(sym%invs) THEN - coulhlp1(ic7:ic8,ic2) = coulhlp1(ic2,ic7:ic8) + coulhlp1(ic2, ic7:ic8) = coulhlp(ic1, ic5:ic6) + IF (sym%invs) THEN + coulhlp1(ic7:ic8, ic2) = coulhlp1(ic2, ic7:ic8) ELSE - coulhlp1(ic7:ic8,ic2) = CONJG(coulhlp1(ic2,ic7:ic8)) + coulhlp1(ic7:ic8, ic2) = CONJG(coulhlp1(ic2, ic7:ic8)) ENDIF END DO - ic3 = ic3 + ishift *atoms%neq(itype1) + ic3 = ic3 + ishift*atoms%neq(itype1) ic4 = ic4 + ishift1*atoms%neq(itype1) END DO @@ -151,11 +150,11 @@ END IF ic2 = 0 - DO itype = 1,atoms%ntype - DO ineq = 1,atoms%neq(itype) - DO l = 0,hybrid%lcutm1(itype) - DO M = -l,l - DO n = 1,hybrid%nindxm1(l,itype) - 1 + DO itype = 1, atoms%ntype + DO ineq = 1, atoms%neq(itype) + DO l = 0, hybrid%lcutm1(itype) + DO M = -l, l + DO n = 1, hybrid%nindxm1(l, itype) - 1 ic2 = ic2 + 1 END DO END DO @@ -164,28 +163,28 @@ END DO ic1 = 0 - DO itype = 1,atoms%ntype - DO ineq = 1,atoms%neq(itype) - DO l = 0,hybrid%lcutm1(itype) - DO M = -l,l + DO itype = 1, atoms%ntype + DO ineq = 1, atoms%neq(itype) + DO l = 0, hybrid%lcutm1(itype) + DO M = -l, l ic2 = ic2 + 1 - ic1 = ic1 + hybrid%nindxm1(l,itype) + ic1 = ic1 + hybrid%nindxm1(l, itype) ic3 = 0 ic4 = ic2 - DO itype1 = 1,atoms%ntype - DO ineq1 = 1,atoms%neq(itype1) - DO l1 = 0,hybrid%lcutm1(itype1) - DO m1 = -l1,l1 - ic3 = ic3 + hybrid%nindxm1(l1,itype1) - IF( ic3 .LT. ic1 ) CYCLE - WRITE(300,'(4i6,2f15.10)') ic2,ic4,ic1,ic3,coulhlp(ic1,ic3) - coulhlp1(ic2,ic4) = coulhlp(ic1,ic3) - IF (sym%invs) THEN - coulhlp1(ic4,ic2) = coulhlp1(ic2,ic4) + DO itype1 = 1, atoms%ntype + DO ineq1 = 1, atoms%neq(itype1) + DO l1 = 0, hybrid%lcutm1(itype1) + DO m1 = -l1, l1 + ic3 = ic3 + hybrid%nindxm1(l1, itype1) + IF (ic3 < ic1) CYCLE + WRITE (300, '(4i6,2f15.10)') ic2, ic4, ic1, ic3, coulhlp(ic1, ic3) + coulhlp1(ic2, ic4) = coulhlp(ic1, ic3) + IF (sym%invs) THEN + coulhlp1(ic4, ic2) = coulhlp1(ic2, ic4) ELSE - coulhlp1(ic4,ic2) = CONJG(coulhlp1(ic2,ic4)) + coulhlp1(ic4, ic2) = CONJG(coulhlp1(ic2, ic4)) ENDIF ic4 = ic4 + 1 END DO @@ -193,12 +192,12 @@ END DO END DO - DO igpt = 1,hybrid%ngptm(ikpt) - coulhlp1(ic2,ic4) = coulhlp(ic1,nbasp+igpt) - IF (sym%invs) THEN - coulhlp1(ic4,ic2) = coulhlp1(ic2,ic4) + DO igpt = 1, hybrid%ngptm(ikpt) + coulhlp1(ic2, ic4) = coulhlp(ic1, nbasp + igpt) + IF (sym%invs) THEN + coulhlp1(ic4, ic2) = coulhlp1(ic2, ic4) ELSE - coulhlp1(ic4,ic2) = CONJG(coulhlp1(ic2,ic4)) + coulhlp1(ic4, ic2) = CONJG(coulhlp1(ic2, ic4)) ENDIF ic4 = ic4 + 1 END DO @@ -208,34 +207,34 @@ END DO END DO - coulhlp1(nbasp+1:,nbasp+1:) = coulhlp(nbasp+1:,nbasp+1:) + coulhlp1(nbasp + 1:, nbasp + 1:) = coulhlp(nbasp + 1:, nbasp + 1:) ic = 0 - DO itype = 1,atoms%ntype - DO ineq = 1,atoms%neq(itype) - DO l = 0,hybrid%lcutm1(itype) - - DO M = -l,l - WRITE(800+ikpt,*) l,M - DO n = 1,hybrid%nindxm1(l,itype)-1 - WRITE(800+ikpt,'(16f8.4)') coulhlp1(ic+n,ic+1:ic+hybrid%nindxm1(l,itype)-1) + DO itype = 1, atoms%ntype + DO ineq = 1, atoms%neq(itype) + DO l = 0, hybrid%lcutm1(itype) + + DO M = -l, l + WRITE (800 + ikpt, *) l, M + DO n = 1, hybrid%nindxm1(l, itype) - 1 + WRITE (800 + ikpt, '(16f8.4)') coulhlp1(ic + n, ic + 1:ic + hybrid%nindxm1(l, itype) - 1) END DO - ic = ic + hybrid%nindxm1(l,itype)-1 + ic = ic + hybrid%nindxm1(l, itype) - 1 ENDDO END DO END DO END DO ic = 0 - DO i = 1,nbasm1(ikpt) - DO j = 1,i - IF( ABS(coulhlp1(i,j)) .GT. 1E-8 ) THEN - WRITE(850+ikpt,'(2i6)') i,j - WRITE(850+ikpt,'(2i6)') j,i + DO i = 1, nbasm1(ikpt) + DO j = 1, i + IF (ABS(coulhlp1(i, j)) > 1E-8) THEN + WRITE (850 + ikpt, '(2i6)') i, j + WRITE (850 + ikpt, '(2i6)') j, i END IF END DO END DO - DEALLOCATE( coulhlp,coulhlp1 ) + DEALLOCATE (coulhlp, coulhlp1) END DO STOP END IF ! lplot diff --git a/hybrid/read_core.F90 b/hybrid/read_core.F90 index 1f696eee69805ffb6ff46e2a03876770486a8618..e8f07b946c57c3fce5de26f37658d5184bb68314 100644 --- a/hybrid/read_core.F90 +++ b/hybrid/read_core.F90 @@ -1,545 +1,512 @@ - MODULE m_read_core +MODULE m_read_core - ! read core radial wavefunctions from corebas - ! corebas is written in cored.F - ! (core basis functions can be read in once during an iteration) + ! read core radial wavefunctions from corebas + ! corebas is written in cored.F + ! (core basis functions can be read in once during an iteration) - CONTAINS +CONTAINS - SUBROUTINE read_core( atoms, hybdat ) + SUBROUTINE read_core(atoms, hybdat) - - USE m_types + USE m_types IMPLICIT NONE - TYPE(t_hybdat),INTENT(INOUT) :: hybdat - TYPE(t_atoms),INTENT(IN) :: atoms - + TYPE(t_hybdat), INTENT(INOUT) :: hybdat + TYPE(t_atoms), INTENT(IN) :: atoms ! - local scalars - INTEGER :: ncst - INTEGER :: ok,itype,i,idum,l + INTEGER :: ok, itype, i, idum, l REAL :: rdum - REAL :: weight1,weight2 + REAL :: weight1, weight2 ! - local arrays - - INTEGER,ALLOCATABLE :: nindxcr(:,:) - INTEGER,ALLOCATABLE :: l_qn(:,:),n_qn(:,:) + INTEGER, ALLOCATABLE :: nindxcr(:, :) + INTEGER, ALLOCATABLE :: l_qn(:, :), n_qn(:, :) - REAL,ALLOCATABLE :: j_qn(:,:) - REAL,ALLOCATABLE :: core1r(:,:,:,:),& - & core2r(:,:,:,:) + REAL, ALLOCATABLE :: j_qn(:, :) + REAL, ALLOCATABLE :: core1r(:, :, :, :),& + & core2r(:, :, :, :) + OPEN (UNIT=77, FILE='corebas', FORM='unformatted') + READ (77) ncst - OPEN(UNIT=77,FILE='corebas',FORM='unformatted') - READ(77) ncst - - - ALLOCATE( n_qn(0:ncst,atoms%ntype) , l_qn(0:ncst,atoms%ntype) , & - & j_qn(0:ncst,atoms%ntype) , stat=ok ) - IF( ok .ne. 0 ) STOP 'mhsfock: failure allocation n_qn,l_qn,j_qn' - ALLOCATE( nindxcr(0:ncst,atoms%ntype),stat = ok ) - IF( ok .ne. 0 ) STOP 'mhsfock: failure allocation nindxcr' + ALLOCATE (n_qn(0:ncst, atoms%ntype), l_qn(0:ncst, atoms%ntype), & + & j_qn(0:ncst, atoms%ntype), stat=ok) + IF (ok /= 0) STOP 'mhsfock: failure allocation n_qn,l_qn,j_qn' + ALLOCATE (nindxcr(0:ncst, atoms%ntype), stat=ok) + IF (ok /= 0) STOP 'mhsfock: failure allocation nindxcr' nindxcr = 0 - hybdat%lmaxc = 0 - l_qn = 0 - ncst = 0 - DO itype=1,atoms%ntype - READ(77) ncst - IF( ncst .eq. 0 ) CYCLE - DO i=1,ncst - READ(77) n_qn(i,itype),l_qn(i,itype),j_qn(i,itype) - nindxcr(l_qn(i,itype),itype) = nindxcr(l_qn(i,itype),itype)+1 - END DO - hybdat%lmaxc(itype) = maxval(l_qn(:,itype)) + hybdat%lmaxc = 0 + l_qn = 0 + ncst = 0 + DO itype = 1, atoms%ntype + READ (77) ncst + IF (ncst == 0) CYCLE + DO i = 1, ncst + READ (77) n_qn(i, itype), l_qn(i, itype), j_qn(i, itype) + nindxcr(l_qn(i, itype), itype) = nindxcr(l_qn(i, itype), itype) + 1 + END DO + hybdat%lmaxc(itype) = maxval(l_qn(:, itype)) END DO - - - ALLOCATE( core1r(atoms%jmtd,0:maxval(hybdat%lmaxc),maxval(nindxcr),atoms%ntype) ) - ALLOCATE( core2r(atoms%jmtd,0:maxval(hybdat%lmaxc),maxval(nindxcr),atoms%ntype) ) + ALLOCATE (core1r(atoms%jmtd, 0:maxval(hybdat%lmaxc), maxval(nindxcr), atoms%ntype)) + ALLOCATE (core2r(atoms%jmtd, 0:maxval(hybdat%lmaxc), maxval(nindxcr), atoms%ntype)) core1r = 0 core2r = 0 - REWIND(77) + REWIND (77) - DEALLOCATE( nindxcr ) - ALLOCATE( nindxcr(0:maxval(l_qn),atoms%ntype)) + DEALLOCATE (nindxcr) + ALLOCATE (nindxcr(0:maxval(l_qn), atoms%ntype)) nindxcr = 0 - READ(77) idum - DO itype=1,atoms%ntype - READ(77) ncst - DO i=1,ncst - nindxcr(l_qn(i,itype),itype) = nindxcr(l_qn(i,itype),itype)+1 - READ(77) idum,idum,rdum,core1r(:atoms%jri(itype),l_qn(i,itype),& - & nindxcr(l_qn(i,itype),itype),itype),& - & core2r(:atoms%jri(itype),l_qn(i,itype),& - & nindxcr(l_qn(i,itype),itype),itype) - END DO + READ (77) idum + DO itype = 1, atoms%ntype + READ (77) ncst + DO i = 1, ncst + nindxcr(l_qn(i, itype), itype) = nindxcr(l_qn(i, itype), itype) + 1 + READ (77) idum, idum, rdum, core1r(:atoms%jri(itype), l_qn(i, itype),& + & nindxcr(l_qn(i, itype), itype), itype),& + & core2r(:atoms%jri(itype), l_qn(i, itype),& + & nindxcr(l_qn(i, itype), itype), itype) + END DO END DO - - - ALLOCATE( hybdat%nindxc(0:maxval(hybdat%lmaxc),atoms%ntype),stat=ok ) - IF( ok .ne. 0 ) STOP 'mhsfock: failure allocation nindxc' - ALLOCATE( hybdat%core1(atoms%jmtd,0:maxval(hybdat%lmaxc),maxval(nindxcr(0,:),& - & nint((maxval(nindxcr)/2.0))),atoms%ntype),stat=ok ) - IF( ok .ne. 0 ) STOP 'mhsfock: failure allocation core1' - ALLOCATE( hybdat%core2(atoms%jmtd,0:maxval(hybdat%lmaxc),maxval(nindxcr(0,:),& - & nint((maxval(nindxcr)/2.0))),atoms%ntype),stat=ok ) - IF( ok .ne. 0 ) STOP 'mhsfock: failure allocation core2' - hybdat%nindxc = 0 ; hybdat%core1 = 0 ; hybdat%core2 = 0 + ALLOCATE (hybdat%nindxc(0:maxval(hybdat%lmaxc), atoms%ntype), stat=ok) + IF (ok /= 0) STOP 'mhsfock: failure allocation nindxc' + ALLOCATE (hybdat%core1(atoms%jmtd, 0:maxval(hybdat%lmaxc), maxval(nindxcr(0, :),& + & nint((maxval(nindxcr)/2.0))), atoms%ntype), stat=ok) + IF (ok /= 0) STOP 'mhsfock: failure allocation core1' + ALLOCATE (hybdat%core2(atoms%jmtd, 0:maxval(hybdat%lmaxc), maxval(nindxcr(0, :),& + & nint((maxval(nindxcr)/2.0))), atoms%ntype), stat=ok) + IF (ok /= 0) STOP 'mhsfock: failure allocation core2' + hybdat%nindxc = 0; hybdat%core1 = 0; hybdat%core2 = 0 ! average over core states that only differ in j ! core functions with l-qn equal 0 doesnot change during averaging - hybdat%nindxc(0,:) = nindxcr(0,:) - DO itype=1,atoms%ntype - hybdat%core1(:,0,:hybdat%nindxc(0,itype),itype)& - & = core1r(:,0,:hybdat%nindxc(0,itype),itype) - hybdat%core2(:,0,:hybdat%nindxc(0,itype),itype)& - & = core2r(:,0,:hybdat%nindxc(0,itype),itype) + hybdat%nindxc(0, :) = nindxcr(0, :) + DO itype = 1, atoms%ntype + hybdat%core1(:, 0, :hybdat%nindxc(0, itype), itype)& + & = core1r(:, 0, :hybdat%nindxc(0, itype), itype) + hybdat%core2(:, 0, :hybdat%nindxc(0, itype), itype)& + & = core2r(:, 0, :hybdat%nindxc(0, itype), itype) END DO + DO itype = 1, atoms%ntype + DO l = 1, hybdat%lmaxc(itype) + weight1 = 2*(l - 0.5) + 1 + weight2 = 2*(l + 0.5) + 1 + IF (modulo(nindxcr(l, itype), 2) == 0) THEN + DO i = 1, nindxcr(l, itype), 2 + hybdat%nindxc(l, itype) = hybdat%nindxc(l, itype) + 1 + hybdat%core1(:atoms%jri(itype), l, hybdat%nindxc(l, itype), itype) =& + & (weight1*core1r(:atoms%jri(itype), l, i, itype) +& + & weight2*core1r(:atoms%jri(itype), l, i + 1, itype))& + & /(weight1 + weight2) + hybdat%core2(:atoms%jri(itype), l, hybdat%nindxc(l, itype), itype) =& + & (weight1*core2r(:atoms%jri(itype), l, i, itype) +& + & weight2*core2r(:atoms%jri(itype), l, i + 1, itype))& + & /(weight1 + weight2) + END DO + ELSE + DO i = 1, nindxcr(l, itype) - 1, 2 + hybdat%nindxc(l, itype) = hybdat%nindxc(l, itype) + 1 + hybdat%core1(:atoms%jri(itype), l, hybdat%nindxc(l, itype), itype) =& + & (weight1*core1r(:atoms%jri(itype), l, i, itype) +& + & weight2*core1r(:atoms%jri(itype), l, i + 1, itype))& + & /(weight1 + weight2) + hybdat%core2(:atoms%jri(itype), l, hybdat%nindxc(l, itype), itype) =& + & (weight1*core2r(:atoms%jri(itype), l, i, itype) +& + & weight2*core2r(:atoms%jri(itype), l, i + 1, itype))& + & /(weight1 + weight2) + END DO + hybdat%nindxc(l, itype) = hybdat%nindxc(l, itype) + 1 + hybdat%core1(:atoms%jri(itype), l, hybdat%nindxc(l, itype), itype)& + & = core1r(:atoms%jri(itype), l, nindxcr(l, itype), itype) + hybdat%core2(:atoms%jri(itype), l, hybdat%nindxc(l, itype), itype)& + & = core2r(:atoms%jri(itype), l, nindxcr(l, itype), itype) + END IF - DO itype=1,atoms%ntype - DO l=1,hybdat%lmaxc(itype) - weight1 = 2*(l-0.5) + 1 - weight2 = 2*(l+0.5) + 1 - IF( modulo(nindxcr(l,itype),2) .eq. 0 ) THEN - DO i=1,nindxcr(l,itype),2 - hybdat%nindxc(l,itype) = hybdat%nindxc(l,itype) + 1 - hybdat%core1(:atoms%jri(itype),l,hybdat%nindxc(l,itype),itype) =& - & (weight1*core1r(:atoms%jri(itype),l,i ,itype) +& - & weight2*core1r(:atoms%jri(itype),l,i+1,itype))& - & / (weight1+weight2) - hybdat%core2(:atoms%jri(itype),l,hybdat%nindxc(l,itype),itype) =& - & (weight1*core2r(:atoms%jri(itype),l,i ,itype) +& - & weight2*core2r(:atoms%jri(itype),l,i+1,itype))& - & / (weight1+weight2) - END DO - ELSE - DO i=1,nindxcr(l,itype)-1,2 - hybdat%nindxc(l,itype) = hybdat%nindxc(l,itype) + 1 - hybdat%core1(:atoms%jri(itype),l,hybdat%nindxc(l,itype),itype) =& - & (weight1*core1r(:atoms%jri(itype),l,i ,itype) +& - & weight2*core1r(:atoms%jri(itype),l,i+1,itype))& - & / (weight1+weight2) - hybdat%core2(:atoms%jri(itype),l,hybdat%nindxc(l,itype),itype) =& - & (weight1*core2r(:atoms%jri(itype),l,i ,itype) +& - & weight2*core2r(:atoms%jri(itype),l,i+1,itype))& - & / (weight1+weight2) - END DO - hybdat%nindxc(l,itype) = hybdat%nindxc(l,itype) + 1 - hybdat%core1(:atoms%jri(itype),l,hybdat%nindxc(l,itype),itype)& - & = core1r(:atoms%jri(itype),l,nindxcr(l,itype),itype) - hybdat%core2(:atoms%jri(itype),l,hybdat%nindxc(l,itype),itype)& - & = core2r(:atoms%jri(itype),l,nindxcr(l,itype),itype) - END IF - - END DO + END DO END DO - DEALLOCATE( nindxcr, core1r,core2r ) + DEALLOCATE (nindxcr, core1r, core2r) hybdat%maxindxc = maxval(hybdat%nindxc) - CLOSE(77) - - END SUBROUTINE read_core - + CLOSE (77) + END SUBROUTINE read_core - - - - - SUBROUTINE corewf( atoms,jsp,input,dimension,& - & vr, lmaxcd,maxindxc,mpi, lmaxc,nindxc,core1,core2,eig_c) + SUBROUTINE corewf(atoms, jsp, input, dimension,& + & vr, lmaxcd, maxindxc, mpi, lmaxc, nindxc, core1, core2, eig_c) USE m_types IMPLICIT NONE - TYPE(t_mpi),INTENT(IN) :: mpi - TYPE(t_dimension),INTENT(IN) :: dimension - TYPE(t_input),INTENT(IN) :: input - TYPE(t_atoms),INTENT(IN) :: atoms + TYPE(t_mpi), INTENT(IN) :: mpi + TYPE(t_dimension), INTENT(IN) :: dimension + TYPE(t_input), INTENT(IN) :: input + TYPE(t_atoms), INTENT(IN) :: atoms ! - scalars - - INTEGER,INTENT(IN) :: jsp - INTEGER,INTENT(IN) :: lmaxcd - INTEGER,INTENT(INOUT) :: maxindxc + INTEGER, INTENT(IN) :: jsp + INTEGER, INTENT(IN) :: lmaxcd + INTEGER, INTENT(INOUT) :: maxindxc ! -arrays - - INTEGER,INTENT(INOUT) :: lmaxc(:) - INTEGER,INTENT(INOUT) :: nindxc(0:lmaxcd,atoms%ntype) + INTEGER, INTENT(INOUT) :: lmaxc(:) + INTEGER, INTENT(INOUT) :: nindxc(0:lmaxcd, atoms%ntype) - REAL , INTENT(IN) :: vr(:,:,:)!(atoms%jmtd,atoms%ntypd,input%jspins) - REAL , INTENT(INOUT) :: core1(:,:,0:,:) !(atoms%jmtd,maxindxc,0:lmaxcd,atoms%ntype) - REAL , INTENT(INOUT) :: core2(:,:,0:,:) !(jmtd,maxindxc,0:lmaxcd,ntype) + REAL, INTENT(IN) :: vr(:, :, :)!(atoms%jmtd,atoms%ntypd,input%jspins) + REAL, INTENT(INOUT) :: core1(:, :, 0:, :) !(atoms%jmtd,maxindxc,0:lmaxcd,atoms%ntype) + REAL, INTENT(INOUT) :: core2(:, :, 0:, :) !(jmtd,maxindxc,0:lmaxcd,ntype) - REAL , INTENT(INOUT) :: eig_c(maxindxc,0:lmaxcd,atoms%ntype) + REAL, INTENT(INOUT) :: eig_c(maxindxc, 0:lmaxcd, atoms%ntype) ! - local scalars - INTEGER :: ncstd - INTEGER :: ok,itype,i,j,idum,l + INTEGER :: ok, itype, i, j, idum, l REAL :: rdum - REAL :: weight1,weight2 + REAL :: weight1, weight2 ! - local arrays - - INTEGER,ALLOCATABLE :: nindxcr(:,:) - INTEGER,ALLOCATABLE :: l_qn(:,:),n_qn(:,:) + INTEGER, ALLOCATABLE :: nindxcr(:, :) + INTEGER, ALLOCATABLE :: l_qn(:, :), n_qn(:, :) - REAL,ALLOCATABLE :: j_qn(:,:) - REAL,ALLOCATABLE :: core1r(:,:,:,:),core2r(:,:,:,:) - REAL,ALLOCATABLE :: core11r(:,:,:,:),core22r(:,:,:,:) - REAL,ALLOCATABLE :: eig_cr(:,:,:) + REAL, ALLOCATABLE :: j_qn(:, :) + REAL, ALLOCATABLE :: core1r(:, :, :, :), core2r(:, :, :, :) + REAL, ALLOCATABLE :: core11r(:, :, :, :), core22r(:, :, :, :) + REAL, ALLOCATABLE :: eig_cr(:, :, :) ncstd = maxval(atoms%ncst) - ALLOCATE( nindxcr(0:ncstd,atoms%ntype),stat = ok ) + ALLOCATE (nindxcr(0:ncstd, atoms%ntype), stat=ok) ! generate relativistic core wave functions( ->core1r,core2r ) - CALL calcorewf( dimension,input,jsp,atoms,& - & ncstd,vr,& - & lmaxc,nindxcr,core1r,core2r,eig_cr,mpi) - + CALL calcorewf(dimension, input, jsp, atoms,& + & ncstd, vr,& + & lmaxc, nindxcr, core1r, core2r, eig_cr, mpi) nindxc = 0 ! average over core states that only differ in j ! core functions with l-qn equal 0 doesnot change during the average process - - nindxc(0,:) = nindxcr(0,:) - DO itype=1,atoms%ntype - core1(:,:nindxc(0,itype),0,itype)& - & = core1r(:,0,:nindxc(0,itype),itype) - core2(:,:nindxc(0,itype),0,itype)& - & = core2r(:,0,:nindxc(0,itype),itype) - eig_c(:nindxc(0,itype),0,itype)& - & = eig_cr(0,:nindxc(0,itype),itype) + + nindxc(0, :) = nindxcr(0, :) + DO itype = 1, atoms%ntype + core1(:, :nindxc(0, itype), 0, itype)& + & = core1r(:, 0, :nindxc(0, itype), itype) + core2(:, :nindxc(0, itype), 0, itype)& + & = core2r(:, 0, :nindxc(0, itype), itype) + eig_c(:nindxc(0, itype), 0, itype)& + & = eig_cr(0, :nindxc(0, itype), itype) END DO + DO itype = 1, atoms%ntype + DO l = 1, lmaxc(itype) + weight1 = 2*(l - 0.5) + 1 + weight2 = 2*(l + 0.5) + 1 + IF (modulo(nindxcr(l, itype), 2) == 0) THEN + DO i = 1, nindxcr(l, itype), 2 + nindxc(l, itype) = nindxc(l, itype) + 1 + core1(:atoms%jri(itype), nindxc(l, itype), l, itype) =& + & (weight1*core1r(:atoms%jri(itype), l, i, itype) +& + & weight2*core1r(:atoms%jri(itype), l, i + 1, itype))& + & /(weight1 + weight2) + core2(:atoms%jri(itype), nindxc(l, itype), l, itype) =& + & (weight1*core2r(:atoms%jri(itype), l, i, itype) + & + & weight2*core2r(:atoms%jri(itype), l, i + 1, itype))& + & /(weight1 + weight2) + + eig_c(nindxc(l, itype), l, itype) =& + & (weight1*eig_cr(l, i, itype) +& + & weight2*eig_cr(l, i + 1, itype))& + & /(weight1 + weight2) + END DO + ELSE + DO i = 1, nindxcr(l, itype) - 1, 2 + nindxc(l, itype) = nindxc(l, itype) + 1 + core1(:atoms%jri(itype), nindxc(l, itype), l, itype) =& + & (weight1*core1r(:atoms%jri(itype), l, i, itype) +& + & weight2*core1r(:atoms%jri(itype), l, i + 1, itype))& + & /(weight1 + weight2) + core2(:atoms%jri(itype), nindxc(l, itype), l, itype) =& + & (weight1*core2r(:atoms%jri(itype), l, i, itype) + & + & weight2*core2r(:atoms%jri(itype), l, i + 1, itype))& + & /(weight1 + weight2) + + eig_c(nindxc(l, itype), l, itype) =& + & (weight1*eig_cr(l, i, itype) +& + & weight2*eig_cr(l, i + 1, itype))& + & /(weight1 + weight2) + END DO + nindxc(l, itype) = nindxc(l, itype) + 1 + core1(:atoms%jri(itype), nindxc(l, itype), l, itype)& + & = core1r(:atoms%jri(itype), l, nindxcr(l, itype), itype) + core2(:atoms%jri(itype), nindxc(l, itype), l, itype)& + & = core2r(:atoms%jri(itype), l, nindxcr(l, itype), itype) + eig_c(nindxc(l, itype), l, itype)& + & = eig_cr(l, nindxcr(l, itype), itype) + END IF - DO itype=1,atoms%ntype - DO l=1,lmaxc(itype) - weight1 = 2*(l-0.5) + 1 - weight2 = 2*(l+0.5) + 1 - IF( modulo(nindxcr(l,itype),2) .eq. 0 ) THEN - DO i=1,nindxcr(l,itype),2 - nindxc(l,itype) = nindxc(l,itype) + 1 - core1(:atoms%jri(itype),nindxc(l,itype),l,itype) =& - & (weight1*core1r(:atoms%jri(itype),l,i ,itype) +& - & weight2*core1r(:atoms%jri(itype),l,i+1,itype))& - & / (weight1+weight2) - core2(:atoms%jri(itype),nindxc(l,itype),l,itype) =& - & (weight1*core2r(:atoms%jri(itype),l,i ,itype) + & - & weight2*core2r(:atoms%jri(itype),l,i+1,itype))& - & / (weight1+weight2) - - eig_c(nindxc(l,itype),l,itype) =& - & (weight1*eig_cr(l,i,itype) +& - & weight2*eig_cr(l,i+1,itype))& - & / (weight1+weight2) - END DO - ELSE - DO i=1,nindxcr(l,itype)-1,2 - nindxc(l,itype) = nindxc(l,itype) + 1 - core1(:atoms%jri(itype),nindxc(l,itype),l,itype) =& - & (weight1*core1r(:atoms%jri(itype),l,i ,itype) +& - & weight2*core1r(:atoms%jri(itype),l,i+1,itype))& - & / (weight1+weight2) - core2(:atoms%jri(itype),nindxc(l,itype),l,itype) =& - & (weight1*core2r(:atoms%jri(itype),l,i ,itype) + & - & weight2*core2r(:atoms%jri(itype),l,i+1,itype))& - & / (weight1+weight2) - - eig_c(nindxc(l,itype),l,itype) =& - & (weight1*eig_cr(l,i,itype) +& - & weight2*eig_cr(l,i+1,itype))& - & / (weight1+weight2) - END DO - nindxc(l,itype) = nindxc(l,itype) + 1 - core1(:atoms%jri(itype),nindxc(l,itype),l,itype)& - & = core1r(:atoms%jri(itype),l,nindxcr(l,itype),itype) - core2(:atoms%jri(itype),nindxc(l,itype),l,itype)& - & = core2r(:atoms%jri(itype),l,nindxcr(l,itype),itype) - eig_c(nindxc(l,itype),l,itype)& - & = eig_cr(l,nindxcr(l,itype),itype) - END IF - - END DO + END DO END DO - DEALLOCATE( nindxcr,core1r,core2r,eig_cr ) + DEALLOCATE (nindxcr, core1r, core2r, eig_cr) - IF( maxindxc .ne. maxval(nindxc) )& + IF (maxindxc /= maxval(nindxc))& & STOP 'corewf: counting error nindxc' + END SUBROUTINE corewf - END SUBROUTINE corewf - + SUBROUTINE calcorewf(dimension, input, jspin, atoms,& + & ncstd, vr,& + & lmaxc, nindxcr, core1, core2, eig_c, mpi) - SUBROUTINE calcorewf(dimension,input,jspin,atoms,& - & ncstd,vr,& - & lmaxc,nindxcr,core1,core2,eig_c,mpi) - - - USE m_intgr, ONLY : intgr3,intgr0,intgr1 - USE m_constants, ONLY : c_light + USE m_intgr, ONLY: intgr3, intgr0, intgr1 + USE m_constants, ONLY: c_light USE m_setcor USE m_differ USE m_types IMPLICIT NONE - TYPE(t_mpi),INTENT(IN) :: mpi - TYPE(t_dimension),INTENT(IN) :: dimension - TYPE(t_input),INTENT(IN) :: input - TYPE(t_atoms),INTENT(IN) :: atoms + TYPE(t_mpi), INTENT(IN) :: mpi + TYPE(t_dimension), INTENT(IN) :: dimension + TYPE(t_input), INTENT(IN) :: input + TYPE(t_atoms), INTENT(IN) :: atoms ! - scalars - - INTEGER, INTENT (IN) :: ncstd - INTEGER, INTENT (IN) :: jspin - INTEGER, INTENT (OUT):: lmaxc(:) + INTEGER, INTENT(IN) :: ncstd + INTEGER, INTENT(IN) :: jspin + INTEGER, INTENT(OUT):: lmaxc(:) - ! - arrays - - INTEGER, INTENT (OUT):: nindxcr(0:ncstd,atoms%ntype) - REAL , INTENT (IN) :: vr(:,:,:)!(atoms%jmtd,atoms%ntypd,input%jspins) - REAL , ALLOCATABLE :: core1(:,:,:,:),core2(:,:,:,:) - REAL , ALLOCATABLE :: eig_c(:,:,:) + ! - arrays - + INTEGER, INTENT(OUT):: nindxcr(0:ncstd, atoms%ntype) + REAL, INTENT(IN) :: vr(:, :, :)!(atoms%jmtd,atoms%ntypd,input%jspins) + REAL, ALLOCATABLE :: core1(:, :, :, :), core2(:, :, :, :) + REAL, ALLOCATABLE :: eig_c(:, :, :) ! - local scalars - - INTEGER :: i,j,itype,korb,ncmsh,nst,ierr - REAL :: e,fj,fl,fn,t2,c,bmu,weight - REAL :: d,dxx,rn,rnot,z,t1,rr + INTEGER :: i, j, itype, korb, ncmsh, nst, ierr + REAL :: e, fj, fl, fn, t2, c, bmu, weight + REAL :: d, dxx, rn, rnot, z, t1, rr LOGICAL, SAVE :: first = .true. ! - local arrays - - INTEGER :: kappa(dimension%nstd),nprnc(dimension%nstd) + INTEGER :: kappa(dimension%nstd), nprnc(dimension%nstd) REAL :: vrd(dimension%msh) - REAL :: occ(dimension%nstd),occ_h(dimension%nstd,2),a(dimension%msh),b(dimension%msh) - REAL,ALLOCATABLE,SAVE:: vr0(:,:,:) + REAL :: occ(dimension%nstd), occ_h(dimension%nstd, 2), a(dimension%msh), b(dimension%msh) + REAL, ALLOCATABLE, SAVE:: vr0(:, :, :) ! - intrinsic functions - - INTRINSIC exp,iabs,isign + INTRINSIC exp, iabs, isign c = c_light(1.0) - IF( first ) THEN - ALLOCATE( vr0(atoms%jmtd,atoms%ntype,input%jspins) ) + IF (first) THEN + ALLOCATE (vr0(atoms%jmtd, atoms%ntype, input%jspins)) END IF - IF ( input%frcor ) THEN - IF ( first ) THEN - vr0 = vr - first = .false. - END IF + IF (input%frcor) THEN + IF (first) THEN + vr0 = vr + first = .false. + END IF ELSE - vr0 = vr - first = .false. + vr0 = vr + first = .false. END IF - ! this loop determines the dimensions lmaxc = 0; nindxcr = 0 - DO itype = 1,atoms%ntype - z = atoms%zatom(itype) - dxx = atoms%dx(itype) - bmu = 0.0 - CALL setcor( itype,input%jspins,atoms,input,bmu,& - & nst,kappa,nprnc,occ_h) - - IF ((bmu > 99.)) THEN - occ(1:nst) = input%jspins * occ_h(1:nst,jspin) - ELSE - occ(1:nst) = occ_h(1:nst,1) - END IF - rnot = atoms%rmsh(1,itype) - d = exp(atoms%dx(itype)) - ncmsh = nint( log( (atoms%rmt(itype)+10.0)/rnot ) / dxx + 1 ) - ncmsh = min( ncmsh, dimension%msh ) - rn = rnot* (d** (ncmsh-1)) - - nst = atoms%ncst(itype) - - DO 80 korb = 1,nst - IF (occ(korb).EQ.0) GOTO 80 + DO itype = 1, atoms%ntype + z = atoms%zatom(itype) + dxx = atoms%dx(itype) + bmu = 0.0 + CALL setcor(itype, input%jspins, atoms, input, bmu,& + & nst, kappa, nprnc, occ_h) + + IF ((bmu > 99.)) THEN + occ(1:nst) = input%jspins*occ_h(1:nst, jspin) + ELSE + occ(1:nst) = occ_h(1:nst, 1) + END IF + rnot = atoms%rmsh(1, itype) + d = exp(atoms%dx(itype)) + ncmsh = nint(log((atoms%rmt(itype) + 10.0)/rnot)/dxx + 1) + ncmsh = min(ncmsh, dimension%msh) + rn = rnot*(d**(ncmsh - 1)) + + nst = atoms%ncst(itype) + + DO 80 korb = 1, nst + IF (occ(korb) == 0) GOTO 80 fn = nprnc(korb) fj = iabs(kappa(korb)) - .5e0 weight = 2*fj + 1.e0 IF (bmu > 99.) weight = occ(korb) - fl = fj + (.5e0)*isign(1,kappa(korb)) - e = -2* (z/ (fn+fl))**2 + fl = fj + (.5e0)*isign(1, kappa(korb)) + e = -2*(z/(fn + fl))**2 - nindxcr(NINT(fl),itype) = nindxcr(NINT(fl),itype) + 1 - lmaxc(itype) = max(lmaxc(itype),NINT(fl)) - 80 END DO + nindxcr(NINT(fl), itype) = nindxcr(NINT(fl), itype) + 1 + lmaxc(itype) = max(lmaxc(itype), NINT(fl)) +80 END DO END DO + ALLOCATE (core1(atoms%jmtd, 0:maxval(lmaxc), maxval(nindxcr), atoms%ntype)) + ALLOCATE (core2(atoms%jmtd, 0:maxval(lmaxc), maxval(nindxcr), atoms%ntype)) + ALLOCATE (eig_c(0:maxval(lmaxc), maxval(nindxcr), atoms%ntype)) + core1 = 0; core2 = 0 + nindxcr = 0 + DO itype = 1, atoms%ntype + z = atoms%zatom(itype) + dxx = atoms%dx(itype) + bmu = 0.0 + CALL setcor(itype, input%jspins, atoms, input, bmu, nst, kappa, nprnc, occ_h) + + IF ((bmu > 99.)) THEN + occ(1:nst) = input%jspins*occ_h(1:nst, jspin) + ELSE + occ(1:nst) = occ_h(1:nst, 1) + END IF + rnot = atoms%rmsh(1, itype) + d = exp(atoms%dx(itype)) + ncmsh = nint(log((atoms%rmt(itype) + 10.0)/rnot)/dxx + 1) + ncmsh = min(ncmsh, dimension%msh) + rn = rnot*(d**(ncmsh - 1)) + IF (mpi%irank == 0) THEN + WRITE (6, FMT=8000) z, rnot, dxx, atoms%jri(itype) + END IF + DO j = 1, atoms%jri(itype) + vrd(j) = vr0(j, itype, jspin) + END DO - ALLOCATE( core1(atoms%jmtd,0:maxval(lmaxc),maxval(nindxcr),atoms%ntype) ) - ALLOCATE( core2(atoms%jmtd,0:maxval(lmaxc),maxval(nindxcr),atoms%ntype) ) - ALLOCATE( eig_c(0:maxval(lmaxc),maxval(nindxcr),atoms%ntype) ) + if (input%l_core_confpot) THEN - core1 = 0; core2 =0 - nindxcr = 0 - DO itype = 1,atoms%ntype - z = atoms%zatom(itype) - dxx = atoms%dx(itype) - bmu = 0.0 - CALL setcor(itype,input%jspins,atoms,input,bmu,nst,kappa,nprnc,occ_h) - - IF ((bmu > 99.)) THEN - occ(1:nst) = input%jspins * occ_h(1:nst,jspin) - ELSE - occ(1:nst) = occ_h(1:nst,1) - END IF - rnot = atoms%rmsh(1,itype) - d = exp(atoms%dx(itype)) - ncmsh = nint( log( (atoms%rmt(itype)+10.0)/rnot ) / dxx + 1 ) - ncmsh = min( ncmsh, dimension%msh ) - rn = rnot* (d** (ncmsh-1)) - IF ( mpi%irank == 0 ) THEN - WRITE(6 ,FMT=8000) z,rnot,dxx,atoms%jri(itype) - END IF - DO j = 1,atoms%jri(itype) - vrd(j) = vr0(j,itype,jspin) - END DO - - if (input%l_core_confpot) THEN - - ! linear extension of the potential with slope t1 / a.u. - t1=0.125 - t2=vrd(atoms%jri(itype))/atoms%rmt(itype)-atoms%rmt(itype)*t1 - rr = atoms%rmt(itype) - else - t2 = vrd(atoms%jri(itype)) / ( atoms%jri(itype) - ncmsh ) - endif - IF ( atoms%jri(itype) .LT. ncmsh) THEN - DO i = atoms%jri(itype) + 1,ncmsh - if (input%l_core_confpot) THEN - rr = d*rr - vrd(i) = rr*( t2 + rr*t1 ) - else - vrd(i) = vrd(atoms%jri(itype)) + t2* (i-atoms%jri(itype)) + ! linear extension of the potential with slope t1 / a.u. + t1 = 0.125 + t2 = vrd(atoms%jri(itype))/atoms%rmt(itype) - atoms%rmt(itype)*t1 + rr = atoms%rmt(itype) + else + t2 = vrd(atoms%jri(itype))/(atoms%jri(itype) - ncmsh) endif + IF (atoms%jri(itype) < ncmsh) THEN + DO i = atoms%jri(itype) + 1, ncmsh + if (input%l_core_confpot) THEN + rr = d*rr + vrd(i) = rr*(t2 + rr*t1) + else + vrd(i) = vrd(atoms%jri(itype)) + t2*(i - atoms%jri(itype)) + endif ! - END DO - END IF - - nst = atoms%ncst(itype) + END DO + END IF + nst = atoms%ncst(itype) - DO 90 korb = 1,nst - IF (occ(korb).EQ.0) GOTO 90 + DO 90 korb = 1, nst + IF (occ(korb) == 0) GOTO 90 fn = nprnc(korb) fj = iabs(kappa(korb)) - .5e0 weight = 2*fj + 1.e0 IF (bmu > 99.) weight = occ(korb) - fl = fj + (.5e0)*isign(1,kappa(korb)) - e = -2* (z/ (fn+fl))**2 - CALL differ(fn,fl,fj,c,z,dxx,rnot,rn,d,ncmsh,vrd, e, a,b,ierr) + fl = fj + (.5e0)*isign(1, kappa(korb)) + e = -2*(z/(fn + fl))**2 + CALL differ(fn, fl, fj, c, z, dxx, rnot, rn, d, ncmsh, vrd, e, a, b, ierr) - nindxcr(NINT(fl),itype) = nindxcr(NINT(fl),itype) + 1 + nindxcr(NINT(fl), itype) = nindxcr(NINT(fl), itype) + 1 + core1(:atoms%jri(itype), NINT(fl), nindxcr(NINT(fl), itype), itype)& + & = a(:atoms%jri(itype)) + core2(:atoms%jri(itype), NINT(fl), nindxcr(NINT(fl), itype), itype)& + & = b(:atoms%jri(itype)) - core1(:atoms%jri(itype),NINT(fl),nindxcr(NINT(fl),itype),itype)& - & = a(:atoms%jri(itype)) - core2(:atoms%jri(itype),NINT(fl),nindxcr(NINT(fl),itype),itype)& - & = b(:atoms%jri(itype)) + eig_c(NINT(fl), nindxcr(NINT(fl), itype), itype) = e - eig_c(NINT(fl),nindxcr(NINT(fl),itype),itype) = e - - IF ( mpi%irank == 0 ) THEN - WRITE (6,FMT=8010) fn,fl,fj,e,weight + IF (mpi%irank == 0) THEN + WRITE (6, FMT=8010) fn, fl, fj, e, weight END IF - IF (ierr.NE.0) STOP 'error in core-level routine' - + IF (ierr /= 0) STOP 'error in core-level routine' - 90 END DO +90 END DO END DO +8000 FORMAT(/, /, 10x, 'z=', f4.0, 5x, 'r(1)=', e14.6, 5x, 'dx=', f8.6, 5x,& + & 'm.t.index=', i4, /, 15x, 'n', 4x, 'l', 5x, 'j', 4x, 'energy', 7x,& + & 'weight') +8010 FORMAT(12x, 2f5.0, f6.1, f10.4, f10.0) - 8000 FORMAT (/,/,10x,'z=',f4.0,5x,'r(1)=',e14.6,5x,'dx=',f8.6,5x,& - & 'm.t.index=',i4,/,15x,'n',4x,'l',5x,'j',4x,'energy',7x,& - & 'weight') - 8010 FORMAT (12x,2f5.0,f6.1,f10.4,f10.0) - - END SUBROUTINE calcorewf + END SUBROUTINE calcorewf - SUBROUTINE core_init( dimension,input,atoms, lmaxcd,maxindxc) + SUBROUTINE core_init(dimension, input, atoms, lmaxcd, maxindxc) - - USE m_intgr, ONLY : intgr3,intgr0,intgr1 - USE m_constants, ONLY : c_light + USE m_intgr, ONLY: intgr3, intgr0, intgr1 + USE m_constants, ONLY: c_light USE m_setcor USE m_differ USE m_types IMPLICIT NONE - TYPE(t_dimension),INTENT(IN) :: dimension - TYPE(t_input),INTENT(IN) :: input - TYPE(t_atoms),INTENT(IN) :: atoms - INTEGER,INTENT(OUT) :: maxindxc,lmaxcd + TYPE(t_dimension), INTENT(IN) :: dimension + TYPE(t_input), INTENT(IN) :: input + TYPE(t_atoms), INTENT(IN) :: atoms + INTEGER, INTENT(OUT) :: maxindxc, lmaxcd - ! - local scalars - - INTEGER :: i,j,itype,korb,ncmsh,nst,ierr - REAL :: e,fj,fl,fn,t,bmu,c - REAL :: d,dxx,rn,rnot,z,t1,rr + INTEGER :: i, j, itype, korb, ncmsh, nst, ierr + REAL :: e, fj, fl, fn, t, bmu, c + REAL :: d, dxx, rn, rnot, z, t1, rr ! - local arrays - - INTEGER :: kappa(dimension%nstd),nprnc(dimension%nstd) - INTEGER :: nindxcr(0:dimension%nstd,atoms%ntype) - REAL :: occ(dimension%nstd),occ_h(dimension%nstd,2),a(dimension%msh),b(dimension%msh) + INTEGER :: kappa(dimension%nstd), nprnc(dimension%nstd) + INTEGER :: nindxcr(0:dimension%nstd, atoms%ntype) + REAL :: occ(dimension%nstd), occ_h(dimension%nstd, 2), a(dimension%msh), b(dimension%msh) INTEGER :: lmaxc(atoms%ntype) - ! - intrinsic functions - - INTRINSIC exp,iabs,isign + INTRINSIC exp, iabs, isign c = c_light(1.0) - ! this loop determines the dimensions lmaxc = 0; nindxcr = 0 - DO itype = 1,atoms%ntype - z = atoms%zatom(itype) - dxx = atoms%dx(itype) - bmu = 0.0 - CALL setcor(itype,input%jspins,atoms,input,bmu, nst,kappa,nprnc,occ_h) + DO itype = 1, atoms%ntype + z = atoms%zatom(itype) + dxx = atoms%dx(itype) + bmu = 0.0 + CALL setcor(itype, input%jspins, atoms, input, bmu, nst, kappa, nprnc, occ_h) - occ(1:nst) = occ_h(1:nst,1) + occ(1:nst) = occ_h(1:nst, 1) - rnot = atoms%rmsh(1,itype) - d = exp(atoms%dx(itype)) - ncmsh = nint( log( (atoms%rmt(itype)+10.0)/rnot ) / dxx + 1 ) - ncmsh = min( ncmsh, dimension%msh ) - rn = rnot* (d** (ncmsh-1)) + rnot = atoms%rmsh(1, itype) + d = exp(atoms%dx(itype)) + ncmsh = nint(log((atoms%rmt(itype) + 10.0)/rnot)/dxx + 1) + ncmsh = min(ncmsh, dimension%msh) + rn = rnot*(d**(ncmsh - 1)) - nst = atoms%ncst(itype) + nst = atoms%ncst(itype) - DO korb = 1,nst - IF (occ(korb).EQ.0) CYCLE + DO korb = 1, nst + IF (occ(korb) == 0) CYCLE fn = nprnc(korb) fj = iabs(kappa(korb)) - .5e0 - fl = fj + (.5e0)*isign(1,kappa(korb)) - e = -2* (z/ (fn+fl))**2 + fl = fj + (.5e0)*isign(1, kappa(korb)) + e = -2*(z/(fn + fl))**2 - nindxcr(NINT(fl),itype) = nindxcr(NINT(fl),itype) + 1 - lmaxc(itype) = max(lmaxc(itype),NINT(fl)) + nindxcr(NINT(fl), itype) = nindxcr(NINT(fl), itype) + 1 + lmaxc(itype) = max(lmaxc(itype), NINT(fl)) END DO END DO - lmaxcd = maxval(lmaxc) - maxindxc = maxval(nindxcr(0,:),nint((maxval(nindxcr)/2.0))) - - + lmaxcd = maxval(lmaxc) + maxindxc = maxval(nindxcr(0, :), nint((maxval(nindxcr)/2.0))) - END SUBROUTINE core_init + END SUBROUTINE core_init - END MODULE m_read_core +END MODULE m_read_core diff --git a/hybrid/spmvec.F90 b/hybrid/spmvec.F90 index 75697956c0223e0c82152d1c6b1eec2699e32296..fcbacdc4a9e2024d44a8b8936034b712ec538ea2 100644 --- a/hybrid/spmvec.F90 +++ b/hybrid/spmvec.F90 @@ -1,624 +1,600 @@ - MODULE m_spmvec - +MODULE m_spmvec + CONTAINS - !Note this module contains a real/complex version of spmvec - - - SUBROUTINE spmvec_invs(& - & atoms,hybrid,& - & hybdat,ikpt,kpts,cell,& - & coulomb_mt1,coulomb_mt2,coulomb_mt3,& - & coulomb_mtir,vecin,& - & vecout) - - USE m_wrapper - USE m_constants - USE m_types - IMPLICIT NONE - TYPE(t_hybdat),INTENT(IN) :: hybdat - TYPE(t_hybrid),INTENT(IN) :: hybrid - TYPE(t_cell),INTENT(IN) :: cell - TYPE(t_kpts),INTENT(IN) :: kpts - TYPE(t_atoms),INTENT(IN) :: atoms - - ! - scalars - - INTEGER, INTENT(IN) :: ikpt - - ! - arrays - - REAL , INTENT(IN) :: coulomb_mt1(hybrid%maxindxm1-1,hybrid%maxindxm1-1,& - & 0:hybrid%maxlcutm1,atoms%ntype) - REAL , INTENT(IN) :: coulomb_mt2(hybrid%maxindxm1-1,-hybrid%maxlcutm1:hybrid%maxlcutm1,& - & 0:hybrid%maxlcutm1+1,atoms%nat) - REAL , INTENT(IN) :: coulomb_mt3(hybrid%maxindxm1-1,atoms%nat,atoms%nat) + !Note this module contains a real/complex version of spmvec + + SUBROUTINE spmvec_invs(& + & atoms, hybrid,& + & hybdat, ikpt, kpts, cell,& + & coulomb_mt1, coulomb_mt2, coulomb_mt3,& + & coulomb_mtir, vecin,& + & vecout) + + USE m_wrapper + USE m_constants + USE m_types + IMPLICIT NONE + TYPE(t_hybdat), INTENT(IN) :: hybdat + TYPE(t_hybrid), INTENT(IN) :: hybrid + TYPE(t_cell), INTENT(IN) :: cell + TYPE(t_kpts), INTENT(IN) :: kpts + TYPE(t_atoms), INTENT(IN) :: atoms + + ! - scalars - + INTEGER, INTENT(IN) :: ikpt + + ! - arrays - + REAL, INTENT(IN) :: coulomb_mt1(hybrid%maxindxm1 - 1, hybrid%maxindxm1 - 1,& + & 0:hybrid%maxlcutm1, atoms%ntype) + REAL, INTENT(IN) :: coulomb_mt2(hybrid%maxindxm1 - 1, -hybrid%maxlcutm1:hybrid%maxlcutm1,& + & 0:hybrid%maxlcutm1 + 1, atoms%nat) + REAL, INTENT(IN) :: coulomb_mt3(hybrid%maxindxm1 - 1, atoms%nat, atoms%nat) #ifdef CPP_IRCOULOMBAPPROX - REAL , INTENT(IN) :: coulomb_mtir(:,:) + REAL, INTENT(IN) :: coulomb_mtir(:, :) #else - REAL , INTENT(IN) :: coulomb_mtir(:) + REAL, INTENT(IN) :: coulomb_mtir(:) #endif - REAL , INTENT(IN) :: vecin (:)!(hybrid%nbasm) - REAL , INTENT(INOUT):: vecout(:)!(hybrid%nbasm) - - ! - local scalars - - INTEGER :: itype,ieq,iatom,ishift - INTEGER :: itype1,ieq1,iatom1,ishift1 - INTEGER :: indx0,indx1,indx2,indx3,indx4 - INTEGER :: i,ibasm,igptm - INTEGER :: l - INTEGER :: n,m - - REAL :: gnorm - - COMPLEX, PARAMETER :: img = (0.0,1.0) - ! - local arrays - - - REAL :: vecinhlp (hybrid%nbasm(ikpt)) - REAL ,ALLOCATABLE :: coulhlp(:,:) - - - - vecinhlp = vecin - - CALL reorder(hybrid%nbasm(ikpt),hybrid%nbasp,atoms,hybrid%lcutm1, hybrid%maxlcutm1,hybrid%nindxm1,1, vecinhlp) - - - ibasm = 0 - iatom = 0 - DO itype = 1,atoms%ntype - DO ieq = 1,atoms%neq(itype) - iatom = iatom + 1 - DO l = 0,hybrid%lcutm1(itype) - DO m = -l,l - ibasm = ibasm + hybrid%nindxm1(l,itype) - 1 - END DO - END DO - END DO - END DO - - - ! compute vecout for the indices from 0:ibasm - iatom = 0 - indx1 = 0; indx2 = 0; indx3 = ibasm - DO itype = 1,atoms%ntype - DO ieq = 1,atoms%neq(itype) - iatom = iatom + 1 - DO l = 0,hybrid%lcutm1(itype) - DO m = -l,l - indx1 = indx1 + 1 - indx2 = indx2 + hybrid%nindxm1(l,itype) - 1 - indx3 = indx3 + 1 - - - vecout(indx1:indx2) = matmul(coulomb_mt1(:hybrid%nindxm1(l,itype)-1,:hybrid%nindxm1(l,itype)-1, l,itype),& - & vecinhlp(indx1:indx2)) - - - - vecout(indx1:indx2) = vecout(indx1:indx2) + coulomb_mt2(:hybrid%nindxm1(l,itype)-1,m,l,iatom) * vecinhlp(indx3) - - indx1 = indx2 + REAL, INTENT(IN) :: vecin(:)!(hybrid%nbasm) + REAL, INTENT(INOUT):: vecout(:)!(hybrid%nbasm) + + ! - local scalars - + INTEGER :: itype, ieq, iatom, ishift + INTEGER :: itype1, ieq1, iatom1, ishift1 + INTEGER :: indx0, indx1, indx2, indx3, indx4 + INTEGER :: i, ibasm, igptm + INTEGER :: l + INTEGER :: n, m + + REAL :: gnorm + + COMPLEX, PARAMETER :: img = (0.0, 1.0) + ! - local arrays - + + REAL :: vecinhlp(hybrid%nbasm(ikpt)) + REAL, ALLOCATABLE :: coulhlp(:, :) + + vecinhlp = vecin + + CALL reorder(hybrid%nbasm(ikpt), hybrid%nbasp, atoms, hybrid%lcutm1, hybrid%maxlcutm1, hybrid%nindxm1, 1, vecinhlp) + + ibasm = 0 + iatom = 0 + DO itype = 1, atoms%ntype + DO ieq = 1, atoms%neq(itype) + iatom = iatom + 1 + DO l = 0, hybrid%lcutm1(itype) + DO m = -l, l + ibasm = ibasm + hybrid%nindxm1(l, itype) - 1 + END DO + END DO + END DO END DO - - END DO - END DO - END DO - - IF( indx2 .ne. ibasm ) STOP 'spmvec: error counting basis functions' - - IF( ikpt .eq. 1) THEN - iatom = 0 - indx0 = 0 - DO itype = 1,atoms%ntype - ishift = sum( (/ ((2*l+1)*(hybrid%nindxm1(l,itype)-1), l=0,hybrid%lcutm1(itype) )/) ) - DO ieq = 1,atoms%neq(itype) - iatom = iatom + 1 - l = 0 - m = 0 - - indx1 = indx0 + 1 - indx2 = indx1 + hybrid%nindxm1(l,itype) - 2 - - iatom1 = 0 - indx3 = ibasm - DO itype1 = 1,atoms%ntype - ishift1 = (hybrid%lcutm1(itype1)+1)**2 - DO ieq1 = 1,atoms%neq(itype1) - iatom1 = iatom1 + 1 - indx4 = indx3 + (ieq1 - 1)*ishift1 + 1 - IF( iatom .eq. iatom1 ) CYCLE - - vecout(indx1:indx2) = vecout(indx1:indx2) + coulomb_mt3(:hybrid%nindxm1(l,itype)-1, iatom1,iatom) * vecinhlp(indx4) - - END DO - indx3 = indx3 + atoms%neq(itype1)*ishift1 + ! compute vecout for the indices from 0:ibasm + iatom = 0 + indx1 = 0; indx2 = 0; indx3 = ibasm + DO itype = 1, atoms%ntype + DO ieq = 1, atoms%neq(itype) + iatom = iatom + 1 + DO l = 0, hybrid%lcutm1(itype) + DO m = -l, l + indx1 = indx1 + 1 + indx2 = indx2 + hybrid%nindxm1(l, itype) - 1 + indx3 = indx3 + 1 + + vecout(indx1:indx2) = matmul(coulomb_mt1(:hybrid%nindxm1(l, itype) - 1, :hybrid%nindxm1(l, itype) - 1, l, itype),& + & vecinhlp(indx1:indx2)) + + vecout(indx1:indx2) = vecout(indx1:indx2) + coulomb_mt2(:hybrid%nindxm1(l, itype) - 1, m, l, iatom)*vecinhlp(indx3) + + indx1 = indx2 + END DO + + END DO + END DO END DO - - IF( indx3 .ne. hybrid%nbasp ) STOP 'spmvec: error counting index indx3' - - vecout(indx1:indx2) = vecout(indx1:indx2) + coulomb_mt2(:hybrid%nindxm1(l,itype)-1,0, hybrid%maxlcutm1+1,iatom) * vecinhlp(indx3+1) - - indx0 = indx0 + ishift - END DO - - END DO - END IF - - ! compute vecout for the index-range from ibasm+1:nbasm - + + IF (indx2 /= ibasm) STOP 'spmvec: error counting basis functions' + + IF (ikpt == 1) THEN + iatom = 0 + indx0 = 0 + DO itype = 1, atoms%ntype + ishift = sum((/((2*l + 1)*(hybrid%nindxm1(l, itype) - 1), l=0, hybrid%lcutm1(itype))/)) + DO ieq = 1, atoms%neq(itype) + iatom = iatom + 1 + l = 0 + m = 0 + + indx1 = indx0 + 1 + indx2 = indx1 + hybrid%nindxm1(l, itype) - 2 + + iatom1 = 0 + indx3 = ibasm + DO itype1 = 1, atoms%ntype + ishift1 = (hybrid%lcutm1(itype1) + 1)**2 + DO ieq1 = 1, atoms%neq(itype1) + iatom1 = iatom1 + 1 + indx4 = indx3 + (ieq1 - 1)*ishift1 + 1 + IF (iatom == iatom1) CYCLE + + vecout(indx1:indx2) = vecout(indx1:indx2) + coulomb_mt3(:hybrid%nindxm1(l, itype) - 1, iatom1, iatom)*vecinhlp(indx4) + + END DO + indx3 = indx3 + atoms%neq(itype1)*ishift1 + END DO + + IF (indx3 /= hybrid%nbasp) STOP 'spmvec: error counting index indx3' + + vecout(indx1:indx2) = vecout(indx1:indx2) + coulomb_mt2(:hybrid%nindxm1(l, itype) - 1, 0, hybrid%maxlcutm1 + 1, iatom)*vecinhlp(indx3 + 1) + + indx0 = indx0 + ishift + END DO + + END DO + END IF + + ! compute vecout for the index-range from ibasm+1:nbasm + #ifdef CPP_IRCOULOMBAPPROX - - indx0 = sum( (/ ( ((2*l+1)*atoms%neq(itype),l=0,hybrid%lcutm1(itype)), itype=1,atoms%ntype ) /) )+ hybrid%ngptm - indx1 = sum( (/ ( ((2*l+1)*atoms%neq(itype),l=0,hybrid%lcutm1(itype)), itype=1,atoms%ntype ) /) ) - CALL DGEMV('N',indx1,indx0,1.0,coulomb_mtir,(hybrid%maxlcutm1+1)**2*atoms,& - & vecinhlp(ibasm+1:),1,0.0,vecout(ibasm+1:),1) - - CALL DGEMV('T',indx1,hybrid,1.0,coulomb_mtir(:indx1,indx1+1:),& - & indx1,vecinhlp(ibasm+1:),1,0.0,vecout(ibasm+indx1+1:),1) + indx0 = sum((/(((2*l + 1)*atoms%neq(itype), l=0, hybrid%lcutm1(itype)), itype=1, atoms%ntype)/)) + hybrid%ngptm + indx1 = sum((/(((2*l + 1)*atoms%neq(itype), l=0, hybrid%lcutm1(itype)), itype=1, atoms%ntype)/)) + + CALL DGEMV('N', indx1, indx0, 1.0, coulomb_mtir, (hybrid%maxlcutm1 + 1)**2*atoms,& + & vecinhlp(ibasm + 1:), 1, 0.0, vecout(ibasm + 1:), 1) + + CALL DGEMV('T', indx1, hybrid, 1.0, coulomb_mtir(:indx1, indx1 + 1:),& + & indx1, vecinhlp(ibasm + 1:), 1, 0.0, vecout(ibasm + indx1 + 1:), 1) ! vecout(ibasm+1:ibasm+indx1) = matmul( coulomb_mtir(:indx1,:indx0),vecinhlp(ibasm+1:ibasm+indx0) ) ! vecout(ibasm+indx1+1:ibasm+indx0) = matmul( conjg(transpose(coulomb_mtir(:indx1,indx1+1:indx0))), ! & vecinhlp(ibasm+1:ibasm+indx1) ) - - indx0 = ibasm + indx1 - IF( indx0 .ne. hybrid%nbasp ) STOP 'spmvec: error indx0' - DO i = 1,hybrid%ngptm - indx0 = indx0 + 1 - igptm = hybrid%pgptm(i) - gnorm = sqrt(sum(matmul(kpts%bk(:) + hybrid%gptm(:,igptm),cell%bmat)**2)) - IF( gnorm .eq. 0 ) CYCLE - vecout(indx0) = vecout(indx0) + fpi*vecinhlp(indx0)/gnorm - END DO - + indx0 = ibasm + indx1 + IF (indx0 /= hybrid%nbasp) STOP 'spmvec: error indx0' + DO i = 1, hybrid%ngptm + indx0 = indx0 + 1 + igptm = hybrid%pgptm(i) + gnorm = sqrt(sum(matmul(kpts%bk(:) + hybrid%gptm(:, igptm), cell%bmat)**2)) + IF (gnorm == 0) CYCLE + vecout(indx0) = vecout(indx0) + fpi*vecinhlp(indx0)/gnorm + END DO + #else - indx1 = sum( (/ ( ((2*l+1)*atoms%neq(itype),l=0,hybrid%lcutm1(itype)),& - & itype=1,atoms%ntype ) /) )+ hybrid%ngptm(ikpt) - CALL dspmv('U',indx1,1.0,coulomb_mtir,vecinhlp(ibasm+1:),1,0.0, vecout(ibasm+1:),1) + indx1 = sum((/(((2*l + 1)*atoms%neq(itype), l=0, hybrid%lcutm1(itype)),& + & itype=1, atoms%ntype)/)) + hybrid%ngptm(ikpt) + CALL dspmv('U', indx1, 1.0, coulomb_mtir, vecinhlp(ibasm + 1:), 1, 0.0, vecout(ibasm + 1:), 1) #endif - iatom = 0 - indx1 = ibasm; indx2 = 0; indx3 = 0 - DO itype = 1,atoms%ntype - DO ieq = 1,atoms%neq(itype) - iatom = iatom + 1 - DO l = 0,hybrid%lcutm1(itype) - n = hybrid%nindxm1(l,itype) - DO m = -l,l - indx1 = indx1 + 1 - indx2 = indx2 + 1 - indx3 = indx3 + n - 1 - - vecout(indx1) = vecout(indx1) + dotprod(coulomb_mt2(:n-1,m,l,iatom), vecinhlp(indx2:indx3)) - indx2 = indx3 - END DO - - END DO - END DO - END DO - - - IF( ikpt .eq. 1 ) THEN - iatom = 0 - indx0 = 0 - DO itype = 1,atoms%ntype - ishift = sum( (/ ((2*l+1)*(hybrid%nindxm1(l,itype)-1), l=0,hybrid%lcutm1(itype) )/) ) - DO ieq = 1,atoms%neq(itype) - iatom = iatom + 1 - indx1 = indx0 + 1 - indx2 = indx1 + hybrid%nindxm1(0,itype) - 2 - vecout(hybrid%nbasp+1) = vecout(hybrid%nbasp+1) + dotprod(coulomb_mt2(:hybrid%nindxm1(0,itype)-1,0, hybrid%maxlcutm1+1,iatom), vecinhlp(indx1:indx2)) - - indx0 = indx0 + ishift - END DO - END DO - - iatom = 0 - indx0 = ibasm - DO itype = 1,atoms%ntype - ishift = (hybrid%lcutm1(itype)+1)**2 - DO ieq = 1,atoms%neq(itype) - iatom = iatom + 1 - indx1 = indx0 + 1 - - iatom1 = 0 - indx2 = 0 - DO itype1 = 1,atoms%ntype - ishift1 = sum( (/ ( (2*l+1)*(hybrid%nindxm1(l,itype1)-1), l=0,hybrid%lcutm1(itype1)) /)) - DO ieq1 = 1,atoms%neq(itype1) - iatom1 = iatom1 + 1 - IF( iatom1 .eq. iatom ) CYCLE - - indx3 = indx2 + (ieq1 - 1)*ishift1 + 1 - indx4 = indx3 + hybrid%nindxm1(0,itype1) - 2 - - vecout(indx1) = vecout(indx1) + dotprod(coulomb_mt3(:hybrid%nindxm1(0,itype1)-1,iatom,iatom1), vecinhlp(indx3:indx4)) - - END DO - indx2 = indx2 + atoms%neq(itype1)*ishift1 + iatom = 0 + indx1 = ibasm; indx2 = 0; indx3 = 0 + DO itype = 1, atoms%ntype + DO ieq = 1, atoms%neq(itype) + iatom = iatom + 1 + DO l = 0, hybrid%lcutm1(itype) + n = hybrid%nindxm1(l, itype) + DO m = -l, l + indx1 = indx1 + 1 + indx2 = indx2 + 1 + indx3 = indx3 + n - 1 + + vecout(indx1) = vecout(indx1) + dotprod(coulomb_mt2(:n - 1, m, l, iatom), vecinhlp(indx2:indx3)) + indx2 = indx3 + END DO + + END DO + END DO END DO - indx0 = indx0 + ishift - END DO - END DO - IF( indx0 .ne. hybrid%nbasp ) STOP 'spmvec: error index counting (indx0)' - END IF - - CALL reorder(hybrid%nbasm(ikpt),hybrid%nbasp,atoms,hybrid%lcutm1,hybrid%maxlcutm1,hybrid%nindxm1,& - & 2,& - & vecout) - - - END SUBROUTINE spmvec_invs - - SUBROUTINE spmvec_noinvs(& - & atoms,hybrid,& - & hybdat,ikpt,kpts,cell,& - & coulomb_mt1,coulomb_mt2,coulomb_mt3,& - & coulomb_mtir,vecin,& - & vecout) - - USE m_wrapper - USE m_constants - USE m_types - IMPLICIT NONE - TYPE(t_hybdat),INTENT(IN) :: hybdat - TYPE(t_hybrid),INTENT(IN) :: hybrid - TYPE(t_cell),INTENT(IN) :: cell - TYPE(t_kpts),INTENT(IN) :: kpts - TYPE(t_atoms),INTENT(IN) :: atoms - - ! - scalars - - INTEGER, INTENT(IN) :: ikpt - - ! - arrays - - REAL , INTENT(IN) :: coulomb_mt1(hybrid%maxindxm1-1,hybrid%maxindxm1-1,& - & 0:hybrid%maxlcutm1,atoms%ntype) - COMPLEX, INTENT(IN) :: coulomb_mt2(hybrid%maxindxm1-1,-hybrid%maxlcutm1:hybrid%maxlcutm1,& - & 0:hybrid%maxlcutm1+1,atoms%nat) - COMPLEX, INTENT(IN) :: coulomb_mt3(hybrid%maxindxm1-1,atoms%nat,atoms%nat) + + IF (ikpt == 1) THEN + iatom = 0 + indx0 = 0 + DO itype = 1, atoms%ntype + ishift = sum((/((2*l + 1)*(hybrid%nindxm1(l, itype) - 1), l=0, hybrid%lcutm1(itype))/)) + DO ieq = 1, atoms%neq(itype) + iatom = iatom + 1 + indx1 = indx0 + 1 + indx2 = indx1 + hybrid%nindxm1(0, itype) - 2 + vecout(hybrid%nbasp + 1) = vecout(hybrid%nbasp + 1) + dotprod(coulomb_mt2(:hybrid%nindxm1(0, itype) - 1, 0, hybrid%maxlcutm1 + 1, iatom), vecinhlp(indx1:indx2)) + + indx0 = indx0 + ishift + END DO + END DO + + iatom = 0 + indx0 = ibasm + DO itype = 1, atoms%ntype + ishift = (hybrid%lcutm1(itype) + 1)**2 + DO ieq = 1, atoms%neq(itype) + iatom = iatom + 1 + indx1 = indx0 + 1 + + iatom1 = 0 + indx2 = 0 + DO itype1 = 1, atoms%ntype + ishift1 = sum((/((2*l + 1)*(hybrid%nindxm1(l, itype1) - 1), l=0, hybrid%lcutm1(itype1))/)) + DO ieq1 = 1, atoms%neq(itype1) + iatom1 = iatom1 + 1 + IF (iatom1 == iatom) CYCLE + + indx3 = indx2 + (ieq1 - 1)*ishift1 + 1 + indx4 = indx3 + hybrid%nindxm1(0, itype1) - 2 + + vecout(indx1) = vecout(indx1) + dotprod(coulomb_mt3(:hybrid%nindxm1(0, itype1) - 1, iatom, iatom1), vecinhlp(indx3:indx4)) + + END DO + indx2 = indx2 + atoms%neq(itype1)*ishift1 + END DO + indx0 = indx0 + ishift + END DO + END DO + IF (indx0 /= hybrid%nbasp) STOP 'spmvec: error index counting (indx0)' + END IF + + CALL reorder(hybrid%nbasm(ikpt), hybrid%nbasp, atoms, hybrid%lcutm1, hybrid%maxlcutm1, hybrid%nindxm1,& + & 2,& + & vecout) + + END SUBROUTINE spmvec_invs + + SUBROUTINE spmvec_noinvs(& + & atoms, hybrid,& + & hybdat, ikpt, kpts, cell,& + & coulomb_mt1, coulomb_mt2, coulomb_mt3,& + & coulomb_mtir, vecin,& + & vecout) + + USE m_wrapper + USE m_constants + USE m_types + IMPLICIT NONE + TYPE(t_hybdat), INTENT(IN) :: hybdat + TYPE(t_hybrid), INTENT(IN) :: hybrid + TYPE(t_cell), INTENT(IN) :: cell + TYPE(t_kpts), INTENT(IN) :: kpts + TYPE(t_atoms), INTENT(IN) :: atoms + + ! - scalars - + INTEGER, INTENT(IN) :: ikpt + + ! - arrays - + REAL, INTENT(IN) :: coulomb_mt1(hybrid%maxindxm1 - 1, hybrid%maxindxm1 - 1,& + & 0:hybrid%maxlcutm1, atoms%ntype) + COMPLEX, INTENT(IN) :: coulomb_mt2(hybrid%maxindxm1 - 1, -hybrid%maxlcutm1:hybrid%maxlcutm1,& + & 0:hybrid%maxlcutm1 + 1, atoms%nat) + COMPLEX, INTENT(IN) :: coulomb_mt3(hybrid%maxindxm1 - 1, atoms%nat, atoms%nat) #ifdef CPP_IRCOULOMBAPPROX - COMPLEX, INTENT(IN) :: coulomb_mtir(:,:) + COMPLEX, INTENT(IN) :: coulomb_mtir(:, :) #else - COMPLEX, INTENT(IN) :: coulomb_mtir(:) + COMPLEX, INTENT(IN) :: coulomb_mtir(:) #endif - COMPLEX, INTENT(IN) :: vecin (:)!(hybrid%nbasm) - COMPLEX, INTENT(OUT):: vecout(:)!(hybrid%nbasm) - - ! - local scalars - - INTEGER :: itype,ieq,iatom,ishift - INTEGER :: itype1,ieq1,iatom1,ishift1 - INTEGER :: indx0,indx1,indx2,indx3,indx4 - INTEGER :: i,ibasm,igptm - INTEGER :: l - INTEGER :: n,m - - REAL :: gnorm - - COMPLEX, PARAMETER :: img = (0.0,1.0) - ! - local arrays - - - REAL :: vecr(hybrid%maxindxm1-1),veci(hybrid%maxindxm1-1) - COMPLEX :: vecinhlp (hybrid%nbasm(ikpt)) - COMPLEX,ALLOCATABLE :: coulhlp(:,:) - - - - vecinhlp = vecin - - CALL reorder(hybrid%nbasm(ikpt),hybrid%nbasp,atoms,hybrid%lcutm1, hybrid%maxlcutm1,hybrid%nindxm1,1, vec_c=vecinhlp) - - - ibasm = 0 - iatom = 0 - DO itype = 1,atoms%ntype - DO ieq = 1,atoms%neq(itype) - iatom = iatom + 1 - DO l = 0,hybrid%lcutm1(itype) - DO m = -l,l - ibasm = ibasm + hybrid%nindxm1(l,itype) - 1 - END DO - END DO - END DO - END DO - - - ! compute vecout for the indices from 0:ibasm - iatom = 0 - indx1 = 0; indx2 = 0; indx3 = ibasm - DO itype = 1,atoms%ntype - DO ieq = 1,atoms%neq(itype) - iatom = iatom + 1 - DO l = 0,hybrid%lcutm1(itype) - DO m = -l,l - indx1 = indx1 + 1 - indx2 = indx2 + hybrid%nindxm1(l,itype) - 1 - indx3 = indx3 + 1 - - - vecout(indx1:indx2) = matmul(coulomb_mt1(:hybrid%nindxm1(l,itype)-1,:hybrid%nindxm1(l,itype)-1, l,itype),& - & vecinhlp(indx1:indx2)) - - - vecout(indx1:indx2) = vecout(indx1:indx2) + coulomb_mt2(:hybrid%nindxm1(l,itype)-1,m,l,iatom) * vecinhlp(indx3) - - indx1 = indx2 + COMPLEX, INTENT(IN) :: vecin(:)!(hybrid%nbasm) + COMPLEX, INTENT(OUT):: vecout(:)!(hybrid%nbasm) + + ! - local scalars - + INTEGER :: itype, ieq, iatom, ishift + INTEGER :: itype1, ieq1, iatom1, ishift1 + INTEGER :: indx0, indx1, indx2, indx3, indx4 + INTEGER :: i, ibasm, igptm + INTEGER :: l + INTEGER :: n, m + + REAL :: gnorm + + COMPLEX, PARAMETER :: img = (0.0, 1.0) + ! - local arrays - + + REAL :: vecr(hybrid%maxindxm1 - 1), veci(hybrid%maxindxm1 - 1) + COMPLEX :: vecinhlp(hybrid%nbasm(ikpt)) + COMPLEX, ALLOCATABLE :: coulhlp(:, :) + + vecinhlp = vecin + + CALL reorder(hybrid%nbasm(ikpt), hybrid%nbasp, atoms, hybrid%lcutm1, hybrid%maxlcutm1, hybrid%nindxm1, 1, vec_c=vecinhlp) + + ibasm = 0 + iatom = 0 + DO itype = 1, atoms%ntype + DO ieq = 1, atoms%neq(itype) + iatom = iatom + 1 + DO l = 0, hybrid%lcutm1(itype) + DO m = -l, l + ibasm = ibasm + hybrid%nindxm1(l, itype) - 1 + END DO + END DO + END DO END DO - - END DO - END DO - END DO - - IF( indx2 .ne. ibasm ) & - & STOP 'spmvec: error counting basis functions' - - IF( ikpt .eq. 1) THEN - iatom = 0 - indx0 = 0 - DO itype = 1,atoms%ntype - ishift = sum( (/ ((2*l+1)*(hybrid%nindxm1(l,itype)-1), l=0,hybrid%lcutm1(itype) )/) ) - DO ieq = 1,atoms%neq(itype) - iatom = iatom + 1 - l = 0 - m = 0 - - indx1 = indx0 + 1 - indx2 = indx1 + hybrid%nindxm1(l,itype) - 2 - - iatom1 = 0 - indx3 = ibasm - DO itype1 = 1,atoms%ntype - ishift1 = (hybrid%lcutm1(itype1)+1)**2 - DO ieq1 = 1,atoms%neq(itype1) - iatom1 = iatom1 + 1 - indx4 = indx3 + (ieq1 - 1)*ishift1 + 1 - IF( iatom .eq. iatom1 ) CYCLE - - vecout(indx1:indx2) = vecout(indx1:indx2)& - & + coulomb_mt3(:hybrid%nindxm1(l,itype)-1, iatom1,iatom) * vecinhlp(indx4) - - END DO - indx3 = indx3 + atoms%neq(itype1)*ishift1 + ! compute vecout for the indices from 0:ibasm + iatom = 0 + indx1 = 0; indx2 = 0; indx3 = ibasm + DO itype = 1, atoms%ntype + DO ieq = 1, atoms%neq(itype) + iatom = iatom + 1 + DO l = 0, hybrid%lcutm1(itype) + DO m = -l, l + indx1 = indx1 + 1 + indx2 = indx2 + hybrid%nindxm1(l, itype) - 1 + indx3 = indx3 + 1 + + vecout(indx1:indx2) = matmul(coulomb_mt1(:hybrid%nindxm1(l, itype) - 1, :hybrid%nindxm1(l, itype) - 1, l, itype),& + & vecinhlp(indx1:indx2)) + + vecout(indx1:indx2) = vecout(indx1:indx2) + coulomb_mt2(:hybrid%nindxm1(l, itype) - 1, m, l, iatom)*vecinhlp(indx3) + + indx1 = indx2 + END DO + + END DO + END DO END DO - - IF( indx3 .ne. hybrid%nbasp ) STOP 'spmvec: error counting index indx3' - - vecout(indx1:indx2) = vecout(indx1:indx2) + coulomb_mt2(:hybrid%nindxm1(l,itype)-1,0, hybrid%maxlcutm1+1,iatom) * vecinhlp(indx3+1) - - indx0 = indx0 + ishift - END DO - - END DO - END IF - - ! compute vecout for the index-range from ibasm+1:nbasm - + + IF (indx2 /= ibasm) & + & STOP 'spmvec: error counting basis functions' + + IF (ikpt == 1) THEN + iatom = 0 + indx0 = 0 + DO itype = 1, atoms%ntype + ishift = sum((/((2*l + 1)*(hybrid%nindxm1(l, itype) - 1), l=0, hybrid%lcutm1(itype))/)) + DO ieq = 1, atoms%neq(itype) + iatom = iatom + 1 + l = 0 + m = 0 + + indx1 = indx0 + 1 + indx2 = indx1 + hybrid%nindxm1(l, itype) - 2 + + iatom1 = 0 + indx3 = ibasm + DO itype1 = 1, atoms%ntype + ishift1 = (hybrid%lcutm1(itype1) + 1)**2 + DO ieq1 = 1, atoms%neq(itype1) + iatom1 = iatom1 + 1 + indx4 = indx3 + (ieq1 - 1)*ishift1 + 1 + IF (iatom == iatom1) CYCLE + + vecout(indx1:indx2) = vecout(indx1:indx2)& + & + coulomb_mt3(:hybrid%nindxm1(l, itype) - 1, iatom1, iatom)*vecinhlp(indx4) + + END DO + indx3 = indx3 + atoms%neq(itype1)*ishift1 + END DO + + IF (indx3 /= hybrid%nbasp) STOP 'spmvec: error counting index indx3' + + vecout(indx1:indx2) = vecout(indx1:indx2) + coulomb_mt2(:hybrid%nindxm1(l, itype) - 1, 0, hybrid%maxlcutm1 + 1, iatom)*vecinhlp(indx3 + 1) + + indx0 = indx0 + ishift + END DO + + END DO + END IF + + ! compute vecout for the index-range from ibasm+1:nbasm + #ifdef CPP_IRCOULOMBAPPROX - - indx0 = sum( (/ ( ((2*l+1)*atoms%neq(itype),l=0,hybrid%lcutm1(itype)), itype=1,atoms%ntype ) /) )+ hybrid%ngptm - indx1 = sum( (/ ( ((2*l+1)*atoms%neq(itype),l=0,hybrid%lcutm1(itype)), itype=1,atoms%ntype ) /) ) - - CALL ZGEMV('N',indx1,indx0,(1.0,0.0),coulomb_mtir,& - & (hybrid%maxlcutm1+1)**2*atoms,vecinhlp(ibasm+1:),& - & 1,(0.0,0.0),vecout(ibasm+1:),1) - - CALL ZGEMV('C',indx1,hybrid,(1.0,0.0),coulomb_mtir(:indx1,indx1+1:)& - & ,indx1,vecinhlp(ibasm+1:),1,(0.0,0.0),& - & vecout(ibasm+indx1+1:),1) + + indx0 = sum((/(((2*l + 1)*atoms%neq(itype), l=0, hybrid%lcutm1(itype)), itype=1, atoms%ntype)/)) + hybrid%ngptm + indx1 = sum((/(((2*l + 1)*atoms%neq(itype), l=0, hybrid%lcutm1(itype)), itype=1, atoms%ntype)/)) + + CALL ZGEMV('N', indx1, indx0, (1.0, 0.0), coulomb_mtir,& + & (hybrid%maxlcutm1 + 1)**2*atoms, vecinhlp(ibasm + 1:),& + & 1, (0.0, 0.0), vecout(ibasm + 1:), 1) + + CALL ZGEMV('C', indx1, hybrid, (1.0, 0.0), coulomb_mtir(:indx1, indx1 + 1:)& + & , indx1, vecinhlp(ibasm + 1:), 1, (0.0, 0.0),& + & vecout(ibasm + indx1 + 1:), 1) ! vecout(ibasm+1:ibasm+indx1) = matmul( coulomb_mtir(:indx1,:indx0),vecinhlp(ibasm+1:ibasm+indx0) ) ! vecout(ibasm+indx1+1:ibasm+indx0) = matmul( conjg(transpose(coulomb_mtir(:indx1,indx1+1:indx0))), ! & vecinhlp(ibasm+1:ibasm+indx1) ) - - indx0 = ibasm + indx1 - IF( indx0 .ne. hybrid%nbasp ) STOP 'spmvec: error indx0' - DO i = 1,hybrid%ngptm - indx0 = indx0 + 1 - igptm = hybrid%pgptm(i) - gnorm = sqrt(sum(matmul(kpts%bk(:) + hybrid%gptm(:,igptm),cell%bmat)**2)) - IF( gnorm .eq. 0 ) CYCLE - vecout(indx0) = vecout(indx0) + fpi*vecinhlp(indx0)/gnorm - END DO - + indx0 = ibasm + indx1 + IF (indx0 /= hybrid%nbasp) STOP 'spmvec: error indx0' + DO i = 1, hybrid%ngptm + indx0 = indx0 + 1 + igptm = hybrid%pgptm(i) + gnorm = sqrt(sum(matmul(kpts%bk(:) + hybrid%gptm(:, igptm), cell%bmat)**2)) + IF (gnorm == 0) CYCLE + vecout(indx0) = vecout(indx0) + fpi*vecinhlp(indx0)/gnorm + END DO + #else - indx1 = sum( (/ ( ((2*l+1)*atoms%neq(itype),l=0,hybrid%lcutm1(itype)),& - & itype=1,atoms%ntype ) /) )+ hybrid%ngptm(ikpt) - call zhpmv('U',indx1,(1.0,0.0),coulomb_mtir,vecinhlp(ibasm+1), 1,(0.0,0.0),vecout(ibasm+1),1) + indx1 = sum((/(((2*l + 1)*atoms%neq(itype), l=0, hybrid%lcutm1(itype)),& + & itype=1, atoms%ntype)/)) + hybrid%ngptm(ikpt) + call zhpmv('U', indx1, (1.0, 0.0), coulomb_mtir, vecinhlp(ibasm + 1), 1, (0.0, 0.0), vecout(ibasm + 1), 1) #endif - iatom = 0 - indx1 = ibasm; indx2 = 0; indx3 = 0 - DO itype = 1,atoms%ntype - DO ieq = 1,atoms%neq(itype) - iatom = iatom + 1 - DO l = 0,hybrid%lcutm1(itype) - n = hybrid%nindxm1(l,itype) - DO m = -l,l - indx1 = indx1 + 1 - indx2 = indx2 + 1 - indx3 = indx3 + n - 1 - - vecout(indx1) = vecout(indx1) + dotprod(coulomb_mt2(:n-1,m,l,iatom), vecinhlp(indx2:indx3)) - indx2 = indx3 + iatom = 0 + indx1 = ibasm; indx2 = 0; indx3 = 0 + DO itype = 1, atoms%ntype + DO ieq = 1, atoms%neq(itype) + iatom = iatom + 1 + DO l = 0, hybrid%lcutm1(itype) + n = hybrid%nindxm1(l, itype) + DO m = -l, l + indx1 = indx1 + 1 + indx2 = indx2 + 1 + indx3 = indx3 + n - 1 + + vecout(indx1) = vecout(indx1) + dotprod(coulomb_mt2(:n - 1, m, l, iatom), vecinhlp(indx2:indx3)) + indx2 = indx3 + END DO + + END DO + END DO END DO - - END DO - END DO - END DO - - - IF( ikpt .eq. 1 ) THEN - iatom = 0 - indx0 = 0 - DO itype = 1,atoms%ntype - ishift = sum( (/ ((2*l+1)*(hybrid%nindxm1(l,itype)-1), l=0,hybrid%lcutm1(itype) )/) ) - DO ieq = 1,atoms%neq(itype) - iatom = iatom + 1 - indx1 = indx0 + 1 - indx2 = indx1 + hybrid%nindxm1(0,itype) - 2 - vecout(hybrid%nbasp+1) = vecout(hybrid%nbasp+1) + dotprod(coulomb_mt2(:hybrid%nindxm1(0,itype)-1,0, hybrid%maxlcutm1+1,iatom), vecinhlp(indx1:indx2)) - - indx0 = indx0 + ishift - END DO - END DO - - iatom = 0 - indx0 = ibasm - DO itype = 1,atoms%ntype - ishift = (hybrid%lcutm1(itype)+1)**2 - DO ieq = 1,atoms%neq(itype) - iatom = iatom + 1 - indx1 = indx0 + 1 - - iatom1 = 0 - indx2 = 0 - DO itype1 = 1,atoms%ntype - ishift1 = sum( (/ ( (2*l+1)*(hybrid%nindxm1(l,itype1)-1), l=0,hybrid%lcutm1(itype1)) /)) - DO ieq1 = 1,atoms%neq(itype1) - iatom1 = iatom1 + 1 - IF( iatom1 .eq. iatom ) CYCLE - - indx3 = indx2 + (ieq1 - 1)*ishift1 + 1 - indx4 = indx3 + hybrid%nindxm1(0,itype1) - 2 - - vecout(indx1) = vecout(indx1) + dotprod(coulomb_mt3(:hybrid%nindxm1(0,itype1)-1,iatom,iatom1), vecinhlp(indx3:indx4)) - - END DO - indx2 = indx2 + atoms%neq(itype1)*ishift1 - END DO - indx0 = indx0 + ishift - END DO - END DO - IF( indx0 .ne. hybrid%nbasp ) STOP 'spmvec: error index counting (indx0)' - END IF - - CALL reorder(hybrid%nbasm(ikpt),hybrid%nbasp,atoms,hybrid%lcutm1,hybrid%maxlcutm1,hybrid%nindxm1,& - & 2,& - & vec_c=vecout) - - - END SUBROUTINE spmvec_noinvs - - - SUBROUTINE reorder(nbasm,nbasp,atoms,lcutm, maxlcutm,nindxm,imode, vec_r,vec_c) - USE m_types - IMPLICIT NONE - TYPE(t_atoms),INTENT(IN) :: atoms - - ! - scalars - - INTEGER, INTENT(IN) :: maxlcutm - INTEGER, INTENT(IN) :: nbasm,nbasp - INTEGER, INTENT(IN) :: imode - - - ! - arrays - - INTEGER, INTENT(IN) :: lcutm(atoms%ntype) - INTEGER, INTENT(IN) :: nindxm(0:maxlcutm,atoms%ntype) - REAL , INTENT(INOUT),OPTIONAL:: vec_r(nbasm) - COMPLEX, INTENT(INOUT),OPTIONAL:: vec_c(nbasm) - ! - local scalars - - INTEGER :: itype,ieq - INTEGER :: indx1,indx2 - INTEGER :: l - INTEGER :: n,m - LOGICAL :: l_real - ! - local arrays - - REAL :: vechlp_r(nbasm) - COMPLEX :: vechlp_c(nbasm) - - l_real=PRESENT(vec_r) - - IF( imode .ne. 1 .and. imode .ne. 2 ) STOP 'reorder: imode equals neither 1 nor 2' - - if (l_real) THEN - vechlp_r = vec_r - else - vechlp_c = vec_c - end if - - IF( imode .eq. 1 ) THEN - indx1 = 0 - indx2 = 0 - DO itype = 1,atoms%ntype - DO ieq = 1,atoms%neq(itype) - DO l = 0,lcutm(itype) - DO m = -l,l - DO n = 1,nindxm(l,itype)-1 - indx1 = indx1 + 1 - indx2 = indx2 + 1 - if (l_real) THEN - vec_r(indx1) = vechlp_r(indx2) - else - vec_c(indx1) = vechlp_c(indx2) - endif - END DO - indx2 = indx2 + 1 - END DO - END DO - END DO - END DO - - indx2 = 0 - DO itype = 1,atoms%ntype - DO ieq = 1,atoms%neq(itype) - DO l = 0,lcutm(itype) - DO m = -l,l - indx1 = indx1 + 1 - indx2 = indx2 + nindxm(l,itype) - if (l_real) THEN - vec_r(indx1) = vechlp_r(indx2) - else - vec_c(indx1) = vechlp_c(indx2) - endif - - END DO - END DO - END DO - END DO - ELSE IF (imode .eq. 2) THEN - indx1 = 0 - indx2 = 0 - DO itype = 1,atoms%ntype - DO ieq = 1,atoms%neq(itype) - DO l = 0,lcutm(itype) - DO m = -l,l - DO n = 1,nindxm(l,itype)-1 - indx1 = indx1 + 1 - indx2 = indx2 + 1 - if (l_real) THEN - vec_r(indx2) = vechlp_r(indx1) - else - vec_c(indx2) = vechlp_c(indx1) - endif - END DO - indx2 = indx2 + 1 - END DO - END DO - END DO - END DO - - indx2 = 0 - DO itype = 1,atoms%ntype - DO ieq = 1,atoms%neq(itype) - DO l = 0,lcutm(itype) - DO m = -l,l - indx1 = indx1 + 1 - indx2 = indx2 + nindxm(l,itype) - if (l_real) THEN - vec_r(indx2) = vechlp_r(indx1) - else - vec_c(indx2) = vechlp_c(indx1) - endif - END DO - END DO - END DO - END DO - END IF - !IR must not be rearranged - END SUBROUTINE reorder - + IF (ikpt == 1) THEN + iatom = 0 + indx0 = 0 + DO itype = 1, atoms%ntype + ishift = sum((/((2*l + 1)*(hybrid%nindxm1(l, itype) - 1), l=0, hybrid%lcutm1(itype))/)) + DO ieq = 1, atoms%neq(itype) + iatom = iatom + 1 + indx1 = indx0 + 1 + indx2 = indx1 + hybrid%nindxm1(0, itype) - 2 + vecout(hybrid%nbasp + 1) = vecout(hybrid%nbasp + 1) + dotprod(coulomb_mt2(:hybrid%nindxm1(0, itype) - 1, 0, hybrid%maxlcutm1 + 1, iatom), vecinhlp(indx1:indx2)) + + indx0 = indx0 + ishift + END DO + END DO + + iatom = 0 + indx0 = ibasm + DO itype = 1, atoms%ntype + ishift = (hybrid%lcutm1(itype) + 1)**2 + DO ieq = 1, atoms%neq(itype) + iatom = iatom + 1 + indx1 = indx0 + 1 + + iatom1 = 0 + indx2 = 0 + DO itype1 = 1, atoms%ntype + ishift1 = sum((/((2*l + 1)*(hybrid%nindxm1(l, itype1) - 1), l=0, hybrid%lcutm1(itype1))/)) + DO ieq1 = 1, atoms%neq(itype1) + iatom1 = iatom1 + 1 + IF (iatom1 == iatom) CYCLE + + indx3 = indx2 + (ieq1 - 1)*ishift1 + 1 + indx4 = indx3 + hybrid%nindxm1(0, itype1) - 2 + + vecout(indx1) = vecout(indx1) + dotprod(coulomb_mt3(:hybrid%nindxm1(0, itype1) - 1, iatom, iatom1), vecinhlp(indx3:indx4)) + + END DO + indx2 = indx2 + atoms%neq(itype1)*ishift1 + END DO + indx0 = indx0 + ishift + END DO + END DO + IF (indx0 /= hybrid%nbasp) STOP 'spmvec: error index counting (indx0)' + END IF + + CALL reorder(hybrid%nbasm(ikpt), hybrid%nbasp, atoms, hybrid%lcutm1, hybrid%maxlcutm1, hybrid%nindxm1,& + & 2,& + & vec_c=vecout) + + END SUBROUTINE spmvec_noinvs + + SUBROUTINE reorder(nbasm, nbasp, atoms, lcutm, maxlcutm, nindxm, imode, vec_r, vec_c) + USE m_types + IMPLICIT NONE + TYPE(t_atoms), INTENT(IN) :: atoms + + ! - scalars - + INTEGER, INTENT(IN) :: maxlcutm + INTEGER, INTENT(IN) :: nbasm, nbasp + INTEGER, INTENT(IN) :: imode + + ! - arrays - + INTEGER, INTENT(IN) :: lcutm(atoms%ntype) + INTEGER, INTENT(IN) :: nindxm(0:maxlcutm, atoms%ntype) + REAL, INTENT(INOUT), OPTIONAL:: vec_r(nbasm) + COMPLEX, INTENT(INOUT), OPTIONAL:: vec_c(nbasm) + ! - local scalars - + INTEGER :: itype, ieq + INTEGER :: indx1, indx2 + INTEGER :: l + INTEGER :: n, m + LOGICAL :: l_real + ! - local arrays - + REAL :: vechlp_r(nbasm) + COMPLEX :: vechlp_c(nbasm) + + l_real = PRESENT(vec_r) + + IF (imode /= 1 .and. imode /= 2) STOP 'reorder: imode equals neither 1 nor 2' + + if (l_real) THEN + vechlp_r = vec_r + else + vechlp_c = vec_c + end if + + IF (imode == 1) THEN + indx1 = 0 + indx2 = 0 + DO itype = 1, atoms%ntype + DO ieq = 1, atoms%neq(itype) + DO l = 0, lcutm(itype) + DO m = -l, l + DO n = 1, nindxm(l, itype) - 1 + indx1 = indx1 + 1 + indx2 = indx2 + 1 + if (l_real) THEN + vec_r(indx1) = vechlp_r(indx2) + else + vec_c(indx1) = vechlp_c(indx2) + endif + END DO + indx2 = indx2 + 1 + END DO + END DO + END DO + END DO + + indx2 = 0 + DO itype = 1, atoms%ntype + DO ieq = 1, atoms%neq(itype) + DO l = 0, lcutm(itype) + DO m = -l, l + indx1 = indx1 + 1 + indx2 = indx2 + nindxm(l, itype) + if (l_real) THEN + vec_r(indx1) = vechlp_r(indx2) + else + vec_c(indx1) = vechlp_c(indx2) + endif + + END DO + END DO + END DO + END DO + ELSE IF (imode == 2) THEN + indx1 = 0 + indx2 = 0 + DO itype = 1, atoms%ntype + DO ieq = 1, atoms%neq(itype) + DO l = 0, lcutm(itype) + DO m = -l, l + DO n = 1, nindxm(l, itype) - 1 + indx1 = indx1 + 1 + indx2 = indx2 + 1 + if (l_real) THEN + vec_r(indx2) = vechlp_r(indx1) + else + vec_c(indx2) = vechlp_c(indx1) + endif + END DO + indx2 = indx2 + 1 + END DO + END DO + END DO + END DO + + indx2 = 0 + DO itype = 1, atoms%ntype + DO ieq = 1, atoms%neq(itype) + DO l = 0, lcutm(itype) + DO m = -l, l + indx1 = indx1 + 1 + indx2 = indx2 + nindxm(l, itype) + if (l_real) THEN + vec_r(indx2) = vechlp_r(indx1) + else + vec_c(indx2) = vechlp_c(indx1) + endif + END DO + END DO + END DO + END DO + END IF + !IR must not be rearranged + + END SUBROUTINE reorder + END MODULE diff --git a/hybrid/subvxc.F90 b/hybrid/subvxc.F90 index f103656b011e309062a1dc9b71fb40404d8390ec..2b79a0ca11ad3c28b95b9df179f35eaaa7f9f3b8 100644 --- a/hybrid/subvxc.F90 +++ b/hybrid/subvxc.F90 @@ -8,15 +8,14 @@ MODULE m_subvxc CONTAINS - SUBROUTINE subvxc(lapw,bk,DIMENSION,input,jsp,vr0,atoms,usdus,hybrid,el,ello,sym,& - cell,sphhar,stars,xcpot,mpi,oneD,hmat,vx) - + SUBROUTINE subvxc(lapw, bk, DIMENSION, input, jsp, vr0, atoms, usdus, hybrid, el, ello, sym, & + cell, sphhar, stars, xcpot, mpi, oneD, hmat, vx) USE m_types USE m_judft - USE m_intgr, ONLY : intgr3 + USE m_intgr, ONLY: intgr3 USE m_constants - USE m_gaunt, ONLY : gaunt1 + USE m_gaunt, ONLY: gaunt1 USE m_wrapper USE m_loddop USE m_radflo @@ -25,107 +24,106 @@ CONTAINS IMPLICIT NONE - 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_input), INTENT(IN) :: input - TYPE(t_sym), INTENT(IN) :: sym - TYPE(t_stars), INTENT(IN) :: stars - TYPE(t_cell), INTENT(IN) :: cell - TYPE(t_sphhar), INTENT(IN) :: sphhar - TYPE(t_atoms), INTENT(IN) :: atoms - TYPE(t_lapw), INTENT(IN) :: lapw - TYPE(t_usdus), INTENT(INOUT) :: usdus - TYPE(t_potden), INTENT(IN) :: vx - TYPE(t_mat), INTENT(INOUT) :: hmat + 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_input), INTENT(IN) :: input + TYPE(t_sym), INTENT(IN) :: sym + TYPE(t_stars), INTENT(IN) :: stars + TYPE(t_cell), INTENT(IN) :: cell + TYPE(t_sphhar), INTENT(IN) :: sphhar + TYPE(t_atoms), INTENT(IN) :: atoms + TYPE(t_lapw), INTENT(IN) :: lapw + TYPE(t_usdus), INTENT(INOUT) :: usdus + TYPE(t_potden), INTENT(IN) :: vx + TYPE(t_mat), INTENT(INOUT) :: hmat ! Scalar Arguments - INTEGER, INTENT (IN) :: jsp + INTEGER, INTENT(IN) :: jsp ! Array Arguments - REAL, INTENT (IN) :: vr0(atoms%jmtd,atoms%ntype,input%jspins) ! just for radial functions - REAL, INTENT (IN) :: el(0:atoms%lmaxd,atoms%ntype,input%jspins) - REAL, INTENT (IN) :: ello(atoms%nlod,atoms%ntype,input%jspins) - REAL, INTENT (IN) :: bk(3) + REAL, INTENT(IN) :: vr0(atoms%jmtd, atoms%ntype, input%jspins) ! just for radial functions + REAL, INTENT(IN) :: el(0:atoms%lmaxd, atoms%ntype, input%jspins) + REAL, INTENT(IN) :: ello(atoms%nlod, atoms%ntype, input%jspins) + REAL, INTENT(IN) :: bk(3) ! Local Scalars - INTEGER :: ic,indx,m,ig1,ig2,n,nn - INTEGER :: nlharm,nnbas,typsym,lm - INTEGER :: noded,nodeu + INTEGER :: ic, indx, m, ig1, ig2, n, nn + INTEGER :: nlharm, nnbas, typsym, lm + INTEGER :: noded, nodeu INTEGER :: nbasf0 - INTEGER :: i,j,l,ll,l1,l2 ,m1,m2 ,j1,j2 - INTEGER :: ok,p1,p2,lh,mh,pp1,pp2 - INTEGER :: igrid,itype,ilharm,istar - INTEGER :: ineq,iatom,ilo,ilop,ieq,icentry - INTEGER :: ikvecat,ikvecprevat,invsfct,ikvec,ikvecp - INTEGER :: lp,mp,pp + INTEGER :: i, j, l, ll, l1, l2, m1, m2, j1, j2 + INTEGER :: ok, p1, p2, lh, mh, pp1, pp2 + INTEGER :: igrid, itype, ilharm, istar + INTEGER :: ineq, iatom, ilo, ilop, ieq, icentry + INTEGER :: ikvecat, ikvecprevat, invsfct, ikvec, ikvecp + INTEGER :: lp, mp, pp REAL :: a_ex REAL :: wronk - COMPLEX :: rc,rr + COMPLEX :: rc, rr ! Local Arrays INTEGER :: gg(3) - INTEGER :: pointer_lo(atoms%nlod,atoms%ntype) + INTEGER :: pointer_lo(atoms%nlod, atoms%ntype) - REAL :: integ(0:sphhar%nlhd,hybrid%maxindx,0:atoms%lmaxd,hybrid%maxindx,0:atoms%lmaxd) + REAL :: integ(0:sphhar%nlhd, hybrid%maxindx, 0:atoms%lmaxd, hybrid%maxindx, 0:atoms%lmaxd) REAL :: grid(atoms%jmtd) - REAL :: vr(atoms%jmtd,0:sphhar%nlhd) - REAL :: f(atoms%jmtd,2,0:atoms%lmaxd),g(atoms%jmtd,2,0:atoms%lmaxd) - REAL :: flo(atoms%jmtd,2,atoms%nlod) - REAL :: uuilon(atoms%nlod,atoms%ntype),duilon(atoms%nlod,atoms%ntype) - REAL :: ulouilopn(atoms%nlod,atoms%nlod,atoms%ntype) + REAL :: vr(atoms%jmtd, 0:sphhar%nlhd) + REAL :: f(atoms%jmtd, 2, 0:atoms%lmaxd), g(atoms%jmtd, 2, 0:atoms%lmaxd) + REAL :: flo(atoms%jmtd, 2, atoms%nlod) + REAL :: uuilon(atoms%nlod, atoms%ntype), duilon(atoms%nlod, atoms%ntype) + REAL :: ulouilopn(atoms%nlod, atoms%nlod, atoms%ntype) - REAL :: bas1(atoms%jmtd,hybrid%maxindx,0:atoms%lmaxd,atoms%ntype) - REAL :: bas2(atoms%jmtd,hybrid%maxindx,0:atoms%lmaxd,atoms%ntype) + REAL :: bas1(atoms%jmtd, hybrid%maxindx, 0:atoms%lmaxd, atoms%ntype) + REAL :: bas2(atoms%jmtd, hybrid%maxindx, 0:atoms%lmaxd, atoms%ntype) COMPLEX :: vpw(stars%ng3) - COMPLEX :: vxc(hmat%matsize1*(hmat%matsize1+1)/2) - COMPLEX :: vrmat(hybrid%maxlmindx,hybrid%maxlmindx) - COMPLEX :: carr(hybrid%maxlmindx,DIMENSION%nvd),carr1(DIMENSION%nvd,DIMENSION%nvd) - COMPLEX ,ALLOCATABLE :: ahlp(:,:,:),bhlp(:,:,:) - COMPLEX, ALLOCATABLE :: bascof(:,:,:) + COMPLEX :: vxc(hmat%matsize1*(hmat%matsize1 + 1)/2) + COMPLEX :: vrmat(hybrid%maxlmindx, hybrid%maxlmindx) + COMPLEX :: carr(hybrid%maxlmindx, DIMENSION%nvd), carr1(DIMENSION%nvd, DIMENSION%nvd) + COMPLEX, ALLOCATABLE :: ahlp(:, :, :), bhlp(:, :, :) + COMPLEX, ALLOCATABLE :: bascof(:, :, :) #ifndef CPP_OLDINTEL - COMPLEX :: bascof_lo(3,-atoms%llod:atoms%llod,4*atoms%llod+2,atoms%nlod, atoms%nat) + COMPLEX :: bascof_lo(3, -atoms%llod:atoms%llod, 4*atoms%llod + 2, atoms%nlod, atoms%nat) #endif CALL timestart("subvxc") - vxc=0 - + vxc = 0 ! Calculate radial functions - hybrid%nindx = 2 - DO itype = 1,atoms%ntype + hybrid%nindx = 2 + DO itype = 1, atoms%ntype ! Generate the radial basis-functions for each l - WRITE(6,'(a,i3,a)') new_LINE('n')//new_LINE('n')//' wavefunction parameters for atom type',itype,':' - WRITE(6,'(31x,a,32x,a)') 'radial function','energy derivative' - WRITE(6,'(a)') ' l energy value '//& - 'derivative nodes value derivative nodes norm wronskian' - DO l = 0,atoms%lmax(itype) - CALL radfun(l,itype,jsp,el(l,itype,jsp),vr0(1,itype,jsp),atoms,f(1,1,l),g(1,1,l),usdus,nodeu,noded,wronk) - WRITE (6,FMT=8010) l,el(l,itype,jsp),usdus%us(l,itype,jsp),& - usdus%dus(l,itype,jsp),nodeu,usdus%uds(l,itype,jsp),usdus%duds(l,itype,jsp),noded,& - usdus%ddn(l,itype,jsp),wronk + WRITE (6, '(a,i3,a)') new_LINE('n')//new_LINE('n')//' wavefunction parameters for atom type', itype, ':' + WRITE (6, '(31x,a,32x,a)') 'radial function', 'energy derivative' + WRITE (6, '(a)') ' l energy value '// & + 'derivative nodes value derivative nodes norm wronskian' + DO l = 0, atoms%lmax(itype) + CALL radfun(l, itype, jsp, el(l, itype, jsp), vr0(1, itype, jsp), atoms, f(1, 1, l), g(1, 1, l), usdus, nodeu, noded, wronk) + WRITE (6, FMT=8010) l, el(l, itype, jsp), usdus%us(l, itype, jsp), & + usdus%dus(l, itype, jsp), nodeu, usdus%uds(l, itype, jsp), usdus%duds(l, itype, jsp), noded, & + usdus%ddn(l, itype, jsp), wronk END DO -8010 FORMAT (i3,f10.5,2 (5x,1p,2e16.7,i5),1p,2e16.7) +8010 FORMAT(i3, f10.5, 2(5x, 1p, 2e16.7, i5), 1p, 2e16.7) - bas1(:,1,:,itype) = f(:,1,:) - bas1(:,2,:,itype) = g(:,1,:) - bas2(:,1,:,itype) = f(:,2,:) - bas2(:,2,:,itype) = g(:,2,:) + bas1(:, 1, :, itype) = f(:, 1, :) + bas1(:, 2, :, itype) = g(:, 1, :) + bas2(:, 1, :, itype) = f(:, 2, :) + bas2(:, 2, :, itype) = g(:, 2, :) ! Generate the extra radial basis-functions for the local orbitals, if there are any. - IF (atoms%nlo(itype).GE.1) THEN - CALL radflo(atoms,itype,jsp,ello(1,1,jsp),vr0(1,itype,jsp),f,g,mpi,& - usdus,uuilon,duilon,ulouilopn,flo,.TRUE.) + IF (atoms%nlo(itype) >= 1) THEN + CALL radflo(atoms, itype, jsp, ello(1, 1, jsp), vr0(1, itype, jsp), f, g, mpi, & + usdus, uuilon, duilon, ulouilopn, flo, .TRUE.) DO i = 1, atoms%nlo(itype) - hybrid%nindx(atoms%llo(i,itype),itype) = hybrid%nindx(atoms%llo(i,itype),itype) + 1 - pointer_lo(i,itype) = hybrid%nindx(atoms%llo(i,itype),itype) - bas1(:,hybrid%nindx(atoms%llo(i,itype),itype),atoms%llo(i,itype),itype) = flo(:,1,i) - bas2(:,hybrid%nindx(atoms%llo(i,itype),itype),atoms%llo(i,itype),itype) = flo(:,2,i) + hybrid%nindx(atoms%llo(i, itype), itype) = hybrid%nindx(atoms%llo(i, itype), itype) + 1 + pointer_lo(i, itype) = hybrid%nindx(atoms%llo(i, itype), itype) + bas1(:, hybrid%nindx(atoms%llo(i, itype), itype), atoms%llo(i, itype), itype) = flo(:, 1, i) + bas2(:, hybrid%nindx(atoms%llo(i, itype), itype), atoms%llo(i, itype), itype) = flo(:, 2, i) END DO END IF END DO @@ -133,30 +131,30 @@ CONTAINS ! Compute APW coefficients ! Calculate bascof - ALLOCATE(ahlp(DIMENSION%nvd,0:DIMENSION%lmd,atoms%nat),bhlp(DIMENSION%nvd,0:DIMENSION%lmd,atoms%nat),stat=ok) - IF(ok.NE.0) STOP 'subvxc: error in allocation of ahlp/bhlp' + ALLOCATE (ahlp(DIMENSION%nvd, 0:DIMENSION%lmd, atoms%nat), bhlp(DIMENSION%nvd, 0:DIMENSION%lmd, atoms%nat), stat=ok) + IF (ok /= 0) STOP 'subvxc: error in allocation of ahlp/bhlp' #ifndef CPP_OLDINTEL - CALL abcof3(input,atoms,sym,jsp,cell,bk,lapw,usdus,oneD,ahlp,bhlp,bascof_lo) + CALL abcof3(input, atoms, sym, jsp, cell, bk, lapw, usdus, oneD, ahlp, bhlp, bascof_lo) #endif - ALLOCATE(bascof(DIMENSION%nvd,2*(DIMENSION%lmd+1),atoms%nat), stat=ok) - IF(ok.NE.0) STOP 'subvxc: error in allocation of bascof' + ALLOCATE (bascof(DIMENSION%nvd, 2*(DIMENSION%lmd + 1), atoms%nat), stat=ok) + IF (ok /= 0) STOP 'subvxc: error in allocation of bascof' bascof = 0 - ic = 0 + ic = 0 DO itype = 1, atoms%ntype DO ieq = 1, atoms%neq(itype) ic = ic + 1 indx = 0 DO l = 0, atoms%lmax(itype) - ll = l*(l+1) + ll = l*(l + 1) DO M = -l, l - lm = ll + M + lm = ll + M DO i = 1, 2 indx = indx + 1 - IF(i.EQ.1) THEN - bascof(:,indx,ic) = ahlp(:,lm,ic) - ELSE IF(i.EQ.2) THEN - bascof(:,indx,ic) = bhlp(:,lm,ic) + IF (i == 1) THEN + bascof(:, indx, ic) = ahlp(:, lm, ic) + ELSE IF (i == 2) THEN + bascof(:, indx, ic) = bhlp(:, lm, ic) END IF END DO END DO @@ -164,24 +162,24 @@ CONTAINS END DO END DO - DEALLOCATE(ahlp,bhlp) + DEALLOCATE (ahlp, bhlp) ! Loop over atom types iatom = 0 DO itype = 1, atoms%ntype - typsym = atoms%ntypsy(SUM(atoms%neq(:itype-1))+1) + typsym = atoms%ntypsy(SUM(atoms%neq(:itype - 1)) + 1) nlharm = sphhar%nlh(typsym) ! Calculate vxc = vtot - vcoul - DO l=0,nlharm - DO i=1,atoms%jri(itype) - IF(l.EQ.0) THEN - ! vr(i,0)= vrtot(i,0,itype)*sfp/rmsh(i,itype) - vrcou(i,0,itype,jsp) - vr(i,0)= vx%mt(i,0,itype,jsp)! * sfp_const / atoms%rmsh(i,itype) + DO l = 0, nlharm + DO i = 1, atoms%jri(itype) + IF (l == 0) THEN + ! vr(i,0)= vrtot(i,0,itype)*sfp/rmsh(i,itype) - vrcou(i,0,itype,jsp) + vr(i, 0) = vx%mt(i, 0, itype, jsp)! * sfp_const / atoms%rmsh(i,itype) ELSE ! vxc = vtot - vcoul ! vr(i,l)= vrtot(i,l,itype)-vrcou(i,l,itype,jsp) - vr(i,l)= vx%mt(i,l,itype,jsp) + vr(i, l) = vx%mt(i, l, itype, jsp) END IF END DO END DO @@ -194,16 +192,16 @@ CONTAINS DO p1 = 1, 2 i = i + 1 j = 0 - DO l2 = 0, atoms%lmax(itype) + DO l2 = 0, atoms%lmax(itype) DO p2 = 1, 2 j = j + 1 - IF(j.LE.i) THEN + IF (j <= i) THEN DO igrid = 1, atoms%jri(itype) - grid(igrid) = vr(igrid,ilharm) * (bas1(igrid,p1,l1,itype) * bas1(igrid,p2,l2,itype) +& - bas2(igrid,p1,l1,itype) * bas2(igrid,p2,l2,itype)) + grid(igrid) = vr(igrid, ilharm)*(bas1(igrid, p1, l1, itype)*bas1(igrid, p2, l2, itype) + & + bas2(igrid, p1, l1, itype)*bas2(igrid, p2, l2, itype)) END DO - CALL intgr3(grid,atoms%rmsh(:,itype),atoms%dx(itype),atoms%jri(itype),integ(ilharm,p1,l1,p2,l2)) - integ(ilharm,p2,l2,p1,l1) = integ(ilharm,p1,l1,p2,l2) + CALL intgr3(grid, atoms%rmsh(:, itype), atoms%dx(itype), atoms%jri(itype), integ(ilharm, p1, l1, p2, l2)) + integ(ilharm, p2, l2, p1, l1) = integ(ilharm, p1, l1, p2, l2) END IF END DO END DO @@ -212,11 +210,11 @@ CONTAINS END DO ! Calculate muffin tin contribution to vxc matrix - vrmat=0 + vrmat = 0 - j1=0 + j1 = 0 DO l1 = 0, atoms%lmax(itype) ! loop: left basis function - DO m1 = -l1,l1 + DO m1 = -l1, l1 DO p1 = 1, 2 j1 = j1 + 1 j2 = 0 @@ -226,15 +224,15 @@ CONTAINS j2 = j2 + 1 rr = 0 DO ilharm = 0, nlharm ! loop: lattice harmonics of vxc - l = sphhar%llh(ilharm,typsym) - DO i = 1, sphhar%nmem(ilharm,typsym) - M = sphhar%mlh(i,ilharm,typsym) - rc = sphhar%clnu(i,ilharm,typsym) * gaunt1(l1,l,l2,m1,M,m2,atoms%lmaxd) - rr = rr + integ(ilharm,p1,l1,p2,l2) * rc + l = sphhar%llh(ilharm, typsym) + DO i = 1, sphhar%nmem(ilharm, typsym) + M = sphhar%mlh(i, ilharm, typsym) + rc = sphhar%clnu(i, ilharm, typsym)*gaunt1(l1, l, l2, m1, M, m2, atoms%lmaxd) + rr = rr + integ(ilharm, p1, l1, p2, l2)*rc END DO END DO - rc = CMPLX(0,1)**(l2-l1) ! adjusts to a/b/ccof-scaling - vrmat(j1,j2) = rr * rc + rc = CMPLX(0, 1)**(l2 - l1) ! adjusts to a/b/ccof-scaling + vrmat(j1, j2) = rr*rc END DO END DO END DO @@ -244,17 +242,17 @@ CONTAINS nnbas = j1 ! Project on bascof - DO ineq = 1,atoms%neq(itype) - iatom = iatom+1 - carr (:nnbas,:lapw%nv(jsp)) = CONJG(MATMUL(vrmat(:nnbas,:nnbas),& - TRANSPOSE(bascof(:lapw%nv(jsp),:nnbas,iatom)))) - carr1(:lapw%nv(jsp),:lapw%nv(jsp)) = MATMUL(bascof(:lapw%nv(jsp),:nnbas,iatom),carr(:nnbas,:lapw%nv(jsp))) + DO ineq = 1, atoms%neq(itype) + iatom = iatom + 1 + carr(:nnbas, :lapw%nv(jsp)) = CONJG(MATMUL(vrmat(:nnbas, :nnbas), & + TRANSPOSE(bascof(:lapw%nv(jsp), :nnbas, iatom)))) + carr1(:lapw%nv(jsp), :lapw%nv(jsp)) = MATMUL(bascof(:lapw%nv(jsp), :nnbas, iatom), carr(:nnbas, :lapw%nv(jsp))) ic = 0 - DO j = 1,lapw%nv(jsp) + DO j = 1, lapw%nv(jsp) ! carr(:nnbas) = matmul(vrmat(:nnbas,:nnbas),bascof(j,:nnbas,iatom) ) DO i = 1, j ic = ic + 1 - vxc(ic) = vxc(ic) + carr1(i,j) + vxc(ic) = vxc(ic) + carr1(i, j) ! vxc(ic) = vxc(ic) + conjg(dotprod ( bascof(i,:nnbas,iatom),carr(:nnbas) )) END DO END DO @@ -262,9 +260,9 @@ CONTAINS END DO ! End loop over atom types ! Calculate plane wave contribution - DO i=1,stars%ng3 - vpw(i)= vx%pw_w(i,jsp) - ! vpw(i)=vpwtot(i)-vpwcou(i,jsp) + DO i = 1, stars%ng3 + vpw(i) = vx%pw_w(i, jsp) + ! vpw(i)=vpwtot(i)-vpwcou(i,jsp) END DO ! Calculate vxc-matrix, left basis function (ig1) @@ -273,26 +271,26 @@ CONTAINS DO ig1 = 1, lapw%nv(jsp) DO ig2 = 1, ig1 ic = ic + 1 - gg(1) = lapw%k1(ig1,jsp) - lapw%k1(ig2,jsp) - gg(2) = lapw%k2(ig1,jsp) - lapw%k2(ig2,jsp) - gg(3) = lapw%k3(ig1,jsp) - lapw%k3(ig2,jsp) - istar = stars%ig(gg(1),gg(2),gg(3)) - IF(istar.NE.0) THEN - vxc(ic)= vxc(ic) + stars%rgphs(gg(1),gg(2),gg(3))*vpw(istar) + gg(1) = lapw%k1(ig1, jsp) - lapw%k1(ig2, jsp) + gg(2) = lapw%k2(ig1, jsp) - lapw%k2(ig2, jsp) + gg(3) = lapw%k3(ig1, jsp) - lapw%k3(ig2, jsp) + istar = stars%ig(gg(1), gg(2), gg(3)) + IF (istar /= 0) THEN + vxc(ic) = vxc(ic) + stars%rgphs(gg(1), gg(2), gg(3))*vpw(istar) ELSE - IF (mpi%irank == 0) THEN - WRITE(6,'(A,/6I5)') 'Warning: Gi-Gj not in any star:',& - lapw%k1(ig1,jsp),lapw%k2(ig1,jsp),lapw%k3(ig1,jsp),& - lapw%k1(ig2,jsp),lapw%k2(ig2,jsp),lapw%k3(ig2,jsp) + IF (mpi%irank == 0) THEN + WRITE (6, '(A,/6I5)') 'Warning: Gi-Gj not in any star:', & + lapw%k1(ig1, jsp), lapw%k2(ig1, jsp), lapw%k3(ig1, jsp), & + lapw%k1(ig2, jsp), lapw%k2(ig2, jsp), lapw%k3(ig2, jsp) END IF END IF END DO END DO ! Calculate local orbital contribution - IF(ANY(atoms%nlo.NE.0)) THEN + IF (ANY(atoms%nlo /= 0)) THEN - nbasf0 = lapw%nv(jsp)*(lapw%nv(jsp)+1)/2 ! number of pure APW contributions + nbasf0 = lapw%nv(jsp)*(lapw%nv(jsp) + 1)/2 ! number of pure APW contributions icentry = nbasf0 ! icentry counts the entry in the matrix vxc iatom = 0 ikvecat = 0 @@ -300,17 +298,17 @@ CONTAINS DO itype = 1, atoms%ntype - typsym = atoms%ntypsy(SUM(atoms%neq(:itype-1))+1) + typsym = atoms%ntypsy(SUM(atoms%neq(:itype - 1)) + 1) nlharm = sphhar%nlh(typsym) ! Calculate vxc = vtot - vcoul DO l = 0, nlharm DO i = 1, atoms%jri(itype) - IF(l.EQ.0) THEN + IF (l == 0) THEN ! vr(i,0)= vrtot(i,0,itype)*sfp/rmsh(i,itype) - vrcou(i,0,itype,jsp) - vr(i,0)= vx%mt(i,0,itype,jsp) * sfp_const / atoms%rmsh(i,itype) + vr(i, 0) = vx%mt(i, 0, itype, jsp)*sfp_const/atoms%rmsh(i, itype) ELSE ! vxc = vtot - vcoul - vr(i,l)= vx%mt(i,l,itype,jsp) ! + vr(i, l) = vx%mt(i, l, itype, jsp) ! ! vr(i,l)= vrtot(i,l,itype)-vrcou(i,l,itype,jsp) END IF END DO @@ -320,19 +318,19 @@ CONTAINS DO ilharm = 0, nlharm i = 0 DO l1 = 0, atoms%lmax(itype) - DO p1 = 1, hybrid%nindx(l1,itype) + DO p1 = 1, hybrid%nindx(l1, itype) i = i + 1 j = 0 - DO l2 = 0, atoms%lmax(itype) - DO p2 = 1, hybrid%nindx(l2,itype) + DO l2 = 0, atoms%lmax(itype) + DO p2 = 1, hybrid%nindx(l2, itype) j = j + 1 - IF(j.LE.i) THEN + IF (j <= i) THEN DO igrid = 1, atoms%jri(itype) - grid(igrid)=vr(igrid,ilharm) * (bas1(igrid,p1,l1,itype) * bas1(igrid,p2,l2,itype) +& - bas2(igrid,p1,l1,itype) * bas2(igrid,p2,l2,itype)) + grid(igrid) = vr(igrid, ilharm)*(bas1(igrid, p1, l1, itype)*bas1(igrid, p2, l2, itype) + & + bas2(igrid, p1, l1, itype)*bas2(igrid, p2, l2, itype)) END DO - CALL intgr3(grid,atoms%rmsh(:,itype),atoms%dx(itype),atoms%jri(itype),integ(ilharm,p1,l1,p2,l2)) - integ(ilharm,p2,l2,p1,l1) = integ(ilharm,p1,l1,p2,l2) + CALL intgr3(grid, atoms%rmsh(:, itype), atoms%dx(itype), atoms%jri(itype), integ(ilharm, p1, l1, p2, l2)) + integ(ilharm, p2, l2, p1, l1) = integ(ilharm, p1, l1, p2, l2) END IF END DO END DO @@ -340,29 +338,28 @@ CONTAINS END DO END DO - DO ieq = 1, atoms%neq(itype) iatom = iatom + 1 - IF((atoms%invsat(iatom).EQ.0).OR.(atoms%invsat(iatom).EQ.1)) THEN + IF ((atoms%invsat(iatom) == 0) .OR. (atoms%invsat(iatom) == 1)) THEN - IF(atoms%invsat(iatom).EQ.0) invsfct = 1 - IF(atoms%invsat(iatom).EQ.1) invsfct = 2 + IF (atoms%invsat(iatom) == 0) invsfct = 1 + IF (atoms%invsat(iatom) == 1) invsfct = 2 DO ilo = 1, atoms%nlo(itype) #ifdef CPP_OLDINTEL - CALL judft_error ("no LOs & hybrid with old intel compiler!",calledby="subvxc.F90") + CALL judft_error("no LOs & hybrid with old intel compiler!", calledby="subvxc.F90") #else - l1 = atoms%llo(ilo,itype) - DO ikvec = 1, invsfct*(2*l1+1) + l1 = atoms%llo(ilo, itype) + DO ikvec = 1, invsfct*(2*l1 + 1) DO m1 = -l1, l1 DO p1 = 1, 3 - IF(p1.EQ.3) THEN - pp1 = pointer_lo(ilo,itype) + IF (p1 == 3) THEN + pp1 = pointer_lo(ilo, itype) ELSE pp1 = p1 END IF - IF(hybrid%nindx(l1,itype).LE.2) STOP 'subvxc: error hybrid%nindx' + IF (hybrid%nindx(l1, itype) <= 2) STOP 'subvxc: error hybrid%nindx' lm = 0 @@ -374,26 +371,26 @@ CONTAINS rr = 0 DO ilharm = 0, nlharm - lh = sphhar%llh(ilharm,typsym) - DO i = 1, sphhar%nmem(ilharm,typsym) - mh = sphhar%mlh(i,ilharm,typsym) - rc = sphhar%clnu(i,ilharm,typsym) * gaunt1(l1,lh,l2,m1,mh,m2,atoms%lmaxd) - rr = rr + integ(ilharm,p2,l2,pp1,l1) * rc + lh = sphhar%llh(ilharm, typsym) + DO i = 1, sphhar%nmem(ilharm, typsym) + mh = sphhar%mlh(i, ilharm, typsym) + rc = sphhar%clnu(i, ilharm, typsym)*gaunt1(l1, lh, l2, m1, mh, m2, atoms%lmaxd) + rr = rr + integ(ilharm, p2, l2, pp1, l1)*rc END DO END DO - rc = CMPLX(0.0,1.0)**(l2-l1) ! adjusts to a/b/ccof-scaling + rc = CMPLX(0.0, 1.0)**(l2 - l1) ! adjusts to a/b/ccof-scaling ! ic counts the entry in vxc ic = icentry DO i = 1, lapw%nv(jsp) ic = ic + 1 IF (hmat%l_real) THEN - vxc(ic) = vxc(ic) + invsfct * REAL(rr*rc*bascof(i,lm,iatom) *& - CONJG(bascof_lo(p1,m1,ikvec,ilo,iatom))) + vxc(ic) = vxc(ic) + invsfct*REAL(rr*rc*bascof(i, lm, iatom)* & + CONJG(bascof_lo(p1, m1, ikvec, ilo, iatom))) ELSE - vxc(ic) = vxc(ic) + rr * rc * bascof(i,lm,iatom) *& - CONJG(bascof_lo(p1,m1,ikvec,ilo,iatom)) + vxc(ic) = vxc(ic) + rr*rc*bascof(i, lm, iatom)* & + CONJG(bascof_lo(p1, m1, ikvec, ilo, iatom)) END IF END DO END DO !p2 @@ -401,40 +398,40 @@ CONTAINS END DO ! l2 -> loop over APW ! calcualte matrix-elements with local orbitals at the same atom - IF(ic.NE.icentry+lapw%nv(jsp)) STOP 'subvxc: error counting ic' + IF (ic /= icentry + lapw%nv(jsp)) STOP 'subvxc: error counting ic' ic = ic + ikvecprevat - DO ilop = 1, ilo-1 - lp = atoms%llo(ilop,itype) - DO ikvecp = 1, invsfct*(2*lp+1) + DO ilop = 1, ilo - 1 + lp = atoms%llo(ilop, itype) + DO ikvecp = 1, invsfct*(2*lp + 1) ic = ic + 1 DO mp = -lp, lp DO pp = 1, 3 - IF (pp.EQ.3) THEN - pp2 = pointer_lo(ilop,itype) + IF (pp == 3) THEN + pp2 = pointer_lo(ilop, itype) ELSE pp2 = pp END IF rr = 0 DO ilharm = 0, nlharm - lh = sphhar%llh(ilharm,typsym) - DO i = 1, sphhar%nmem(ilharm,typsym) - mh = sphhar%mlh(i,ilharm,typsym) - rc = sphhar%clnu(i,ilharm,typsym) * gaunt1(l1,lh,lp,m1,mh,mp,atoms%lmaxd) - rr = rr + integ(ilharm,pp2,lp,pp1,l1) * rc + lh = sphhar%llh(ilharm, typsym) + DO i = 1, sphhar%nmem(ilharm, typsym) + mh = sphhar%mlh(i, ilharm, typsym) + rc = sphhar%clnu(i, ilharm, typsym)*gaunt1(l1, lh, lp, m1, mh, mp, atoms%lmaxd) + rr = rr + integ(ilharm, pp2, lp, pp1, l1)*rc END DO END DO - rc = CMPLX(0.0,1.0)**(lp-l1) ! adjusts to a/b/ccof-scaling + rc = CMPLX(0.0, 1.0)**(lp - l1) ! adjusts to a/b/ccof-scaling IF (hmat%l_real) THEN - vxc(ic) = vxc(ic) + invsfct * REAL(rr * rc * bascof_lo(pp,mp,ikvecp,ilop,iatom) *& - CONJG(bascof_lo(p1,m1,ikvec,ilo,iatom))) + vxc(ic) = vxc(ic) + invsfct*REAL(rr*rc*bascof_lo(pp, mp, ikvecp, ilop, iatom)* & + CONJG(bascof_lo(p1, m1, ikvec, ilo, iatom))) ELSE - vxc(ic) = vxc(ic) + rr * rc * bascof_lo(pp,mp,ikvecp, ilop,iatom) *& - CONJG(bascof_lo(p1,m1,ikvec,ilo, iatom)) + vxc(ic) = vxc(ic) + rr*rc*bascof_lo(pp, mp, ikvecp, ilop, iatom)* & + CONJG(bascof_lo(p1, m1, ikvec, ilo, iatom)) END IF END DO ! pp END DO ! mp @@ -446,43 +443,43 @@ CONTAINS DO ikvecp = 1, ikvec ic = ic + 1 - lp = l1 + lp = l1 ilop = ilo DO mp = -lp, lp DO pp = 1, 3 - IF (pp.EQ.3) THEN - pp2 = pointer_lo(ilop,itype) + IF (pp == 3) THEN + pp2 = pointer_lo(ilop, itype) ELSE pp2 = pp END IF rr = 0 DO ilharm = 0, nlharm - lh = sphhar%llh(ilharm,typsym) - DO i = 1, sphhar%nmem(ilharm,typsym) - mh = sphhar%mlh(i,ilharm,typsym) - rc = sphhar%clnu(i,ilharm,typsym) * gaunt1(l1,lh,lp,m1,mh,mp,atoms%lmaxd) - rr = rr + integ(ilharm,pp2,lp,pp1,l1) * rc + lh = sphhar%llh(ilharm, typsym) + DO i = 1, sphhar%nmem(ilharm, typsym) + mh = sphhar%mlh(i, ilharm, typsym) + rc = sphhar%clnu(i, ilharm, typsym)*gaunt1(l1, lh, lp, m1, mh, mp, atoms%lmaxd) + rr = rr + integ(ilharm, pp2, lp, pp1, l1)*rc END DO END DO - rc = CMPLX(0.0,1.0)**(lp-l1) ! adjusts to a/b/ccof-scaling + rc = CMPLX(0.0, 1.0)**(lp - l1) ! adjusts to a/b/ccof-scaling IF (hmat%l_real) THEN - vxc(ic) = vxc(ic) + invsfct*REAL(rr * rc * bascof_lo(pp,mp,ikvecp,ilop,iatom) *& - CONJG(bascof_lo(p1,m1,ikvec,ilo,iatom))) + vxc(ic) = vxc(ic) + invsfct*REAL(rr*rc*bascof_lo(pp, mp, ikvecp, ilop, iatom)* & + CONJG(bascof_lo(p1, m1, ikvec, ilo, iatom))) ELSE - vxc(ic) = vxc(ic) + rr * rc * bascof_lo(pp,mp,ikvecp,ilop, iatom) *& - CONJG(bascof_lo(p1,m1,ikvec,ilo, iatom)) + vxc(ic) = vxc(ic) + rr*rc*bascof_lo(pp, mp, ikvecp, ilop, iatom)* & + CONJG(bascof_lo(p1, m1, ikvec, ilo, iatom)) END IF END DO ! pp END DO ! mp END DO ! ikvecp END DO ! p1 END DO ! m1 - icentry = ic + icentry = ic END DO !ikvec - ikvecat = ikvecat + invsfct*(2*l1+1) + ikvecat = ikvecat + invsfct*(2*l1 + 1) #endif END DO ! ilo ikvecprevat = ikvecprevat + ikvecat @@ -496,23 +493,23 @@ CONTAINS a_ex = xcpot%get_exchange_weight() i = 0 - DO n =1, hmat%matsize1 + DO n = 1, hmat%matsize1 DO nn = 1, n i = i + 1 IF (hmat%l_real) THEN - hmat%data_r(nn,n) = hmat%data_r(nn,n) - a_ex*REAL(vxc(i)) - IF ((n.LE.5).AND.(nn.LE.5)) THEN - WRITE(1235,'(2i7,3f15.8)') n, nn, hmat%data_r(n,nn), hmat%data_r(nn,n), REAL(vxc(i)) + hmat%data_r(nn, n) = hmat%data_r(nn, n) - a_ex*REAL(vxc(i)) + IF ((n <= 5) .AND. (nn <= 5)) THEN + WRITE (1235, '(2i7,3f15.8)') n, nn, hmat%data_r(n, nn), hmat%data_r(nn, n), REAL(vxc(i)) END IF ELSE - hmat%data_c(nn,n) = hmat%data_c(nn,n) - a_ex*vxc(i) + hmat%data_c(nn, n) = hmat%data_c(nn, n) - a_ex*vxc(i) ENDIF END DO END DO CALL timestop("subvxc") - DEALLOCATE(bascof) + DEALLOCATE (bascof) END SUBROUTINE subvxc END MODULE m_subvxc diff --git a/hybrid/symm_hf.F90 b/hybrid/symm_hf.F90 index 7840bc5fba1896e83e6ec4f3e97b680cebf22c9c..8bbe41925f20835f8e1c81af7897c10fc7a1a50c 100644 --- a/hybrid/symm_hf.F90 +++ b/hybrid/symm_hf.F90 @@ -15,136 +15,136 @@ MODULE m_symm_hf CONTAINS -SUBROUTINE symm_hf_init(sym,kpts,nk,nsymop,rrot,psym) + SUBROUTINE symm_hf_init(sym, kpts, nk, nsymop, rrot, psym) - USE m_types - USE m_util ,ONLY: modulo1 + USE m_types + USE m_util, ONLY: modulo1 - IMPLICIT NONE + IMPLICIT NONE - TYPE(t_sym), INTENT(IN) :: sym - TYPE(t_kpts), INTENT(IN) :: kpts - INTEGER, INTENT(IN) :: nk - 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 + TYPE(t_sym), INTENT(IN) :: sym + TYPE(t_kpts), INTENT(IN) :: kpts + INTEGER, INTENT(IN) :: nk + 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) + 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 + ! calculate rotations in reciprocal space + DO i = 1, sym%nsym + IF (i <= 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 + ! 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)) + 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) + !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 + !check if rotkpt is identical to bk(:,nk) + IF (maxval(abs(rotkpt - kpts%bkf(:, nk))) <= 1E-07) THEN + nsymop = nsymop + 1 + psym(nsymop) = i + END IF + END DO - WRITE(6,'(A,i3)') ' nk',nk - WRITE(6,'(A,3f10.5)') ' kpts%bkf(:,nk):',kpts%bkf(:,nk) - WRITE(6,'(A,i3)') ' Number of elements in the little group:',nsymop + WRITE (6, '(A,i3)') ' nk', nk + WRITE (6, '(A,3f10.5)') ' kpts%bkf(:,nk):', kpts%bkf(:, nk) + WRITE (6, '(A,i3)') ' Number of elements in the little group:', nsymop -END SUBROUTINE symm_hf_init + END SUBROUTINE symm_hf_init -SUBROUTINE symm_hf(kpts,nk,sym,dimension,hybdat,eig_irr,atoms,hybrid,cell,& - lapw,jsp,mpi,rrot,nsymop,psym,nkpt_EIBZ,n_q,parent,& - pointer_EIBZ,nsest,indx_sest) + SUBROUTINE symm_hf(kpts, nk, sym, dimension, hybdat, eig_irr, atoms, hybrid, cell, & + lapw, jsp, mpi, rrot, nsymop, psym, nkpt_EIBZ, n_q, parent, & + pointer_EIBZ, nsest, indx_sest) USE m_constants USE m_types - USE m_util ,ONLY: modulo1,intgrf,intgrf_init - USE m_olap ,ONLY: wfolap_inv,wfolap_noinv,wfolap1,wfolap_init - USE m_trafo ,ONLY: waveftrafo_symm + USE m_util, ONLY: modulo1, intgrf, intgrf_init + USE m_olap, ONLY: wfolap_inv, wfolap_noinv, wfolap1, wfolap_init + USE m_trafo, ONLY: waveftrafo_symm USE m_io_hybrid IMPLICIT NONE - TYPE(t_hybdat),INTENT(IN) :: hybdat + TYPE(t_hybdat), INTENT(IN) :: hybdat - TYPE(t_mpi),INTENT(IN) :: mpi - TYPE(t_dimension),INTENT(IN) :: dimension - TYPE(t_hybrid),INTENT(IN) :: hybrid - TYPE(t_sym),INTENT(IN) :: sym - TYPE(t_cell),INTENT(IN) :: cell - TYPE(t_kpts),INTENT(IN) :: kpts - TYPE(t_atoms),INTENT(IN) :: atoms - TYPE(t_lapw),INTENT(IN) :: lapw + TYPE(t_mpi), INTENT(IN) :: mpi + TYPE(t_dimension), INTENT(IN) :: dimension + TYPE(t_hybrid), INTENT(IN) :: hybrid + TYPE(t_sym), INTENT(IN) :: sym + TYPE(t_cell), INTENT(IN) :: cell + TYPE(t_kpts), INTENT(IN) :: kpts + TYPE(t_atoms), INTENT(IN) :: atoms + TYPE(t_lapw), INTENT(IN) :: lapw ! - scalars - - INTEGER,INTENT(IN) :: nk - INTEGER,INTENT(IN) :: jsp - INTEGER,INTENT(OUT) :: nkpt_EIBZ - INTEGER,INTENT(IN) :: nsymop + INTEGER, INTENT(IN) :: nk + INTEGER, INTENT(IN) :: jsp + INTEGER, INTENT(OUT) :: nkpt_EIBZ + INTEGER, INTENT(IN) :: nsymop ! - arrays - - INTEGER,INTENT(IN) :: rrot(3,3,sym%nsym) - INTEGER,INTENT(IN) :: psym(sym%nsym) - INTEGER,INTENT(OUT) :: parent(kpts%nkptf) - INTEGER,INTENT(OUT) :: nsest(hybrid%nbands(nk)), indx_sest(hybrid%nbands(nk),hybrid%nbands(nk)) - INTEGER,ALLOCATABLE,INTENT(OUT) :: pointer_EIBZ(:) - INTEGER,ALLOCATABLE,INTENT(OUT) :: n_q(:) + INTEGER, INTENT(IN) :: rrot(3, 3, sym%nsym) + INTEGER, INTENT(IN) :: psym(sym%nsym) + INTEGER, INTENT(OUT) :: parent(kpts%nkptf) + INTEGER, INTENT(OUT) :: nsest(hybrid%nbands(nk)), indx_sest(hybrid%nbands(nk), hybrid%nbands(nk)) + INTEGER, ALLOCATABLE, INTENT(OUT) :: pointer_EIBZ(:) + INTEGER, ALLOCATABLE, INTENT(OUT) :: n_q(:) - REAL,INTENT(IN) :: eig_irr(dimension%neigd,kpts%nkpt) + REAL, INTENT(IN) :: eig_irr(dimension%neigd, kpts%nkpt) ! - local scalars - - INTEGER :: ikpt,ikpt1,iop,isym,iisym,m - INTEGER :: itype,ieq,iatom,ratom - INTEGER :: iband,iband1,iband2,iatom0 - INTEGER :: i,j,ic,ic1,ic2 - INTEGER :: irecl_cmt,irecl_z + INTEGER :: ikpt, ikpt1, iop, isym, iisym, m + INTEGER :: itype, ieq, iatom, ratom + INTEGER :: iband, iband1, iband2, iatom0 + INTEGER :: i, j, ic, ic1, ic2 + INTEGER :: irecl_cmt, irecl_z INTEGER :: ok - INTEGER :: l,lm - INTEGER :: n1,n2,nn - INTEGER :: ndb,ndb1,ndb2 + INTEGER :: l, lm + INTEGER :: n1, n2, nn + INTEGER :: ndb, ndb1, ndb2 INTEGER :: nrkpt INTEGER :: maxndb, nddb - REAL :: tolerance,pi + REAL :: tolerance, pi COMPLEX :: cdum - COMPLEX , PARAMETER :: img = (0.0,1.0) + COMPLEX, PARAMETER :: img = (0.0, 1.0) ! - local arrays - INTEGER :: neqvkpt(kpts%nkptf) INTEGER :: list(kpts%nkptf) INTEGER :: degenerat(hybrid%ne_eig(nk)) - INTEGER,ALLOCATABLE :: help(:) - - REAL :: rotkpt(3),g(3) - REAL ,ALLOCATABLE :: olapmt(:,:,:,:) + INTEGER, ALLOCATABLE :: help(:) - COMPLEX :: cmt(dimension%neigd,hybrid%maxlmindx,atoms%nat) - COMPLEX :: carr1(hybrid%maxlmindx,atoms%nat) - COMPLEX,ALLOCATABLE :: carr(:),wavefolap(:,:) - COMPLEX,ALLOCATABLE :: cmthlp(:,:,:) - COMPLEX,ALLOCATABLE :: cpwhlp(:,:) - COMPLEX,ALLOCATABLE :: trace(:,:) + REAL :: rotkpt(3), g(3) + REAL, ALLOCATABLE :: olapmt(:, :, :, :) - TYPE(t_mat) :: olappw,z - COMPLEX,ALLOCATABLE :: rep_d(:,:,:) - LOGICAL,ALLOCATABLE :: symequivalent(:,:) + COMPLEX :: cmt(dimension%neigd, hybrid%maxlmindx, atoms%nat) + COMPLEX :: carr1(hybrid%maxlmindx, atoms%nat) + COMPLEX, ALLOCATABLE :: carr(:), wavefolap(:, :) + COMPLEX, ALLOCATABLE :: cmthlp(:, :, :) + COMPLEX, ALLOCATABLE :: cpwhlp(:, :) + COMPLEX, ALLOCATABLE :: trace(:, :) - WRITE(6,'(A)') new_line('n') // new_line('n') // '### subroutine: symm ###' + TYPE(t_mat) :: olappw, z + COMPLEX, ALLOCATABLE :: rep_d(:, :, :) + LOGICAL, ALLOCATABLE :: symequivalent(:, :) + + WRITE (6, '(A)') new_line('n')//new_line('n')//'### subroutine: symm ###' ! determine extented irreducible BZ of k ( EIBZ(k) ), i.e. ! those k-points, which can generate the whole BZ by @@ -152,89 +152,85 @@ SUBROUTINE symm_hf(kpts,nk,sym,dimension,hybdat,eig_irr,atoms,hybrid,cell,& neqvkpt = 0 - DO i=1,kpts%nkptf - list(i) = i-1 + DO i = 1, kpts%nkptf + list(i) = i - 1 END DO - DO ikpt=2,kpts%nkptf - DO iop=1,nsymop + DO ikpt = 2, kpts%nkptf + DO iop = 1, nsymop - rotkpt = matmul( rrot(:,:,psym(iop)), kpts%bkf(:,ikpt) ) + rotkpt = matmul(rrot(:, :, psym(iop)), kpts%bkf(:, ikpt)) - !transfer rotkpt into BZ - rotkpt = modulo1(rotkpt,kpts%nkpt3) + !transfer rotkpt into BZ + rotkpt = modulo1(rotkpt, kpts%nkpt3) + + !determine number of rotkpt + nrkpt = 0 + DO ikpt1 = 1, kpts%nkptf + IF (maxval(abs(rotkpt - kpts%bkf(:, ikpt1))) <= 1E-06) THEN + nrkpt = ikpt1 + EXIT + END IF + END DO + IF (nrkpt == 0) STOP 'symm: Difference vector not found !' - !determine number of rotkpt - nrkpt = 0 - DO ikpt1=1,kpts%nkptf - IF ( maxval( abs( rotkpt - kpts%bkf(:,ikpt1) ) ) <= 1E-06 ) THEN - nrkpt = ikpt1 - EXIT + IF (list(nrkpt) /= 0) THEN + list(nrkpt) = 0 + neqvkpt(ikpt) = neqvkpt(ikpt) + 1 + parent(nrkpt) = ikpt END IF - END DO - IF( nrkpt .eq.0 ) STOP 'symm: Difference vector not found !' - - IF( list(nrkpt) .ne. 0) THEN - list(nrkpt) = 0 - neqvkpt(ikpt) = neqvkpt(ikpt) + 1 - parent(nrkpt) = ikpt - END IF - IF ( all(list .eq. 0) ) EXIT + IF (all(list == 0)) EXIT - END DO + END DO END DO ! for the Gamma-point holds: - parent(1) = 1 + parent(1) = 1 neqvkpt(1) = 1 - - ! determine number of members in the EIBZ(k) ic = 0 - DO ikpt=1,kpts%nkptf - IF(parent(ikpt) .eq. ikpt) ic = ic + 1 + DO ikpt = 1, kpts%nkptf + IF (parent(ikpt) == ikpt) ic = ic + 1 END DO nkpt_EIBZ = ic - ALLOCATE( pointer_EIBZ(nkpt_EIBZ) ) + ALLOCATE (pointer_EIBZ(nkpt_EIBZ)) ic = 0 - DO ikpt=1,kpts%nkptf - IF(parent(ikpt) .eq. ikpt) THEN - ic = ic + 1 - pointer_EIBZ(ic) = ikpt - END IF + DO ikpt = 1, kpts%nkptf + IF (parent(ikpt) == ikpt) THEN + ic = ic + 1 + pointer_EIBZ(ic) = ikpt + END IF END DO - WRITE(6,'(A,i5)') ' Number of k-points in the EIBZ',nkpt_EIBZ - + WRITE (6, '(A,i5)') ' Number of k-points in the EIBZ', nkpt_EIBZ ! determine the factor n_q, that means the number of symmetrie operations of the little group of bk(:,nk) ! which keep q (in EIBZ) invariant - ALLOCATE( n_q(nkpt_EIBZ) ) + ALLOCATE (n_q(nkpt_EIBZ)) - ic = 0 + ic = 0 n_q = 0 - DO ikpt = 1,kpts%nkptf - IF ( parent(ikpt) .eq. ikpt ) THEN - ic = ic + 1 - DO iop=1,nsymop - isym = psym(iop) - rotkpt = matmul( rrot(:,:,isym), kpts%bkf(:,ikpt) ) + DO ikpt = 1, kpts%nkptf + IF (parent(ikpt) == ikpt) THEN + ic = ic + 1 + DO iop = 1, nsymop + isym = psym(iop) + rotkpt = matmul(rrot(:, :, isym), kpts%bkf(:, ikpt)) - !transfer rotkpt into BZ - rotkpt = modulo1(rotkpt,kpts%nkpt3) + !transfer rotkpt into BZ + rotkpt = modulo1(rotkpt, kpts%nkpt3) - !check if rotkpt is identical to bk(:,ikpt) - IF( maxval( abs( rotkpt - kpts%bkf(:,ikpt) ) ) .le. 1E-06) THEN - n_q(ic) = n_q(ic) + 1 - END IF - END DO - END IF + !check if rotkpt is identical to bk(:,ikpt) + IF (maxval(abs(rotkpt - kpts%bkf(:, ikpt))) <= 1E-06) THEN + n_q(ic) = n_q(ic) + 1 + END IF + END DO + END IF END DO - IF( ic .ne. nkpt_EIBZ ) STOP 'symm: failure EIBZ' - + IF (ic /= nkpt_EIBZ) STOP 'symm: failure EIBZ' ! calculate degeneracy: ! degenerat(i) = 1 state i is not degenerat, @@ -245,255 +241,251 @@ SUBROUTINE symm_hf(kpts,nk,sym,dimension,hybdat,eig_irr,atoms,hybrid,cell,& degenerat = 1 - WRITE(6,'(A,f10.8)') ' Tolerance for determining degenerate states=', tolerance + WRITE (6, '(A,f10.8)') ' Tolerance for determining degenerate states=', tolerance - DO i=1,hybrid%nbands(nk) - DO j=i+1,hybrid%nbands(nk) - IF( abs(eig_irr(i,nk)-eig_irr(j,nk)) .le. tolerance) THEN - degenerat(i) = degenerat(i) + 1 - END IF - END DO + DO i = 1, hybrid%nbands(nk) + DO j = i + 1, hybrid%nbands(nk) + IF (abs(eig_irr(i, nk) - eig_irr(j, nk)) <= tolerance) THEN + degenerat(i) = degenerat(i) + 1 + END IF + END DO END DO - DO i=1,hybrid%ne_eig(nk) - IF ( degenerat(i) .ne. 1 .or. degenerat(i) .ne. 0 ) THEN - degenerat(i+1:i+degenerat(i)-1) = 0 - END IF + DO i = 1, hybrid%ne_eig(nk) + IF (degenerat(i) /= 1 .or. degenerat(i) /= 0) THEN + degenerat(i + 1:i + degenerat(i) - 1) = 0 + END IF END DO - ! maximal number of degenerate bands -> maxndb maxndb = maxval(degenerat) ! number of different degenerate bands/states - nddb = count( degenerat .ge. 1) + nddb = count(degenerat >= 1) - WRITE(6,*) ' Degenerate states:' - DO iband = 1,hybrid%nbands(nk)/5+1 - WRITE(6,'(5i5)')degenerat(iband*5-4:min(iband*5,hybrid%nbands(nk))) + WRITE (6, *) ' Degenerate states:' + DO iband = 1, hybrid%nbands(nk)/5 + 1 + WRITE (6, '(5i5)') degenerat(iband*5 - 4:min(iband*5, hybrid%nbands(nk))) END DO - IF( irreps ) THEN - ! calculate representation, i.e. the action of an element of - ! the little group of k on \phi_n,k: - ! P(R,T)\phi_n,k = \sum_{n'\in degenerat(n)} rep_v(n',n) *\phi_n',k - - ! read in cmt and z at current k-point (nk) - CALL read_cmt(cmt,nk) - call read_z(z,nk) - - ALLOCATE(rep_d(maxndb,nddb,nsymop),stat=ok ) - IF(ok.NE.0) STOP 'symm: failure allocation rep_v' - - call olappw%alloc(z%l_real,lapw%nv(jsp),lapw%nv(jsp)) - ALLOCATE( olapmt(hybrid%maxindx,hybrid%maxindx,0:atoms%lmaxd,atoms%ntype),stat=ok) - IF(ok.NE.0) STOP 'symm: failure allocation olapmt' - - olapmt = 0 - CALL wfolap_init(olappw,olapmt,lapw%gvec(:,:,jsp),atoms,hybrid,cell,hybdat%bas1,hybdat%bas2) - - ALLOCATE(cmthlp(hybrid%maxlmindx,atoms%nat,maxndb), cpwhlp(lapw%nv(jsp),maxndb),stat= ok ) - IF(ok.NE.0) STOP 'symm: failure allocation cmthlp/cpwhlp' - - DO isym=1,nsymop - iop= psym(isym) - - ic = 0 - DO i=1,hybrid%nbands(nk) - ndb = degenerat(i) - IF ( ndb .ge. 1 ) THEN - ic = ic + 1 - cmthlp = 0 - cpwhlp = 0 - - CALL waveftrafo_symm(cmthlp(:,:,:ndb),cpwhlp(:,:ndb),cmt,z%l_real,z%data_r,z%data_c,& - i,ndb,nk,iop,atoms,hybrid,kpts,sym,jsp,dimension,cell,lapw) - - DO iband = 1,ndb - carr1 = cmt(iband+i-1,:,:) - IF(z%l_real) THEN - rep_d(iband,ic,isym) = wfolap_inv( carr1,z%data_r(:lapw%nv(jsp),iband+i-1),cmthlp(:,:,iband),& - cpwhlp(:,iband), lapw%nv(jsp),lapw%nv(jsp),olappw%data_r,olapmt,atoms,hybrid) - else - rep_d(iband,ic,isym) = wfolap_noinv( carr1,z%data_c(:lapw%nv(jsp),iband+i-1),cmthlp(:,:,iband),& - cpwhlp(:,iband), lapw%nv(jsp),lapw%nv(jsp),olappw%data_c,olapmt,atoms,hybrid) - endif - END DO - - END IF - END DO - - END DO - - DEALLOCATE( cmthlp,cpwhlp ) - - - ! calculate trace of irrecudible representation - ALLOCATE( trace(sym%nsym,nddb), stat=ok ) - IF( ok .ne. 0) STOP 'symm: failure allocation trace' + IF (irreps) THEN + ! calculate representation, i.e. the action of an element of + ! the little group of k on \phi_n,k: + ! P(R,T)\phi_n,k = \sum_{n'\in degenerat(n)} rep_v(n',n) *\phi_n',k + + ! read in cmt and z at current k-point (nk) + CALL read_cmt(cmt, nk) + call read_z(z, nk) + + ALLOCATE (rep_d(maxndb, nddb, nsymop), stat=ok) + IF (ok /= 0) STOP 'symm: failure allocation rep_v' + + call olappw%alloc(z%l_real, lapw%nv(jsp), lapw%nv(jsp)) + ALLOCATE (olapmt(hybrid%maxindx, hybrid%maxindx, 0:atoms%lmaxd, atoms%ntype), stat=ok) + IF (ok /= 0) STOP 'symm: failure allocation olapmt' + + olapmt = 0 + CALL wfolap_init(olappw, olapmt, lapw%gvec(:, :, jsp), atoms, hybrid, cell, hybdat%bas1, hybdat%bas2) + + ALLOCATE (cmthlp(hybrid%maxlmindx, atoms%nat, maxndb), cpwhlp(lapw%nv(jsp), maxndb), stat=ok) + IF (ok /= 0) STOP 'symm: failure allocation cmthlp/cpwhlp' + + DO isym = 1, nsymop + iop = psym(isym) + + ic = 0 + DO i = 1, hybrid%nbands(nk) + ndb = degenerat(i) + IF (ndb >= 1) THEN + ic = ic + 1 + cmthlp = 0 + cpwhlp = 0 + + CALL waveftrafo_symm(cmthlp(:, :, :ndb), cpwhlp(:, :ndb), cmt, z%l_real, z%data_r, z%data_c, & + i, ndb, nk, iop, atoms, hybrid, kpts, sym, jsp, dimension, cell, lapw) + + DO iband = 1, ndb + carr1 = cmt(iband + i - 1, :, :) + IF (z%l_real) THEN + rep_d(iband, ic, isym) = wfolap_inv(carr1, z%data_r(:lapw%nv(jsp), iband + i - 1), cmthlp(:, :, iband), & + cpwhlp(:, iband), lapw%nv(jsp), lapw%nv(jsp), olappw%data_r, olapmt, atoms, hybrid) + else + rep_d(iband, ic, isym) = wfolap_noinv(carr1, z%data_c(:lapw%nv(jsp), iband + i - 1), cmthlp(:, :, iband), & + cpwhlp(:, iband), lapw%nv(jsp), lapw%nv(jsp), olappw%data_c, olapmt, atoms, hybrid) + endif + END DO - ic = 0 - trace = 0 - DO iband = 1,hybrid%nbands(nk) - ndb = degenerat(iband) - IF( ndb .ge. 1 ) THEN - ic = ic + 1 - !calculate trace - DO iop = 1,nsymop - isym = psym(iop) - DO i = 1,ndb - trace(isym,ic) = trace(isym,ic) + rep_d(i,ic,iop) - END DO + END IF END DO - END IF - END DO - - ! determine symmetry equivalent bands/irreducible representations by comparing the trace - - ALLOCATE( symequivalent(nddb,nddb), stat=ok ) - IF( ok .ne. 0) STOP 'symm: failure allocation symequivalent' - - ic1 = 0 - symequivalent = .false. - DO iband1 = 1,hybrid%nbands(nk) - ndb1 = degenerat(iband1) - IF( ndb1 .ge. 1 ) THEN - ic1 = ic1 + 1 - ic2 = 0 - DO iband2 = 1,hybrid%nbands(nk) - ndb2 = degenerat(iband2) - IF( ndb2 .ge. 1 ) THEN - ic2 = ic2 + 1 - IF( ndb2 .eq. ndb1 ) THEN - ! note that this criterium is only valid for pure spatial rotations - ! if one combines spatial rotations with time reversal symmetry there - ! is no unique criteria to identify symequivalent state - ! however, also in the latter case the trace of the spatial rotations - ! for two symmetry equivalent states must be equivalent - IF( all(abs(trace(:sym%nop,ic1)-trace(:sym%nop,ic2)) <= 1E-8))& - & THEN - symequivalent(ic2,ic1) = .true. + END DO + + DEALLOCATE (cmthlp, cpwhlp) + + ! calculate trace of irrecudible representation + ALLOCATE (trace(sym%nsym, nddb), stat=ok) + IF (ok /= 0) STOP 'symm: failure allocation trace' + + ic = 0 + trace = 0 + DO iband = 1, hybrid%nbands(nk) + ndb = degenerat(iband) + IF (ndb >= 1) THEN + ic = ic + 1 + !calculate trace + DO iop = 1, nsymop + isym = psym(iop) + DO i = 1, ndb + trace(isym, ic) = trace(isym, ic) + rep_d(i, ic, iop) + END DO + END DO + END IF + END DO + + ! determine symmetry equivalent bands/irreducible representations by comparing the trace + + ALLOCATE (symequivalent(nddb, nddb), stat=ok) + IF (ok /= 0) STOP 'symm: failure allocation symequivalent' + + ic1 = 0 + symequivalent = .false. + DO iband1 = 1, hybrid%nbands(nk) + ndb1 = degenerat(iband1) + IF (ndb1 >= 1) THEN + ic1 = ic1 + 1 + ic2 = 0 + DO iband2 = 1, hybrid%nbands(nk) + ndb2 = degenerat(iband2) + IF (ndb2 >= 1) THEN + ic2 = ic2 + 1 + IF (ndb2 == ndb1) THEN + ! note that this criterium is only valid for pure spatial rotations + ! if one combines spatial rotations with time reversal symmetry there + ! is no unique criteria to identify symequivalent state + ! however, also in the latter case the trace of the spatial rotations + ! for two symmetry equivalent states must be equivalent + IF (all(abs(trace(:sym%nop, ic1) - trace(:sym%nop, ic2)) <= 1E-8))& + & THEN + symequivalent(ic2, ic1) = .true. + END IF + END IF END IF - END IF - END IF - END DO - END IF - END DO - - + END DO + END IF + END DO + ELSE - ! read in cmt and z at current k-point (nk) - - CALL read_cmt(cmt,nk) - !CALL intgrf_init(atoms%ntype,atoms%jmtd,atoms%jri,atoms%dx,atoms%rmsh,hybdat%gridf) - - IF( allocated(olapmt)) deallocate(olapmt) - ALLOCATE( olapmt(hybrid%maxindx,hybrid%maxindx,0:atoms%lmaxd,atoms%ntype),stat=ok) - IF( ok .ne. 0) STOP 'symm: failure allocation olapmt' - olapmt = 0 - - DO itype = 1,atoms%ntype - DO l = 0,atoms%lmax(itype) - nn = hybrid%nindx(l,itype) - DO n2 = 1,nn - DO n1 = 1,nn - olapmt(n1,n2,l,itype) = intgrf ( & - & hybdat%bas1(:,n1,l,itype)*hybdat%bas1(:,n2,l,itype)& - & +hybdat%bas2(:,n1,l,itype)*hybdat%bas2(:,n2,l,itype),& - & atoms%jri,atoms%jmtd,atoms%rmsh,atoms%dx,atoms%ntype,itype,hybdat%gridf) - END DO + ! read in cmt and z at current k-point (nk) + + CALL read_cmt(cmt, nk) + !CALL intgrf_init(atoms%ntype,atoms%jmtd,atoms%jri,atoms%dx,atoms%rmsh,hybdat%gridf) + + IF (allocated(olapmt)) deallocate (olapmt) + ALLOCATE (olapmt(hybrid%maxindx, hybrid%maxindx, 0:atoms%lmaxd, atoms%ntype), stat=ok) + IF (ok /= 0) STOP 'symm: failure allocation olapmt' + olapmt = 0 + + DO itype = 1, atoms%ntype + DO l = 0, atoms%lmax(itype) + nn = hybrid%nindx(l, itype) + DO n2 = 1, nn + DO n1 = 1, nn + olapmt(n1, n2, l, itype) = intgrf( & + & hybdat%bas1(:, n1, l, itype)*hybdat%bas1(:, n2, l, itype)& + & + hybdat%bas2(:, n1, l, itype)*hybdat%bas2(:, n2, l, itype),& + & atoms%jri, atoms%jmtd, atoms%rmsh, atoms%dx, atoms%ntype, itype, hybdat%gridf) + END DO + END DO END DO - END DO - END DO - - ALLOCATE( wavefolap(hybrid%nbands(nk),hybrid%nbands(nk)),carr(hybrid%maxindx),stat=ok ) - IF( ok .ne. 0) STOP 'symm: failure allocation wfolap/maxindx' - wavefolap = 0 - - iatom = 0 - DO itype = 1,atoms%ntype - DO ieq = 1,atoms%neq(itype) - iatom = iatom + 1 - lm = 0 - DO l = 0,atoms%lmax(itype) - DO M = -l,l - nn = hybrid%nindx(l,itype) - DO iband1 = 1,hybrid%nbands(nk) - carr(:nn) = matmul( olapmt(:nn,:nn,l,itype),& - & cmt(iband1,lm+1:lm+nn,iatom)) - DO iband2 = 1,iband1 - wavefolap(iband2,iband1)& - & = wavefolap(iband2,iband1)& - & + dot_product(cmt(iband2,lm+1:lm+nn,iatom),carr(:nn)) + END DO + + ALLOCATE (wavefolap(hybrid%nbands(nk), hybrid%nbands(nk)), carr(hybrid%maxindx), stat=ok) + IF (ok /= 0) STOP 'symm: failure allocation wfolap/maxindx' + wavefolap = 0 + + iatom = 0 + DO itype = 1, atoms%ntype + DO ieq = 1, atoms%neq(itype) + iatom = iatom + 1 + lm = 0 + DO l = 0, atoms%lmax(itype) + DO M = -l, l + nn = hybrid%nindx(l, itype) + DO iband1 = 1, hybrid%nbands(nk) + carr(:nn) = matmul(olapmt(:nn, :nn, l, itype),& + & cmt(iband1, lm + 1:lm + nn, iatom)) + DO iband2 = 1, iband1 + wavefolap(iband2, iband1)& + & = wavefolap(iband2, iband1)& + & + dot_product(cmt(iband2, lm + 1:lm + nn, iatom), carr(:nn)) + END DO + END DO + lm = lm + nn END DO - END DO - lm = lm + nn - END DO + END DO END DO - END DO - END DO - - DO iband1 = 1,hybrid%nbands(nk) - DO iband2 = 1,iband1 - wavefolap(iband1,iband2) = conjg(wavefolap(iband2,iband1)) - END DO - END DO - - ALLOCATE( symequivalent(nddb,nddb), stat=ok ) - IF( ok .ne. 0) STOP 'symm: failure allocation symequivalent' - symequivalent = .false. - ic1 = 0 - DO iband1 = 1,hybrid%nbands(nk) - ndb1 = degenerat(iband1) - IF( ndb1 .eq. 0 ) CYCLE - ic1 = ic1 + 1 - ic2 = 0 - DO iband2 = 1,hybrid%nbands(nk) - ndb2 = degenerat(iband2) - IF( ndb2 .eq. 0 ) CYCLE - ic2 = ic2 + 1 - IF( any( abs(wavefolap(iband1:iband1+ndb1-1,& - & iband2:iband2+ndb2-1)) > 1E-9 ) )THEN + END DO + + DO iband1 = 1, hybrid%nbands(nk) + DO iband2 = 1, iband1 + wavefolap(iband1, iband2) = conjg(wavefolap(iband2, iband1)) + END DO + END DO + + ALLOCATE (symequivalent(nddb, nddb), stat=ok) + IF (ok /= 0) STOP 'symm: failure allocation symequivalent' + symequivalent = .false. + ic1 = 0 + DO iband1 = 1, hybrid%nbands(nk) + ndb1 = degenerat(iband1) + IF (ndb1 == 0) CYCLE + ic1 = ic1 + 1 + ic2 = 0 + DO iband2 = 1, hybrid%nbands(nk) + ndb2 = degenerat(iband2) + IF (ndb2 == 0) CYCLE + ic2 = ic2 + 1 + IF (any(abs(wavefolap(iband1:iband1 + ndb1 - 1,& + & iband2:iband2 + ndb2 - 1)) > 1E-9)) THEN ! & .and. ndb1 .eq. ndb2 ) THEN - symequivalent(ic2,ic1) = .true. - END IF - END DO - END DO + symequivalent(ic2, ic1) = .true. + END IF + END DO + END DO END IF - + ! ! generate index field which contain the band combinations (n1,n2), - ! which are non zero - ! - - ic1 = 0 + ! which are non zero + ! + + ic1 = 0 indx_sest = 0 - nsest = 0 - DO iband1 = 1,hybrid%nbands(nk) - ndb1 = degenerat(iband1) - IF( ndb1 .ge. 1 ) ic1 = ic1 + 1 - i = 0 - DO WHILE ( degenerat(iband1-i) == 0 ) - i = i+1 - END DO - ndb1 = degenerat(iband1-i) - ic2 = 0 - DO iband2 = 1,hybrid%nbands(nk) - ndb2 = degenerat(iband2) - IF( ndb2 .ge. 1 ) ic2 = ic2 + 1 - i = 0 - DO WHILE ( degenerat(iband2-i) == 0 ) - i = i+1 - END DO - ndb2 = degenerat(iband2-i) - ! only upper triangular part - IF( symequivalent(ic2,ic1) .and. iband2 .le. iband1 ) THEN + nsest = 0 + DO iband1 = 1, hybrid%nbands(nk) + ndb1 = degenerat(iband1) + IF (ndb1 >= 1) ic1 = ic1 + 1 + i = 0 + DO WHILE (degenerat(iband1 - i) == 0) + i = i + 1 + END DO + ndb1 = degenerat(iband1 - i) + ic2 = 0 + DO iband2 = 1, hybrid%nbands(nk) + ndb2 = degenerat(iband2) + IF (ndb2 >= 1) ic2 = ic2 + 1 + i = 0 + DO WHILE (degenerat(iband2 - i) == 0) + i = i + 1 + END DO + ndb2 = degenerat(iband2 - i) + ! only upper triangular part + IF (symequivalent(ic2, ic1) .and. iband2 <= iband1) THEN ! IF( ndb1 .ne. ndb2 ) STOP 'symm_hf: failure symequivalent' - nsest(iband1) = nsest(iband1) + 1 - indx_sest(nsest(iband1),iband1) = iband2 - END IF - END DO + nsest(iband1) = nsest(iband1) + 1 + indx_sest(nsest(iband1), iband1) = iband2 + END IF + END DO END DO ! @@ -509,64 +501,64 @@ SUBROUTINE symm_hf(kpts,nk,sym,dimension,hybdat,eig_irr,atoms,hybrid,cell,& pi = pimach() - IF( hybdat%lmaxcd .gt. atoms%lmaxd ) STOP & + IF (hybdat%lmaxcd > atoms%lmaxd) STOP & & 'symm_hf: The very impropable case that hybdat%lmaxcd > atoms%lmaxd occurs' - iatom = 0 + iatom = 0 iatom0 = 0 - DO itype = 1,atoms%ntype - DO ieq = 1,atoms%neq(itype) - iatom = iatom + 1 - DO iop = 1,nsymop - isym = psym(iop) - IF( isym .le. sym%nop) THEN - iisym = isym - ELSE - iisym = isym - sym%nop - END IF - - ratom = hybrid%map(iatom,isym) - rotkpt = matmul( rrot(:,:,isym), kpts%bkf(:,nk) ) - g = nint(rotkpt - kpts%bkf(:,nk)) - - cdum = exp(-2*pi*img*dot_product(rotkpt,sym%tau(:,iisym)))* & - & exp( 2*pi*img*dot_product(g,atoms%taual(:,ratom))) - END DO - END DO - iatom0 = iatom0 + atoms%neq(itype) + DO itype = 1, atoms%ntype + DO ieq = 1, atoms%neq(itype) + iatom = iatom + 1 + DO iop = 1, nsymop + isym = psym(iop) + IF (isym <= sym%nop) THEN + iisym = isym + ELSE + iisym = isym - sym%nop + END IF + + ratom = hybrid%map(iatom, isym) + rotkpt = matmul(rrot(:, :, isym), kpts%bkf(:, nk)) + g = nint(rotkpt - kpts%bkf(:, nk)) + + cdum = exp(-2*pi*img*dot_product(rotkpt, sym%tau(:, iisym)))* & + & exp(2*pi*img*dot_product(g, atoms%taual(:, ratom))) + END DO + END DO + iatom0 = iatom0 + atoms%neq(itype) END DO -END SUBROUTINE symm_hf + END SUBROUTINE symm_hf -INTEGER FUNCTION symm_hf_nkpt_EIBZ(kpts,nk,sym) + INTEGER FUNCTION symm_hf_nkpt_EIBZ(kpts, nk, sym) USE m_util, ONLY: modulo1 USE m_types IMPLICIT NONE - TYPE(t_sym),INTENT(IN) :: sym - TYPE(t_kpts),INTENT(IN) :: kpts + TYPE(t_sym), INTENT(IN) :: sym + TYPE(t_kpts), INTENT(IN) :: kpts ! - scalar input - INTEGER, INTENT(IN) :: nk ! - array input - ! - local scalars - - INTEGER :: isym,ic,iop,ikpt,ikpt1 - INTEGER :: nsymop,nrkpt + INTEGER :: isym, ic, iop, ikpt, ikpt1 + INTEGER :: nsymop, nrkpt ! - local arrays - - INTEGER :: rrot(3,3,sym%nsym) - INTEGER :: neqvkpt(kpts%nkptf),list(kpts%nkptf),parent(kpts%nkptf),& + INTEGER :: rrot(3, 3, sym%nsym) + INTEGER :: neqvkpt(kpts%nkptf), list(kpts%nkptf), parent(kpts%nkptf),& & symop(kpts%nkptf) INTEGER, ALLOCATABLE :: psym(:)!,help(:) REAL :: rotkpt(3) ! calculate rotations in reciprocal space - DO isym = 1,sym%nsym - IF( isym .le. sym%nop ) THEN - rrot(:,:,isym) = transpose(sym%mrot(:,:,sym%invtab(isym))) - ELSE - rrot(:,:,isym) = -rrot(:,:,isym-sym%nop) - END IF + DO isym = 1, sym%nsym + IF (isym <= sym%nop) THEN + rrot(:, :, isym) = transpose(sym%mrot(:, :, sym%invtab(isym))) + ELSE + rrot(:, :, isym) = -rrot(:, :, isym - sym%nop) + END IF END DO ! determine little group of k., i.e. those symmetry operations @@ -575,19 +567,19 @@ INTEGER FUNCTION symm_hf_nkpt_EIBZ(kpts,nk,sym) ! psym :: points to the symmetry-operation ic = 0 - ALLOCATE(psym(sym%nsym)) + ALLOCATE (psym(sym%nsym)) - DO iop=1,sym%nsym - rotkpt = matmul( rrot(:,:,iop), kpts%bkf(:,nk) ) + DO iop = 1, sym%nsym + rotkpt = matmul(rrot(:, :, iop), kpts%bkf(:, nk)) - !transfer rotkpt into BZ - rotkpt = modulo1(rotkpt,kpts%nkpt3) + !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 - ic = ic + 1 - psym(ic) = iop - END IF + !check if rotkpt is identical to bk(:,nk) + IF (maxval(abs(rotkpt - kpts%bkf(:, nk))) <= 1E-07) THEN + ic = ic + 1 + psym(ic) = iop + END IF END DO nsymop = ic @@ -606,50 +598,50 @@ INTEGER FUNCTION symm_hf_nkpt_EIBZ(kpts,nk,sym) neqvkpt = 0 ! list = (/ (ikpt-1, ikpt=1,nkpt) /) - DO ikpt=1,kpts%nkptf - list(ikpt) = ikpt-1 + DO ikpt = 1, kpts%nkptf + list(ikpt) = ikpt - 1 END DO - DO ikpt=2,kpts%nkptf - DO iop=1,nsymop + DO ikpt = 2, kpts%nkptf + DO iop = 1, nsymop - rotkpt = matmul( rrot(:,:,psym(iop)), kpts%bkf(:,ikpt) ) + rotkpt = matmul(rrot(:, :, psym(iop)), kpts%bkf(:, ikpt)) - !transfer rotkpt into BZ - rotkpt = modulo1(rotkpt,kpts%nkpt3) + !transfer rotkpt into BZ + rotkpt = modulo1(rotkpt, kpts%nkpt3) + + !determine number of rotkpt + nrkpt = 0 + DO ikpt1 = 1, kpts%nkptf + IF (maxval(abs(rotkpt - kpts%bkf(:, ikpt1))) <= 1E-06) THEN + nrkpt = ikpt1 + EXIT + END IF + END DO + IF (nrkpt == 0) STOP 'symm: Difference vector not found !' - !determine number of rotkpt - nrkpt = 0 - DO ikpt1=1,kpts%nkptf - IF ( maxval( abs( rotkpt - kpts%bkf(:,ikpt1) ) ) .le. 1E-06 ) THEN - nrkpt = ikpt1 - EXIT + IF (list(nrkpt) /= 0) THEN + list(nrkpt) = 0 + neqvkpt(ikpt) = neqvkpt(ikpt) + 1 + parent(nrkpt) = ikpt + symop(nrkpt) = psym(iop) END IF - END DO - IF( nrkpt .eq.0 ) STOP 'symm: Difference vector not found !' - - IF( list(nrkpt) .ne. 0) THEN - list(nrkpt) = 0 - neqvkpt(ikpt) = neqvkpt(ikpt) + 1 - parent(nrkpt) = ikpt - symop(nrkpt) = psym(iop) - END IF - IF ( all(list .eq. 0) ) EXIT - - END DO + IF (all(list == 0)) EXIT + + END DO END DO ! for the Gamma-point holds: - parent(1) = 1 + parent(1) = 1 neqvkpt(1) = 1 ! determine number of members in the EIBZ(k) ic = 0 - DO ikpt=1,kpts%nkptf - IF(parent(ikpt) .eq. ikpt) ic = ic + 1 + DO ikpt = 1, kpts%nkptf + IF (parent(ikpt) == ikpt) ic = ic + 1 END DO symm_hf_nkpt_EIBZ = ic -END FUNCTION symm_hf_nkpt_EIBZ + END FUNCTION symm_hf_nkpt_EIBZ END MODULE m_symm_hf diff --git a/hybrid/symmetrizeh.F90 b/hybrid/symmetrizeh.F90 index 4f36e2d33bb9979c36273abe0b37e3824e6246f3..571044cabc4b98a0cdef1442209af71de0909846 100644 --- a/hybrid/symmetrizeh.F90 +++ b/hybrid/symmetrizeh.F90 @@ -10,601 +10,600 @@ MODULE m_symmetrizeh CONTAINS -SUBROUTINE symmetrizeh(atoms,bk,DIMENSION,jsp,lapw,sym,kveclo,cell,nsymop,psym,hmat) - - USE m_constants - USE m_types - - IMPLICIT NONE - - TYPE(t_dimension), INTENT(IN) :: DIMENSION - TYPE(t_sym), INTENT(IN) :: sym - TYPE(t_cell), INTENT(IN) :: cell - TYPE(t_atoms), INTENT(IN) :: atoms - TYPE(t_lapw), INTENT(IN) :: lapw - TYPE(t_mat), INTENT(INOUT) :: hmat - - ! scalars - INTEGER, INTENT(IN) :: nsymop, jsp - - ! arrays - INTEGER, INTENT(IN) :: kveclo(atoms%nlotot) - INTEGER, INTENT(IN) :: psym(nsymop) - REAL, INTENT(IN) :: bk(3) - - ! local scalars - INTEGER :: ilotot,itype,itype1,ilo,ilo1 - INTEGER :: iatom,iatom1,iiatom,iiatom1 - INTEGER :: i,ieq,ieq1,m - INTEGER :: igpt_lo,igpt_lo1,igpt_lo2,igpt1_lo1 - INTEGER :: igpt1_lo2,isym,iop,ic,ic1,ic2 - INTEGER :: igpt,igpt1,igpt2,igpt3 - INTEGER :: invsfct,invsfct1,idum - INTEGER :: l ,l1,lm,j,ok,ratom,ratom1,nrgpt - COMPLEX,PARAMETER :: img=(0.0,1.0) - COMPLEX :: cdum,cdum2 - - ! local arrays - INTEGER :: l_lo(atoms%nlotot) - INTEGER :: itype_lo(atoms%nlotot) - INTEGER :: gpt_lo(3,atoms%nlotot),gpthlp(3),g(3) - INTEGER :: indx(DIMENSION%nbasfcn,DIMENSION%nbasfcn) - INTEGER :: lo_indx(atoms%nlod,atoms%nat) - INTEGER :: rot(3,3,nsymop),rrot(3,3,nsymop) - - INTEGER,ALLOCATABLE :: pointer_apw(:,:) - INTEGER,ALLOCATABLE :: ipiv(:) - INTEGER,ALLOCATABLE :: map(:,:) - - REAL :: rtaual(3),kghlp(3) - REAL :: rotkpthlp(3),rotkpt(3) - REAL :: trans(3,nsymop) - COMPLEX,ALLOCATABLE :: c_lo(:,:,:,:),c_rot(:,:,:,:,:),y(:) - COMPLEX,ALLOCATABLE :: cfac(:,:),chelp(:,:) - - LOGICAL :: ldum(lapw%nv(jsp)+atoms%nlotot,lapw%nv(jsp)+atoms%nlotot) - - TYPE(t_mat) :: hmatTemp - - CALL hmatTemp%init(hmat%l_real,hmat%matsize1,hmat%matsize2) - IF(hmat%l_real) THEN - hmatTemp%data_r = hmat%data_r - ELSE - hmatTemp%data_c = CONJG(hmat%data_c) - END IF - - ! calculate rotations in reciprocal space - DO isym = 1,nsymop - iop = psym(isym) - IF(iop.LE.sym%nop) THEN - rrot(:,:,isym) = TRANSPOSE(sym%mrot(:,:,sym%invtab(iop))) - ELSE - rrot(:,:,isym) = -TRANSPOSE(sym%mrot(:,:,sym%invtab(iop-sym%nop))) - END IF - END DO - - ! calculate rotations in real space (internal coordinates) - DO isym = 1,nsymop - iop = psym(isym) - IF(iop.LE.sym%nop) THEN - rot(:,:,isym) = sym%mrot(:,:,iop) - trans(:,isym) = sym%tau(:,iop) + SUBROUTINE symmetrizeh(atoms, bk, DIMENSION, jsp, lapw, sym, kveclo, cell, nsymop, psym, hmat) + + USE m_constants + USE m_types + + IMPLICIT NONE + + TYPE(t_dimension), INTENT(IN) :: DIMENSION + TYPE(t_sym), INTENT(IN) :: sym + TYPE(t_cell), INTENT(IN) :: cell + TYPE(t_atoms), INTENT(IN) :: atoms + TYPE(t_lapw), INTENT(IN) :: lapw + TYPE(t_mat), INTENT(INOUT) :: hmat + + ! scalars + INTEGER, INTENT(IN) :: nsymop, jsp + + ! arrays + INTEGER, INTENT(IN) :: kveclo(atoms%nlotot) + INTEGER, INTENT(IN) :: psym(nsymop) + REAL, INTENT(IN) :: bk(3) + + ! local scalars + INTEGER :: ilotot, itype, itype1, ilo, ilo1 + INTEGER :: iatom, iatom1, iiatom, iiatom1 + INTEGER :: i, ieq, ieq1, m + INTEGER :: igpt_lo, igpt_lo1, igpt_lo2, igpt1_lo1 + INTEGER :: igpt1_lo2, isym, iop, ic, ic1, ic2 + INTEGER :: igpt, igpt1, igpt2, igpt3 + INTEGER :: invsfct, invsfct1, idum + INTEGER :: l, l1, lm, j, ok, ratom, ratom1, nrgpt + COMPLEX, PARAMETER :: img = (0.0, 1.0) + COMPLEX :: cdum, cdum2 + + ! local arrays + INTEGER :: l_lo(atoms%nlotot) + INTEGER :: itype_lo(atoms%nlotot) + INTEGER :: gpt_lo(3, atoms%nlotot), gpthlp(3), g(3) + INTEGER :: indx(DIMENSION%nbasfcn, DIMENSION%nbasfcn) + INTEGER :: lo_indx(atoms%nlod, atoms%nat) + INTEGER :: rot(3, 3, nsymop), rrot(3, 3, nsymop) + + INTEGER, ALLOCATABLE :: pointer_apw(:, :) + INTEGER, ALLOCATABLE :: ipiv(:) + INTEGER, ALLOCATABLE :: map(:, :) + + REAL :: rtaual(3), kghlp(3) + REAL :: rotkpthlp(3), rotkpt(3) + REAL :: trans(3, nsymop) + COMPLEX, ALLOCATABLE :: c_lo(:, :, :, :), c_rot(:, :, :, :, :), y(:) + COMPLEX, ALLOCATABLE :: cfac(:, :), chelp(:, :) + + LOGICAL :: ldum(lapw%nv(jsp) + atoms%nlotot, lapw%nv(jsp) + atoms%nlotot) + + TYPE(t_mat) :: hmatTemp + + CALL hmatTemp%init(hmat%l_real, hmat%matsize1, hmat%matsize2) + IF (hmat%l_real) THEN + hmatTemp%data_r = hmat%data_r ELSE - rot(:,:,isym) = sym%mrot(:,:,iop-sym%nop) - trans(:,isym) = sym%tau(:,iop-sym%nop) + hmatTemp%data_c = CONJG(hmat%data_c) END IF - END DO - - ! caclulate mapping of atoms - ALLOCATE(map(nsymop,atoms%nat)) - map = 0 - iatom = 0 - iiatom = 0 - DO itype = 1,atoms%ntype - DO ieq = 1,atoms%neq(itype) - iatom = iatom + 1 - DO isym = 1,nsymop - rtaual = MATMUL(rot(:,:,isym),atoms%taual(:,iatom))+trans(:,isym) - iatom1 = 0 - DO ieq1 = 1,atoms%neq(itype) - IF(ALL(ABS(MODULO(rtaual-atoms%taual(:,iiatom + ieq1)+10.0**-12,1.0)).LT.10.0**-10)) THEN !The 10.0**-12 is a dirty fix. - iatom1 = iiatom + ieq1 - END IF - END DO - IF(iatom1.EQ.0) STOP 'symmetrizeh_new: error finding rotated atomic position' - map(isym,iatom) = iatom1 - END DO - END DO - iiatom = iiatom + atoms%neq(itype) - END DO - - ! initialze pointer_apw and the apw part of cfac - ALLOCATE(pointer_apw(lapw%nv(jsp),nsymop),cfac(lapw%nv(jsp)+atoms%nlotot,nsymop), stat= ok) - IF(ok.NE.0) STOP 'symmetrizeh_new: failure allocation pointer_apw,cfac' - - pointer_apw = 0 - cfac = 0 - - DO isym = 1, nsymop - - ! determine vector g, which map Rk back into BZ - ! Rk - G = k => G = Rk-k - rotkpt = MATMUL( rrot(:,:,isym), bk(:) ) - g = NINT(rotkpt-bk) - - DO igpt = 1, lapw%nv(jsp) - !rotate G vector corresponding to isym - gpthlp = MATMUL(rrot(:,:,isym),lapw%gvec(:,igpt,jsp)) + g - ! determine number of gpthlp - nrgpt = 0 - DO i = 1, lapw%nv(jsp) - IF(MAXVAL( ABS( gpthlp - lapw%gvec(:,i,jsp) ) ) .LE. 1E-06) THEN - nrgpt = i - EXIT - END IF - END DO - IF(nrgpt.EQ.0) THEN - PRINT *,igpt - PRINT *,lapw%gvec(:,igpt,jsp) - PRINT *,gpthlp - PRINT *,g - PRINT *,bk - DO i=1,lapw%nv(jsp) - WRITE(6,*) i,lapw%gvec(:,i,jsp) - ENDDO - STOP 'symmetrizeh_new: rotated G point not found' + + ! calculate rotations in reciprocal space + DO isym = 1, nsymop + iop = psym(isym) + IF (iop <= sym%nop) THEN + rrot(:, :, isym) = TRANSPOSE(sym%mrot(:, :, sym%invtab(iop))) + ELSE + rrot(:, :, isym) = -TRANSPOSE(sym%mrot(:, :, sym%invtab(iop - sym%nop))) END IF - pointer_apw(igpt,isym) = nrgpt - cfac(igpt,isym) = EXP(-2*pi_const*img* (dot_PRODUCT( bk(:)+gpthlp(:),trans(:,isym) ) ) ) END DO - END DO - - ! average apw-part of symmetry-equivalent matrix elements - - ldum = .TRUE. - DO i = 1, lapw%nv(jsp) - DO j = 1, i - cdum = 0 - ic = 0 - DO isym = 1, nsymop - iop = psym(isym) - igpt = pointer_apw(i,isym) - igpt1 = pointer_apw(j,isym) - - IF(iop.LE.sym%nop) THEN - IF((igpt.NE.0).AND.(igpt1.NE.0)) THEN - ic = ic + 1 - IF (hmatTemp%l_real) THEN - cdum = cdum + CONJG(cfac(i,isym))*hmatTemp%data_r(igpt1,igpt)*cfac(j,isym) - ELSE - cdum = cdum + CONJG(cfac(i,isym))*hmatTemp%data_c(igpt1,igpt)*cfac(j,isym) - END IF - END IF - ELSE - IF((igpt.NE.0).AND.(igpt1.NE.0)) THEN - ic = ic + 1 - IF (hmatTemp%l_real) THEN - cdum = cdum + CONJG(CONJG(cfac(i,isym))*hmatTemp%data_r(igpt1,igpt)*cfac(j,isym)) - ELSE - cdum = cdum + CONJG(CONJG(cfac(i,isym))*hmatTemp%data_c(igpt1,igpt)*cfac(j,isym)) - END IF - END IF - END IF - END DO - cdum = cdum!/ic - DO isym = 1, nsymop - iop = psym(isym) - igpt = pointer_apw(i,isym) - igpt1 = pointer_apw(j,isym) - IF ((igpt.EQ.0).OR.(igpt1.EQ.0)) CYCLE - IF (igpt1.GT.igpt) CYCLE - IF (ldum(igpt,igpt1)) THEN - IF (hmat%l_real) THEN - IF (iop.LE.sym%nop) THEN - hmat%data_r(igpt1,igpt) = cdum/(CONJG(cfac(i,isym))*cfac(j,isym)) - ldum(igpt,igpt1) = .FALSE. - ELSE - hmat%data_r(igpt1,igpt) = CONJG(cdum/(CONJG(cfac(i,isym))*cfac(j,isym))) - ldum(igpt,igpt1) = .FALSE. - END IF - hmat%data_r(igpt,igpt1) = hmat%data_r(igpt1,igpt) - ELSE - IF (iop.LE.sym%nop) THEN - hmat%data_c(igpt1,igpt) = cdum/(CONJG(cfac(i,isym))*cfac(j,isym)) - ldum(igpt,igpt1) = .FALSE. - ELSE - hmat%data_c(igpt1,igpt) = CONJG(cdum/(CONJG(cfac(i,isym))*cfac(j,isym))) - ldum(igpt,igpt1) = .FALSE. - END IF - hmat%data_c(igpt,igpt1) = CONJG(hmat%data_c(igpt1,igpt)) - END IF - END IF - END DO + ! calculate rotations in real space (internal coordinates) + DO isym = 1, nsymop + iop = psym(isym) + IF (iop <= sym%nop) THEN + rot(:, :, isym) = sym%mrot(:, :, iop) + trans(:, isym) = sym%tau(:, iop) + ELSE + rot(:, :, isym) = sym%mrot(:, :, iop - sym%nop) + trans(:, isym) = sym%tau(:, iop - sym%nop) + END IF END DO - END DO - - - ! average lo-part of matrix elements - IF (ANY(atoms%nlo.NE.0)) THEN - ! preparations - ilotot = 0 - iatom = 0 + ! caclulate mapping of atoms + ALLOCATE (map(nsymop, atoms%nat)) + map = 0 + iatom = 0 + iiatom = 0 DO itype = 1, atoms%ntype - DO ieq = 1,atoms%neq(itype) + DO ieq = 1, atoms%neq(itype) iatom = iatom + 1 - IF ((atoms%invsat(iatom).EQ.0).OR.(atoms%invsat(iatom).EQ.1)) THEN - IF (atoms%invsat(iatom).EQ.0) invsfct = 1 - IF (atoms%invsat(iatom).EQ.1) invsfct = 2 - DO ilo = 1, atoms%nlo(itype) - l = atoms%llo(ilo,itype) - DO m = 1, invsfct*(2*l+1) - ilotot = ilotot + 1 - l_lo(ilotot) = l - itype_lo(ilotot) = itype - gpt_lo(:,ilotot) = lapw%gvec(:,kveclo(ilotot),jsp) - END DO + DO isym = 1, nsymop + rtaual = MATMUL(rot(:, :, isym), atoms%taual(:, iatom)) + trans(:, isym) + iatom1 = 0 + DO ieq1 = 1, atoms%neq(itype) + IF (ALL(ABS(MODULO(rtaual - atoms%taual(:, iiatom + ieq1) + 10.0**-12, 1.0)) < 10.0**-10)) THEN !The 10.0**-12 is a dirty fix. + iatom1 = iiatom + ieq1 + END IF END DO - END IF + IF (iatom1 == 0) STOP 'symmetrizeh_new: error finding rotated atomic position' + map(isym, iatom) = iatom1 + END DO END DO + iiatom = iiatom + atoms%neq(itype) END DO - ! calculate expansion coefficients for local orbitals - IF (hmat%l_real) THEN - ALLOCATE(c_lo(4*MAXVAL(l_lo)+2,4*MAXVAL(l_lo)+2,atoms%nlod,atoms%nat), stat = ok) - ELSE - ALLOCATE(c_lo(2*MAXVAL(l_lo)+1,2*MAXVAL(l_lo)+1,atoms%nlod,atoms%nat), stat = ok) - END IF + ! initialze pointer_apw and the apw part of cfac + ALLOCATE (pointer_apw(lapw%nv(jsp), nsymop), cfac(lapw%nv(jsp) + atoms%nlotot, nsymop), stat=ok) + IF (ok /= 0) STOP 'symmetrizeh_new: failure allocation pointer_apw,cfac' - IF (ok.NE.0) STOP 'symmetrizeh_new: failure allocation c_lo' + pointer_apw = 0 + cfac = 0 - iatom = 0 - ilotot = 0 - lo_indx = 0 - DO itype = 1, atoms%ntype - DO ieq = 1, atoms%neq(itype) - iatom = iatom + 1 - IF ((atoms%invsat(iatom).EQ.0).OR.(atoms%invsat(iatom).EQ.1)) THEN - IF(atoms%invsat(iatom).EQ.0) invsfct = 1 - IF(atoms%invsat(iatom).EQ.1) invsfct = 2 - - DO ilo = 1, atoms%nlo(itype) - l = atoms%llo(ilo,itype) - ALLOCATE(y((l+1)**2)) - lo_indx(ilo,iatom) = ilotot + 1 + DO isym = 1, nsymop - DO igpt_lo = 1, invsfct*(2*l+1) - ilotot = ilotot + 1 - kghlp = bk(:) + gpt_lo(:,ilotot) - - !generate spherical harmonics - CALL harmonicsr(y,MATMUL(kghlp,cell%bmat),l) + ! determine vector g, which map Rk back into BZ + ! Rk - G = k => G = Rk-k + rotkpt = MATMUL(rrot(:, :, isym), bk(:)) + g = NINT(rotkpt - bk) + + DO igpt = 1, lapw%nv(jsp) + !rotate G vector corresponding to isym + gpthlp = MATMUL(rrot(:, :, isym), lapw%gvec(:, igpt, jsp)) + g + ! determine number of gpthlp + nrgpt = 0 + DO i = 1, lapw%nv(jsp) + IF (MAXVAL(ABS(gpthlp - lapw%gvec(:, i, jsp))) <= 1E-06) THEN + nrgpt = i + EXIT + END IF + END DO + IF (nrgpt == 0) THEN + PRINT *, igpt + PRINT *, lapw%gvec(:, igpt, jsp) + PRINT *, gpthlp + PRINT *, g + PRINT *, bk + DO i = 1, lapw%nv(jsp) + WRITE (6, *) i, lapw%gvec(:, i, jsp) + ENDDO + STOP 'symmetrizeh_new: rotated G point not found' + END IF + pointer_apw(igpt, isym) = nrgpt + cfac(igpt, isym) = EXP(-2*pi_const*img*(dot_PRODUCT(bk(:) + gpthlp(:), trans(:, isym)))) + END DO + END DO - lm = l**2 - cdum = EXP(2*pi_const*img*dot_PRODUCT(kghlp,atoms%taual(:,iatom))) + ! average apw-part of symmetry-equivalent matrix elements + + ldum = .TRUE. + DO i = 1, lapw%nv(jsp) + DO j = 1, i + cdum = 0 + ic = 0 + DO isym = 1, nsymop + iop = psym(isym) + igpt = pointer_apw(i, isym) + igpt1 = pointer_apw(j, isym) + + IF (iop <= sym%nop) THEN + IF ((igpt /= 0) .AND. (igpt1 /= 0)) THEN + ic = ic + 1 + IF (hmatTemp%l_real) THEN + cdum = cdum + CONJG(cfac(i, isym))*hmatTemp%data_r(igpt1, igpt)*cfac(j, isym) + ELSE + cdum = cdum + CONJG(cfac(i, isym))*hmatTemp%data_c(igpt1, igpt)*cfac(j, isym) + END IF + END IF + ELSE + IF ((igpt /= 0) .AND. (igpt1 /= 0)) THEN + ic = ic + 1 + IF (hmatTemp%l_real) THEN + cdum = cdum + CONJG(CONJG(cfac(i, isym))*hmatTemp%data_r(igpt1, igpt)*cfac(j, isym)) + ELSE + cdum = cdum + CONJG(CONJG(cfac(i, isym))*hmatTemp%data_c(igpt1, igpt)*cfac(j, isym)) + END IF + END IF + END IF + END DO - IF (invsfct.EQ.1) THEN - DO m = 1,2*l+1 - lm = lm + 1 - c_lo(m,igpt_lo,ilo,iatom) = cdum*CONJG(y(lm)) - END DO + cdum = cdum!/ic + DO isym = 1, nsymop + iop = psym(isym) + igpt = pointer_apw(i, isym) + igpt1 = pointer_apw(j, isym) + IF ((igpt == 0) .OR. (igpt1 == 0)) CYCLE + IF (igpt1 > igpt) CYCLE + IF (ldum(igpt, igpt1)) THEN + IF (hmat%l_real) THEN + IF (iop <= sym%nop) THEN + hmat%data_r(igpt1, igpt) = cdum/(CONJG(cfac(i, isym))*cfac(j, isym)) + ldum(igpt, igpt1) = .FALSE. ELSE - DO m = 1, 2*l+1 - lm = lm + 1 - c_lo(m,igpt_lo,ilo,iatom) = cdum *CONJG(y(lm)) - c_lo(4*l+3-m,igpt_lo,ilo,iatom) = (-1)**(m-1)*CONJG(cdum)*y(lm) - END DO + hmat%data_r(igpt1, igpt) = CONJG(cdum/(CONJG(cfac(i, isym))*cfac(j, isym))) + ldum(igpt, igpt1) = .FALSE. END IF - END DO - DEALLOCATE( y ) - END DO - END IF + hmat%data_r(igpt, igpt1) = hmat%data_r(igpt1, igpt) + ELSE + IF (iop <= sym%nop) THEN + hmat%data_c(igpt1, igpt) = cdum/(CONJG(cfac(i, isym))*cfac(j, isym)) + ldum(igpt, igpt1) = .FALSE. + ELSE + hmat%data_c(igpt1, igpt) = CONJG(cdum/(CONJG(cfac(i, isym))*cfac(j, isym))) + ldum(igpt, igpt1) = .FALSE. + END IF + hmat%data_c(igpt, igpt1) = CONJG(hmat%data_c(igpt1, igpt)) + END IF + END IF + END DO END DO END DO - IF (ilotot.NE.atoms%nlotot) STOP 'symmetrizeh_new: failure counting local orbitals(ilotot)' - - IF (hmat%l_real) THEN - ALLOCATE(c_rot(4*MAXVAL(l_lo)+2,4*MAXVAL(l_lo)+2,atoms%nlod,atoms%nat, nsymop)) - ALLOCATE(chelp(4*MAXVAL(l_lo)+2,4*MAXVAL(l_lo)+2)) - ELSE - ALLOCATE(c_rot(2*MAXVAL(l_lo)+1,2*MAXVAL(l_lo)+1,atoms%nlod,atoms%nat, nsymop)) - ALLOCATE(chelp(2*MAXVAL(l_lo)+1,2*MAXVAL(l_lo)+1)) - END IF - - DO isym = 1,nsymop - ! determine vector g, which map Rk back into BZ - ! Rk - G = k => G = Rk-k - rotkpt = MATMUL( rrot(:,:,isym), bk(:) ) - g = NINT(rotkpt-bk) + ! average lo-part of matrix elements + IF (ANY(atoms%nlo /= 0)) THEN + ! preparations ilotot = 0 iatom = 0 - DO itype = 1,atoms%ntype - DO ieq = 1,atoms%neq(itype) + DO itype = 1, atoms%ntype + DO ieq = 1, atoms%neq(itype) iatom = iatom + 1 - ratom = map(isym,iatom) + IF ((atoms%invsat(iatom) == 0) .OR. (atoms%invsat(iatom) == 1)) THEN + IF (atoms%invsat(iatom) == 0) invsfct = 1 + IF (atoms%invsat(iatom) == 1) invsfct = 2 + DO ilo = 1, atoms%nlo(itype) + l = atoms%llo(ilo, itype) + DO m = 1, invsfct*(2*l + 1) + ilotot = ilotot + 1 + l_lo(ilotot) = l + itype_lo(ilotot) = itype + gpt_lo(:, ilotot) = lapw%gvec(:, kveclo(ilotot), jsp) + END DO + END DO + END IF + END DO + END DO - IF ((atoms%invsat(iatom).EQ.0).OR.(atoms%invsat(iatom).EQ.1)) THEN - IF (atoms%invsat(iatom).EQ.0) invsfct = 1 - IF (atoms%invsat(iatom).EQ.1) THEN - IF (atoms%invsat(ratom).EQ.2) THEN - ratom = sym%invsatnr(ratom) - END IF - invsfct = 2 - END IF + ! calculate expansion coefficients for local orbitals + IF (hmat%l_real) THEN + ALLOCATE (c_lo(4*MAXVAL(l_lo) + 2, 4*MAXVAL(l_lo) + 2, atoms%nlod, atoms%nat), stat=ok) + ELSE + ALLOCATE (c_lo(2*MAXVAL(l_lo) + 1, 2*MAXVAL(l_lo) + 1, atoms%nlod, atoms%nat), stat=ok) + END IF - DO ilo = 1,atoms%nlo(itype) - l = atoms%llo(ilo,itype) - ALLOCATE(y((l+1)**2)) + IF (ok /= 0) STOP 'symmetrizeh_new: failure allocation c_lo' - DO igpt_lo = 1,invsfct*(2*l+1) - ilotot = ilotot + 1 + iatom = 0 + ilotot = 0 + lo_indx = 0 + DO itype = 1, atoms%ntype + DO ieq = 1, atoms%neq(itype) + iatom = iatom + 1 + IF ((atoms%invsat(iatom) == 0) .OR. (atoms%invsat(iatom) == 1)) THEN + IF (atoms%invsat(iatom) == 0) invsfct = 1 + IF (atoms%invsat(iatom) == 1) invsfct = 2 + + DO ilo = 1, atoms%nlo(itype) + l = atoms%llo(ilo, itype) + ALLOCATE (y((l + 1)**2)) + lo_indx(ilo, iatom) = ilotot + 1 - !rotate G_lo corresponding to iop - gpthlp = MATMUL(rrot(:,:,isym),gpt_lo(:,ilotot)) + g - kghlp = bk(:) + MATMUL(rrot(:,:,isym),gpt_lo(:,ilotot)) + g + DO igpt_lo = 1, invsfct*(2*l + 1) + ilotot = ilotot + 1 + kghlp = bk(:) + gpt_lo(:, ilotot) !generate spherical harmonics - CALL harmonicsr(y,MATMUL(kghlp,cell%bmat),l) + CALL harmonicsr(y, MATMUL(kghlp, cell%bmat), l) lm = l**2 - cdum = EXP(2*pi_const*img* dot_PRODUCT(kghlp,atoms%taual(:,ratom))) - IF (invsfct.EQ.1) THEN - DO m = 1,2*l+1 + cdum = EXP(2*pi_const*img*dot_PRODUCT(kghlp, atoms%taual(:, iatom))) + + IF (invsfct == 1) THEN + DO m = 1, 2*l + 1 lm = lm + 1 - c_rot(m,igpt_lo,ilo,ratom,isym) = cdum*CONJG(y(lm)) + c_lo(m, igpt_lo, ilo, iatom) = cdum*CONJG(y(lm)) END DO ELSE - DO m = 1,2*l+1 + DO m = 1, 2*l + 1 lm = lm + 1 - c_rot(m,igpt_lo,ilo,ratom,isym) = cdum *CONJG(y(lm)) - c_rot(4*l+3-m,igpt_lo,ilo,ratom,isym) = (-1)**(m-1)*(CONJG(cdum))* y(lm) + c_lo(m, igpt_lo, ilo, iatom) = cdum*CONJG(y(lm)) + c_lo(4*l + 3 - m, igpt_lo, ilo, iatom) = (-1)**(m - 1)*CONJG(cdum)*y(lm) END DO END IF - cfac(lapw%nv(jsp)+ilotot,isym) = EXP(-2*pi_const*img* (dot_PRODUCT( kghlp,trans(:,isym) ) ) ) END DO + DEALLOCATE (y) + END DO + END IF + END DO + END DO - idum = invsfct*(2*l+1) + IF (ilotot /= atoms%nlotot) STOP 'symmetrizeh_new: failure counting local orbitals(ilotot)' - ALLOCATE(ipiv(idum)) + IF (hmat%l_real) THEN + ALLOCATE (c_rot(4*MAXVAL(l_lo) + 2, 4*MAXVAL(l_lo) + 2, atoms%nlod, atoms%nat, nsymop)) + ALLOCATE (chelp(4*MAXVAL(l_lo) + 2, 4*MAXVAL(l_lo) + 2)) + ELSE + ALLOCATE (c_rot(2*MAXVAL(l_lo) + 1, 2*MAXVAL(l_lo) + 1, atoms%nlod, atoms%nat, nsymop)) + ALLOCATE (chelp(2*MAXVAL(l_lo) + 1, 2*MAXVAL(l_lo) + 1)) + END IF - chelp(:idum,:idum) = c_lo(:idum,:idum,ilo,ratom) + DO isym = 1, nsymop + ! determine vector g, which map Rk back into BZ + ! Rk - G = k => G = Rk-k + rotkpt = MATMUL(rrot(:, :, isym), bk(:)) + g = NINT(rotkpt - bk) + + ilotot = 0 + iatom = 0 + DO itype = 1, atoms%ntype + DO ieq = 1, atoms%neq(itype) + iatom = iatom + 1 + ratom = map(isym, iatom) + + IF ((atoms%invsat(iatom) == 0) .OR. (atoms%invsat(iatom) == 1)) THEN + IF (atoms%invsat(iatom) == 0) invsfct = 1 + IF (atoms%invsat(iatom) == 1) THEN + IF (atoms%invsat(ratom) == 2) THEN + ratom = sym%invsatnr(ratom) + END IF + invsfct = 2 + END IF - CALL ZGESV(idum,idum,chelp(:idum,:idum),idum,ipiv, c_rot(:idum,:idum,ilo,ratom,isym),idum,ok ) + DO ilo = 1, atoms%nlo(itype) + l = atoms%llo(ilo, itype) + ALLOCATE (y((l + 1)**2)) - IF(ok.NE.0) STOP 'symmetrizeh_new: failure zgesv' - DEALLOCATE(ipiv,y) - END DO - END IF + DO igpt_lo = 1, invsfct*(2*l + 1) + ilotot = ilotot + 1 + + !rotate G_lo corresponding to iop + gpthlp = MATMUL(rrot(:, :, isym), gpt_lo(:, ilotot)) + g + kghlp = bk(:) + MATMUL(rrot(:, :, isym), gpt_lo(:, ilotot)) + g + + !generate spherical harmonics + CALL harmonicsr(y, MATMUL(kghlp, cell%bmat), l) + + lm = l**2 + cdum = EXP(2*pi_const*img*dot_PRODUCT(kghlp, atoms%taual(:, ratom))) + IF (invsfct == 1) THEN + DO m = 1, 2*l + 1 + lm = lm + 1 + c_rot(m, igpt_lo, ilo, ratom, isym) = cdum*CONJG(y(lm)) + END DO + ELSE + DO m = 1, 2*l + 1 + lm = lm + 1 + c_rot(m, igpt_lo, ilo, ratom, isym) = cdum*CONJG(y(lm)) + c_rot(4*l + 3 - m, igpt_lo, ilo, ratom, isym) = (-1)**(m - 1)*(CONJG(cdum))*y(lm) + END DO + END IF + cfac(lapw%nv(jsp) + ilotot, isym) = EXP(-2*pi_const*img*(dot_PRODUCT(kghlp, trans(:, isym)))) + END DO + + idum = invsfct*(2*l + 1) + + ALLOCATE (ipiv(idum)) + + chelp(:idum, :idum) = c_lo(:idum, :idum, ilo, ratom) + + CALL ZGESV(idum, idum, chelp(:idum, :idum), idum, ipiv, c_rot(:idum, :idum, ilo, ratom, isym), idum, ok) + + IF (ok /= 0) STOP 'symmetrizeh_new: failure zgesv' + DEALLOCATE (ipiv, y) + END DO + END IF + END DO END DO END DO - END DO - ! symmetrize local-orbital-apw-part of the matrix - i = 0 - iatom = 0 - DO itype = 1, atoms%ntype - DO ieq = 1, atoms%neq(itype) - iatom = iatom + 1 - IF ((atoms%invsat(iatom).EQ.0).OR.(atoms%invsat(iatom).EQ.1)) THEN - IF (atoms%invsat(iatom).EQ.0) invsfct = 1 - IF (atoms%invsat(iatom).EQ.1) invsfct = 2 - - DO ilo = 1, atoms%nlo(itype) - l = atoms%llo(ilo,itype) - DO igpt = 1, invsfct*(2*l+1) - i = i + 1 - DO j = 1, lapw%nv(jsp) - cdum = 0 - ic = 0 - DO isym = 1,nsymop - ic = ic + 1 - iop = psym(isym) - ratom = map(isym,iatom) - IF (invsfct.EQ.2) THEN - IF (atoms%invsat(ratom).EQ.2) THEN - ratom = sym%invsatnr(ratom) + ! symmetrize local-orbital-apw-part of the matrix + i = 0 + iatom = 0 + DO itype = 1, atoms%ntype + DO ieq = 1, atoms%neq(itype) + iatom = iatom + 1 + IF ((atoms%invsat(iatom) == 0) .OR. (atoms%invsat(iatom) == 1)) THEN + IF (atoms%invsat(iatom) == 0) invsfct = 1 + IF (atoms%invsat(iatom) == 1) invsfct = 2 + + DO ilo = 1, atoms%nlo(itype) + l = atoms%llo(ilo, itype) + DO igpt = 1, invsfct*(2*l + 1) + i = i + 1 + DO j = 1, lapw%nv(jsp) + cdum = 0 + ic = 0 + DO isym = 1, nsymop + ic = ic + 1 + iop = psym(isym) + ratom = map(isym, iatom) + IF (invsfct == 2) THEN + IF (atoms%invsat(ratom) == 2) THEN + ratom = sym%invsatnr(ratom) + END IF END IF - END IF - igpt_lo1 = lo_indx(ilo,ratom) - igpt_lo2 = igpt_lo1 + invsfct*2*l - IF (invsfct.EQ.2) igpt_lo2 = igpt_lo2 + 1 - igpt1 = pointer_apw(j,isym) - - cdum2 = 0 - ic1 = 0 - DO igpt2 = igpt_lo1, igpt_lo2 - ic1 = ic1 + 1 - IF (hmatTemp%l_real) THEN - cdum2 = cdum2 + CONJG(c_rot(ic1,igpt,ilo,ratom,isym)) * hmatTemp%data_r(igpt1,lapw%nv(jsp)+igpt2) + igpt_lo1 = lo_indx(ilo, ratom) + igpt_lo2 = igpt_lo1 + invsfct*2*l + IF (invsfct == 2) igpt_lo2 = igpt_lo2 + 1 + igpt1 = pointer_apw(j, isym) + + cdum2 = 0 + ic1 = 0 + DO igpt2 = igpt_lo1, igpt_lo2 + ic1 = ic1 + 1 + IF (hmatTemp%l_real) THEN + cdum2 = cdum2 + CONJG(c_rot(ic1, igpt, ilo, ratom, isym))*hmatTemp%data_r(igpt1, lapw%nv(jsp) + igpt2) + ELSE + cdum2 = cdum2 + CONJG(c_rot(ic1, igpt, ilo, ratom, isym))*hmatTemp%data_c(igpt1, lapw%nv(jsp) + igpt2) + END IF + END DO + + IF (iop <= sym%nop) THEN + cdum = cdum + cdum2*CONJG(cfac(lapw%nv(jsp) + i, isym))*cfac(j, isym) ELSE - cdum2 = cdum2 + CONJG(c_rot(ic1,igpt,ilo,ratom,isym)) * hmatTemp%data_c(igpt1,lapw%nv(jsp)+igpt2) + cdum = cdum + CONJG(cdum2*CONJG(cfac(lapw%nv(jsp) + i, isym))*cfac(j, isym)) END IF END DO - - IF (iop.LE.sym%nop) THEN - cdum = cdum + cdum2*CONJG(cfac(lapw%nv(jsp)+i,isym)) * cfac(j,isym) + IF (hmat%l_real) THEN + hmat%data_r(j, lapw%nv(jsp) + i) = cdum!/ic ELSE - cdum = cdum + CONJG(cdum2*CONJG(cfac(lapw%nv(jsp)+i,isym)) * cfac(j,isym)) + hmat%data_c(j, lapw%nv(jsp) + i) = cdum!/ic END IF END DO - IF (hmat%l_real) THEN - hmat%data_r(j,lapw%nv(jsp)+i) = cdum!/ic - ELSE - hmat%data_c(j,lapw%nv(jsp)+i) = cdum!/ic - END IF END DO END DO - END DO - END IF + END IF + END DO END DO - END DO - !lo's - lo's - i = 0 - iatom = 0 - DO itype = 1, atoms%ntype - DO ieq = 1, atoms%neq(itype) - iatom = iatom + 1 - IF ((atoms%invsat(iatom).EQ.0).OR.(atoms%invsat(iatom).EQ.1)) THEN - IF(atoms%invsat(iatom).EQ.0) invsfct = 1 - IF(atoms%invsat(iatom).EQ.1) invsfct = 2 - - DO ilo = 1, atoms%nlo(itype) - l = atoms%llo(ilo,itype) - DO igpt = 1, invsfct*(2*l+1) - i = i + 1 - j = 0 - iatom1 = 0 - DO itype1 = 1, atoms%ntype - DO ieq1 = 1, atoms%neq(itype1) - iatom1 = iatom1 + 1 - IF ((atoms%invsat(iatom1).EQ.0).OR.(atoms%invsat(iatom1).EQ.1)) THEN - IF(atoms%invsat(iatom1).EQ.0) invsfct1 = 1 - IF(atoms%invsat(iatom1).EQ.1) invsfct1 = 2 - - DO ilo1 = 1, atoms%nlo(itype1) - l1 = atoms%llo(ilo1,itype1) - DO igpt1 = 1, invsfct1*(2*l1+1) - j = j + 1 - IF (j.GT.i) CYCLE - cdum = 0 - ic = 0 - DO isym = 1, nsymop - iop = psym(isym) - ratom = map(isym,iatom ) - ratom1 = map(isym,iatom1) - - IF (invsfct.EQ.2) THEN - IF (atoms%invsat(ratom).EQ.2) THEN - ratom = sym%invsatnr(ratom) + !lo's - lo's + i = 0 + iatom = 0 + DO itype = 1, atoms%ntype + DO ieq = 1, atoms%neq(itype) + iatom = iatom + 1 + IF ((atoms%invsat(iatom) == 0) .OR. (atoms%invsat(iatom) == 1)) THEN + IF (atoms%invsat(iatom) == 0) invsfct = 1 + IF (atoms%invsat(iatom) == 1) invsfct = 2 + + DO ilo = 1, atoms%nlo(itype) + l = atoms%llo(ilo, itype) + DO igpt = 1, invsfct*(2*l + 1) + i = i + 1 + j = 0 + iatom1 = 0 + DO itype1 = 1, atoms%ntype + DO ieq1 = 1, atoms%neq(itype1) + iatom1 = iatom1 + 1 + IF ((atoms%invsat(iatom1) == 0) .OR. (atoms%invsat(iatom1) == 1)) THEN + IF (atoms%invsat(iatom1) == 0) invsfct1 = 1 + IF (atoms%invsat(iatom1) == 1) invsfct1 = 2 + + DO ilo1 = 1, atoms%nlo(itype1) + l1 = atoms%llo(ilo1, itype1) + DO igpt1 = 1, invsfct1*(2*l1 + 1) + j = j + 1 + IF (j > i) CYCLE + cdum = 0 + ic = 0 + DO isym = 1, nsymop + iop = psym(isym) + ratom = map(isym, iatom) + ratom1 = map(isym, iatom1) + + IF (invsfct == 2) THEN + IF (atoms%invsat(ratom) == 2) THEN + ratom = sym%invsatnr(ratom) + END IF END IF - END IF - IF (invsfct1.EQ.2) THEN - IF (atoms%invsat(ratom1).EQ.2) THEN - ratom1 = sym%invsatnr(ratom1) + IF (invsfct1 == 2) THEN + IF (atoms%invsat(ratom1) == 2) THEN + ratom1 = sym%invsatnr(ratom1) + END IF END IF - END IF - igpt_lo1 = lo_indx(ilo,ratom ) - igpt_lo2 = igpt_lo1 + invsfct*2*l - IF (invsfct.EQ.2) igpt_lo2 = igpt_lo2 + 1 - - igpt1_lo1 = lo_indx(ilo1,ratom1) - igpt1_lo2 = igpt1_lo1 + invsfct1*2*l1 - IF (invsfct1.EQ.2) igpt1_lo2 = igpt1_lo2 + 1 - - cdum2 = 0 - ic1 = 0 - DO igpt2 = igpt_lo1, igpt_lo2 - ic1 = ic1 + 1 - ic2 = 0 - DO igpt3 = igpt1_lo1, igpt1_lo2 - ic2 = ic2 + 1 - IF (hmatTemp%l_real) THEN - cdum2 = cdum2 + CONJG(c_rot(ic1,igpt,ilo,ratom,isym)) *& - hmatTemp%data_r(lapw%nv(jsp)+igpt3,lapw%nv(jsp)+igpt2) *& - c_rot(ic2,igpt1,ilo1,ratom1,isym) - ELSE - cdum2 = cdum2 + CONJG(c_rot(ic1,igpt,ilo,ratom,isym)) *& - hmatTemp%data_c(lapw%nv(jsp)+igpt3,lapw%nv(jsp)+igpt2) *& - c_rot(ic2,igpt1,ilo1,ratom1,isym) - END IF + igpt_lo1 = lo_indx(ilo, ratom) + igpt_lo2 = igpt_lo1 + invsfct*2*l + IF (invsfct == 2) igpt_lo2 = igpt_lo2 + 1 + + igpt1_lo1 = lo_indx(ilo1, ratom1) + igpt1_lo2 = igpt1_lo1 + invsfct1*2*l1 + IF (invsfct1 == 2) igpt1_lo2 = igpt1_lo2 + 1 + + cdum2 = 0 + ic1 = 0 + DO igpt2 = igpt_lo1, igpt_lo2 + ic1 = ic1 + 1 + ic2 = 0 + DO igpt3 = igpt1_lo1, igpt1_lo2 + ic2 = ic2 + 1 + IF (hmatTemp%l_real) THEN + cdum2 = cdum2 + CONJG(c_rot(ic1, igpt, ilo, ratom, isym))* & + hmatTemp%data_r(lapw%nv(jsp) + igpt3, lapw%nv(jsp) + igpt2)* & + c_rot(ic2, igpt1, ilo1, ratom1, isym) + ELSE + cdum2 = cdum2 + CONJG(c_rot(ic1, igpt, ilo, ratom, isym))* & + hmatTemp%data_c(lapw%nv(jsp) + igpt3, lapw%nv(jsp) + igpt2)* & + c_rot(ic2, igpt1, ilo1, ratom1, isym) + END IF + END DO END DO + ic = ic + 1 + IF (iop <= sym%nop) THEN + cdum = cdum + cdum2*CONJG(cfac(lapw%nv(jsp) + i, isym))*cfac(lapw%nv(jsp) + j, isym) + ELSE + cdum = cdum + CONJG(cdum2*CONJG(cfac(lapw%nv(jsp) + i, isym))*cfac(lapw%nv(jsp) + j, isym)) + END IF END DO - ic = ic + 1 - IF (iop.LE.sym%nop) THEN - cdum = cdum + cdum2*CONJG(cfac(lapw%nv(jsp)+i,isym))*cfac(lapw%nv(jsp)+j,isym) - ELSE - cdum = cdum + CONJG(cdum2*CONJG(cfac(lapw%nv(jsp)+i,isym))*cfac(lapw%nv(jsp)+j,isym)) + IF (hmat%l_real) THEN + hmat%data_r(lapw%nv(jsp) + j, lapw%nv(jsp) + i) = cdum!/ic + ELSE + hmat%data_c(lapw%nv(jsp) + j, lapw%nv(jsp) + i) = cdum!/ic END IF - END DO - IF (hmat%l_real) THEN - hmat%data_r(lapw%nv(jsp)+j,lapw%nv(jsp)+i) = cdum!/ic - ELSE - hmat%data_c(lapw%nv(jsp)+j,lapw%nv(jsp)+i) = cdum!/ic - END IF - END DO ! igpt_lo1 - END DO ! ilo1 - END IF - END DO !ieq1 - END DO !itype1 - END DO ! igpt_lo - END DO ! ilo - END IF - END DO !ieq - END DO !itype + END DO ! igpt_lo1 + END DO ! ilo1 + END IF + END DO !ieq1 + END DO !itype1 + END DO ! igpt_lo + END DO ! ilo + END IF + END DO !ieq + END DO !itype - END IF ! ANY(atoms%nlo.NE.0) + END IF ! ANY(atoms%nlo.NE.0) CONTAINS - ! Returns the spherical harmonics Y_lm(^rvec) for l = 0,...,ll in Y(1,...,(ll+1)**2). - SUBROUTINE harmonicsr(Y,rvec,ll) - use m_judft - IMPLICIT NONE - INTEGER,INTENT(IN) :: ll - REAL,INTENT(IN) :: rvec(3) - COMPLEX,INTENT(OUT) :: Y((ll+1)**2) - REAL :: stheta,ctheta,sphi,cphi,r,rvec1(3) - INTEGER :: l ,lm - COMPLEX :: c - COMPLEX,PARAMETER :: img=(0.0,1.0) - - call timestart("symm harmonics") - Y(1) = 0.282094791773878 - IF(ll.EQ.0) RETURN - - stheta = 0 - ctheta = 0 - sphi = 0 - cphi = 0 - r = SQRT(SUM(rvec**2)) - IF (r.GT.10.0**-16) THEN - rvec1 = rvec / r - ctheta = rvec1(3) - stheta = SQRT(rvec1(1)**2+rvec1(2)**2) - IF (stheta.GT.10.0**-16) THEN - cphi = rvec1(1) / stheta - sphi = rvec1(2) / stheta + ! Returns the spherical harmonics Y_lm(^rvec) for l = 0,...,ll in Y(1,...,(ll+1)**2). + SUBROUTINE harmonicsr(Y, rvec, ll) + use m_judft + IMPLICIT NONE + INTEGER, INTENT(IN) :: ll + REAL, INTENT(IN) :: rvec(3) + COMPLEX, INTENT(OUT) :: Y((ll + 1)**2) + REAL :: stheta, ctheta, sphi, cphi, r, rvec1(3) + INTEGER :: l, lm + COMPLEX :: c + COMPLEX, PARAMETER :: img = (0.0, 1.0) + + call timestart("symm harmonics") + Y(1) = 0.282094791773878 + IF (ll == 0) RETURN + + stheta = 0 + ctheta = 0 + sphi = 0 + cphi = 0 + r = SQRT(SUM(rvec**2)) + IF (r > 10.0**-16) THEN + rvec1 = rvec/r + ctheta = rvec1(3) + stheta = SQRT(rvec1(1)**2 + rvec1(2)**2) + IF (stheta > 10.0**-16) THEN + cphi = rvec1(1)/stheta + sphi = rvec1(2)/stheta + END IF + ELSE + Y(2:) = 0.0 + RETURN END IF - ELSE - Y(2:) = 0.0 - RETURN - END IF - ! define Y,l,-l and Y,l,l - r = Y(1) - c = 1 - DO l = 1, ll - r = r*stheta*SQRT(1.0+1.0/(2*l)) - c = c * (cphi + img*sphi) - Y(l**2+1) = r*CONJG(c) ! l,-l - Y((l+1)**2) = r*c*(-1)**l ! l,l - END DO + ! define Y,l,-l and Y,l,l + r = Y(1) + c = 1 + DO l = 1, ll + r = r*stheta*SQRT(1.0 + 1.0/(2*l)) + c = c*(cphi + img*sphi) + Y(l**2 + 1) = r*CONJG(c) ! l,-l + Y((l + 1)**2) = r*c*(-1)**l ! l,l + END DO - ! define Y,l,-l+1 and Y,l,l-1 - Y(3) = 0.48860251190292*ctheta - DO l = 2, ll - r = SQRT(2.0*l+1) * ctheta - Y(l**2+2) = r*Y((l-1)**2+1) ! l,-l+1 - Y(l*(l+2)) = r*Y(l**2) ! l,l-1 - END DO + ! define Y,l,-l+1 and Y,l,l-1 + Y(3) = 0.48860251190292*ctheta + DO l = 2, ll + r = SQRT(2.0*l + 1)*ctheta + Y(l**2 + 2) = r*Y((l - 1)**2 + 1) ! l,-l+1 + Y(l*(l + 2)) = r*Y(l**2) ! l,l-1 + END DO - ! define Y,l,m, |m| 10.0**-8)) THEN + WRITE (*, *) maxval(abs(aimag(zhlp(:, i)/cdum))) + WRITE (*, *) zhlp + STOP 'waveftrafo1: Residual imaginary part.' + END IF + z_rout(:, i) = zhlp(:, i)/cdum + cmt_out(i, :, :) = cmt_out(i, :, :)/cdum + else + z_cout(:, i) = zhlp(:, i) + endif + END DO ELSE if (l_real) THEN z_rout = zhlp @@ -326,95 +321,93 @@ endif END IF - - END SUBROUTINE waveftrafo_genwavf - + END SUBROUTINE waveftrafo_genwavf ! - - - - - - - - - - - - - - - - - - - - - - - - - - - - - - - - - - - - - - - - ! Symmetrizes MT part of input matrix according to inversion symmetry. - ! This is achieved by a transformation to - ! 1/sqrt(2) * ( exp(ikR) Y_lm(r-R) + (-1)**(l+m) exp(-ikR) Y_l,-m(r+R) ) - ! and if R /=0 or m<0 - ! i/sqrt(2) * ( exp(ikR) Y_lm(r-R) - (-1)**(l+m) exp(-ikR) Y_l,-m(r+R) ) . - ! - ! or - ! i*Y_l,0(r) if R=0,m=0 and l odd - ! These functions have the property f(-r)=f(r)* which makes the output matrix real symmetric. - ! (Array mat is overwritten! ) - - SUBROUTINE symmetrize( mat,dim1,dim2,imode,lreal,& - atoms,lcutm,maxlcutm, nindxm,sym) - USE m_types + ! Symmetrizes MT part of input matrix according to inversion symmetry. + ! This is achieved by a transformation to + ! 1/sqrt(2) * ( exp(ikR) Y_lm(r-R) + (-1)**(l+m) exp(-ikR) Y_l,-m(r+R) ) + ! and if R /=0 or m<0 + ! i/sqrt(2) * ( exp(ikR) Y_lm(r-R) - (-1)**(l+m) exp(-ikR) Y_l,-m(r+R) ) . + ! + ! or + ! i*Y_l,0(r) if R=0,m=0 and l odd + ! These functions have the property f(-r)=f(r)* which makes the output matrix real symmetric. + ! (Array mat is overwritten! ) + + SUBROUTINE symmetrize(mat, dim1, dim2, imode, lreal, & + atoms, lcutm, maxlcutm, nindxm, sym) + USE m_types IMPLICIT NONE - TYPE(t_atoms),INTENT(IN) :: atoms - TYPE(t_sym),INTENT(IN) :: sym - + TYPE(t_atoms), INTENT(IN) :: atoms + TYPE(t_sym), INTENT(IN) :: sym + ! - scalars - - INTEGER,INTENT(IN) :: imode,dim1,dim2 - INTEGER,INTENT(IN) :: maxlcutm - LOGICAL,INTENT(IN) :: lreal + INTEGER, INTENT(IN) :: imode, dim1, dim2 + INTEGER, INTENT(IN) :: maxlcutm + LOGICAL, INTENT(IN) :: lreal ! - arrays - - INTEGER,INTENT(IN) :: lcutm(atoms%ntype) - INTEGER,INTENT(IN) :: nindxm(0:maxlcutm,atoms%ntype) - COMPLEX,INTENT(INOUT) :: mat(dim1,dim2) + INTEGER, INTENT(IN) :: lcutm(atoms%ntype) + INTEGER, INTENT(IN) :: nindxm(0:maxlcutm, atoms%ntype) + COMPLEX, INTENT(INOUT) :: mat(dim1, dim2) ! -local scalars - - INTEGER :: i,j,itype,ieq,ic,ic1,i1,i2,l,m,n,nn,ifac,ishift - REAL :: rfac,rdum,rmax - COMPLEX :: img = (0.0,1.0) + INTEGER :: i, j, itype, ieq, ic, ic1, i1, i2, l, m, n, nn, ifac, ishift + REAL :: rfac, rdum, rmax + COMPLEX :: img = (0.0, 1.0) ! - local arrays - - COMPLEX :: carr(max(dim1,dim2)),cfac + COMPLEX :: carr(max(dim1, dim2)), cfac rfac = sqrt(0.5) cfac = sqrt(0.5)*img - ic = 0 - i = 0 - - DO itype = 1,atoms%ntype - nn = sum( (/ ((2*l+1)*nindxm(l,itype),l=0,lcutm(itype)) /) ) - DO ieq = 1,atoms%neq(itype) - ic = ic + 1 - IF( atoms%invsat(ic) .eq. 0) THEN + ic = 0 + i = 0 + + DO itype = 1, atoms%ntype + nn = sum((/((2*l + 1)*nindxm(l, itype), l=0, lcutm(itype))/)) + DO ieq = 1, atoms%neq(itype) + ic = ic + 1 + IF (atoms%invsat(ic) == 0) THEN ! if the structure is inversion-symmetric, but the equivalent atom belongs to a different unit cell ! invsat(atom) = 0, invsatnr(atom) = 0 ! but we need invsatnr(atom) = natom ic1 = ic - ELSE + ELSE ic1 = sym%invsatnr(ic) END IF !ic1 = invsatnr(ic) - IF( ic1 .lt. ic ) THEN + IF (ic1 < ic) THEN i = i + nn CYCLE END IF ! IF( ic1 .lt. ic ) cycle - DO l = 0,lcutm(itype) + DO l = 0, lcutm(itype) ifac = -1 - DO m = -l,l - ifac = -ifac - ishift = (ic1-ic)*nn - 2*m*nindxm(l,itype) - DO n = 1,nindxm(l,itype) + DO m = -l, l + ifac = -ifac + ishift = (ic1 - ic)*nn - 2*m*nindxm(l, itype) + DO n = 1, nindxm(l, itype) i = i + 1 j = i + ishift - IF( ic1 .ne. ic .or. m .lt. 0 ) THEN - IF( iand(imode,1).ne.0 ) THEN - carr(:dim2) = mat(i,:) - mat(i,:) = ( carr(:dim2) + ifac * mat(j,:) ) * rfac - mat(j,:) = ( carr(:dim2) - ifac * mat(j,:) ) * (-cfac) + IF (ic1 /= ic .or. m < 0) THEN + IF (iand(imode, 1) /= 0) THEN + carr(:dim2) = mat(i, :) + mat(i, :) = (carr(:dim2) + ifac*mat(j, :))*rfac + mat(j, :) = (carr(:dim2) - ifac*mat(j, :))*(-cfac) END IF - IF( iand(imode,2).ne.0) THEN - carr(:dim1) = mat(:,i) - mat(:,i) = ( carr(:dim1) + ifac * mat(:,j) ) * rfac - mat(:,j) = ( carr(:dim1) - ifac * mat(:,j) ) * cfac + IF (iand(imode, 2) /= 0) THEN + carr(:dim1) = mat(:, i) + mat(:, i) = (carr(:dim1) + ifac*mat(:, j))*rfac + mat(:, j) = (carr(:dim1) - ifac*mat(:, j))*cfac END IF - ELSE IF( m .eq. 0 .and. ifac .eq. -1) THEN - IF( iand(imode,1) .ne. 0) THEN - mat(i,:) = -img * mat(i,:) + ELSE IF (m == 0 .and. ifac == -1) THEN + IF (iand(imode, 1) /= 0) THEN + mat(i, :) = -img*mat(i, :) END IF - IF( iand(imode,2) .ne. 0) THEN - mat(:,i) = img * mat(:,i) + IF (iand(imode, 2) /= 0) THEN + mat(:, i) = img*mat(:, i) END IF END IF END DO @@ -423,11 +416,11 @@ END DO END DO - IF(lreal) THEN + IF (lreal) THEN ! ! Determine common phase factor and devide by it to make the output matrix real. ! rmax = 0 ! DO i = 1,dim1 -! DO j = 1,dim2 +! DO j = 1,dim2 ! rdum = abs(real(mat(i,j)))+abs(aimag(mat(i,j))) ! IF(rdum.gt.10.0**-6) THEN ! cfac = mat(i,j)/abs(mat(i,j)) @@ -440,334 +433,327 @@ ! END DO ! IF(1-abs(cfac) .gt.10.0**-8) THEN ; mat = 0 ; RETURN ; END IF ! 1 IF(abs(1-cfac**2).gt.10.0**-8) mat = mat/cfac -! +! ! IF(any(abs(aimag(mat)).gt.10.0**-8)) THEN ! WRITE(*,*) maxval(aimag(mat)) ! STOP 'symmetrize: Residual imaginary part. Symmetrization failed.' ! Determine common phase factor and divide by it to make the output matrix real. - CALL commonphase(cfac,mat,dim1*dim2) - mat = mat / cfac - IF(any(abs(aimag(mat)).gt.10.0**-8)) & + CALL commonphase(cfac, mat, dim1*dim2) + mat = mat/cfac + IF (any(abs(aimag(mat)) > 10.0**-8)) & &STOP 'symmetrize: Residual imaginary part. Symmetrization failed.' END IF - END SUBROUTINE symmetrize + END SUBROUTINE symmetrize -! - - - - - - - - - - - - - - - - - - - - - - - - - - - - - - - - - - - - - - - - - - - - - - - - - - - +! - - - - - - - - - - - - - - - - - - - - - - - - - - - - - - - - - - - - - - - - - - - - - - - - - - - - ! Undoes symmetrization with routine symmetrize. - SUBROUTINE desymmetrize(mat,dim1,dim2,imode,& - atoms,lcutm,maxlcutm, nindxm,sym) + ! Undoes symmetrization with routine symmetrize. + SUBROUTINE desymmetrize(mat, dim1, dim2, imode, & + atoms, lcutm, maxlcutm, nindxm, sym) - USE m_types + USE m_types IMPLICIT NONE - TYPE(t_sym),INTENT(IN) :: sym - TYPE(t_atoms),INTENT(IN) :: atoms + TYPE(t_sym), INTENT(IN) :: sym + TYPE(t_atoms), INTENT(IN) :: atoms ! - scalars - - INTEGER,INTENT(IN) :: imode,dim1,dim2 - INTEGER,INTENT(IN) :: maxlcutm + INTEGER, INTENT(IN) :: imode, dim1, dim2 + INTEGER, INTENT(IN) :: maxlcutm ! - arrays - - INTEGER,INTENT(IN) :: lcutm(atoms%ntype) - INTEGER,INTENT(IN) :: nindxm(0:maxlcutm,atoms%ntype) - COMPLEX,INTENT(INOUT) :: mat(dim1,dim2) + INTEGER, INTENT(IN) :: lcutm(atoms%ntype) + INTEGER, INTENT(IN) :: nindxm(0:maxlcutm, atoms%ntype) + COMPLEX, INTENT(INOUT) :: mat(dim1, dim2) ! - local scalars - - INTEGER :: ifac,i,j,itype,ieq,ic,ic1,i1,i2,l,m,n, nn,ishift - REAL :: rfac1,rfac2 - COMPLEX :: img = (0.0,1.0) + INTEGER :: ifac, i, j, itype, ieq, ic, ic1, i1, i2, l, m, n, nn, ishift + REAL :: rfac1, rfac2 + COMPLEX :: img = (0.0, 1.0) ! - local arrays - - COMPLEX :: carr(max(dim1,dim2)) + COMPLEX :: carr(max(dim1, dim2)) rfac1 = sqrt(0.5) - ic = 0 - i = 0 - DO itype = 1,atoms%ntype - nn = sum( (/ ((2*l+1)*nindxm(l,itype),l=0,lcutm(itype)) /) ) - DO ieq = 1,atoms%neq(itype) - ic = ic + 1 - IF( atoms%invsat(ic) .eq. 0) THEN - ! if the structure is inversion-symmetric, but the equivalent atom belongs to a different unit cell - ! invsat(atom) = 0, invsatnr(atom) =0 - ! but we need invsatnr(atom) = natom - ic1 = ic - ELSE - ic1 = sym%invsatnr(ic) - END IF - !ic1 = invsatnr(ic) - !IF( ic1 .lt. ic ) cycle - IF ( ic1.lt.ic ) THEN - i = i + nn - CYCLE - END IF - DO l = 0,lcutm(itype) - ifac = -1 - DO m = -l,l - ifac = -ifac - rfac2 = rfac1 * ifac - ishift = (ic1-ic)*nn - 2*m*nindxm(l,itype) - DO n = 1,nindxm(l,itype) - i = i + 1 - j = i + ishift - IF( ic1 .ne. ic .or. m .lt. 0) THEN - IF( iand(imode,1) .ne.0) THEN - carr(:dim2) = mat(i,:) - mat(i,:) = ( carr(:dim2) + img * mat(j,:) ) * rfac1 - mat(j,:) = ( carr(:dim2) - img * mat(j,:) ) * rfac2 - END IF - IF( iand(imode,2).ne.0) THEN - carr(:dim1) = mat(:,i) - mat(:,i) = ( carr(:dim1) - img * mat(:,j) ) * rfac1 - mat(:,j) = ( carr(:dim1) + img * mat(:,j) ) * rfac2 - END IF - ELSE IF( m .eq. 0 .and. ifac .eq. -1 ) THEN - IF( iand(imode,1) .ne. 0 ) THEN - mat(i,:) = img * mat(i,:) - END IF - IF( iand(imode,2) .ne. 0) THEN - mat(:,i) = -img * mat(:,i) - END IF - END IF - END DO + ic = 0 + i = 0 + DO itype = 1, atoms%ntype + nn = sum((/((2*l + 1)*nindxm(l, itype), l=0, lcutm(itype))/)) + DO ieq = 1, atoms%neq(itype) + ic = ic + 1 + IF (atoms%invsat(ic) == 0) THEN + ! if the structure is inversion-symmetric, but the equivalent atom belongs to a different unit cell + ! invsat(atom) = 0, invsatnr(atom) =0 + ! but we need invsatnr(atom) = natom + ic1 = ic + ELSE + ic1 = sym%invsatnr(ic) + END IF + !ic1 = invsatnr(ic) + !IF( ic1 .lt. ic ) cycle + IF (ic1 < ic) THEN + i = i + nn + CYCLE + END IF + DO l = 0, lcutm(itype) + ifac = -1 + DO m = -l, l + ifac = -ifac + rfac2 = rfac1*ifac + ishift = (ic1 - ic)*nn - 2*m*nindxm(l, itype) + DO n = 1, nindxm(l, itype) + i = i + 1 + j = i + ishift + IF (ic1 /= ic .or. m < 0) THEN + IF (iand(imode, 1) /= 0) THEN + carr(:dim2) = mat(i, :) + mat(i, :) = (carr(:dim2) + img*mat(j, :))*rfac1 + mat(j, :) = (carr(:dim2) - img*mat(j, :))*rfac2 + END IF + IF (iand(imode, 2) /= 0) THEN + carr(:dim1) = mat(:, i) + mat(:, i) = (carr(:dim1) - img*mat(:, j))*rfac1 + mat(:, j) = (carr(:dim1) + img*mat(:, j))*rfac2 + END IF + ELSE IF (m == 0 .and. ifac == -1) THEN + IF (iand(imode, 1) /= 0) THEN + mat(i, :) = img*mat(i, :) + END IF + IF (iand(imode, 2) /= 0) THEN + mat(:, i) = -img*mat(:, i) + END IF + END IF + END DO + END DO END DO - END DO - END DO + END DO END DO - END SUBROUTINE desymmetrize - - ! bra_trafo1 rotates cprod at ikpt0(<=> not irreducible k-point) to cprod at ikpt1 (bkp(ikpt0)), which is the - ! symmetrie equivalent one - ! isym maps ikpt0 on ikpt1 + END SUBROUTINE desymmetrize + ! bra_trafo1 rotates cprod at ikpt0(<=> not irreducible k-point) to cprod at ikpt1 (bkp(ikpt0)), which is the + ! symmetrie equivalent one + ! isym maps ikpt0 on ikpt1 - SUBROUTINE bra_trafo2 (& - l_real,vecout_r,vecin_r,vecout_c,vecin_c,& - dim,nobd,nbands,ikpt0,ikpt1,iop,sym,& - hybrid,kpts,cell,atoms,& - phase) + SUBROUTINE bra_trafo2( & + l_real, vecout_r, vecin_r, vecout_c, vecin_c, & + dim, nobd, nbands, ikpt0, ikpt1, iop, sym, & + hybrid, kpts, cell, atoms, & + phase) ! ikpt0 :: parent of ikpt1 ! iop maps ikpt0 on ikpt1 - USE m_constants + USE m_constants USE m_dwigner USE m_util USE m_types IMPLICIT NONE - TYPE(t_hybrid),INTENT(IN) :: hybrid - TYPE(t_sym),INTENT(IN) :: sym - TYPE(t_cell),INTENT(IN) :: cell - TYPE(t_kpts),INTENT(IN) :: kpts - TYPE(t_atoms),INTENT(IN) :: atoms + TYPE(t_hybrid), INTENT(IN) :: hybrid + TYPE(t_sym), INTENT(IN) :: sym + TYPE(t_cell), INTENT(IN) :: cell + TYPE(t_kpts), INTENT(IN) :: kpts + TYPE(t_atoms), INTENT(IN) :: atoms ! - scalars - - INTEGER,INTENT(IN) :: ikpt0,ikpt1,iop,dim,nobd,nbands - + INTEGER, INTENT(IN) :: ikpt0, ikpt1, iop, dim, nobd, nbands + ! - arrays - - - - LOGICAL,INTENT(IN) :: l_real - REAL,INTENT(IN) :: vecin_r(dim,nobd,nbands) - REAL,INTENT(OUT) :: vecout_r(dim,nobd,nbands) - COMPLEX,INTENT(IN) :: vecin_c(dim,nobd,nbands) - COMPLEX,INTENT(OUT) :: vecout_c(dim,nobd,nbands) - COMPLEX,INTENT(OUT) :: phase(nobd,nbands) + LOGICAL, INTENT(IN) :: l_real + + REAL, INTENT(IN) :: vecin_r(dim, nobd, nbands) + REAL, INTENT(OUT) :: vecout_r(dim, nobd, nbands) + COMPLEX, INTENT(IN) :: vecin_c(dim, nobd, nbands) + COMPLEX, INTENT(OUT) :: vecout_c(dim, nobd, nbands) + COMPLEX, INTENT(OUT) :: phase(nobd, nbands) ! - local - -! - scalars - - INTEGER :: nrkpt,rcent,itype,ieq,ic,l,n,i,j,nn, i1,i2,j1,j2,m1,m2,ok - INTEGER :: igptm,igptm2,igptp,icent1,iiatom,iiop, inviop - COMPLEX :: cexp,cdum - COMPLEX,PARAMETER :: img=(0.0,1.0) -! - arrays - - - INTEGER :: rrot(3,3),invrot(3,3) - INTEGER :: pnt(hybrid%maxindxm1,0:hybrid%maxlcutm1,atoms%nat) - INTEGER :: g(3),g1(3) - REAL :: rkpt(3),rkpthlp(3),rtaual(3),trans(3) +! - scalars - + INTEGER :: nrkpt, rcent, itype, ieq, ic, l, n, i, j, nn, i1, i2, j1, j2, m1, m2, ok + INTEGER :: igptm, igptm2, igptp, icent1, iiatom, iiop, inviop + COMPLEX :: cexp, cdum + COMPLEX, PARAMETER :: img = (0.0, 1.0) +! - arrays - + + INTEGER :: rrot(3, 3), invrot(3, 3) + INTEGER :: pnt(hybrid%maxindxm1, 0:hybrid%maxlcutm1, atoms%nat) + INTEGER :: g(3), g1(3) + REAL :: rkpt(3), rkpthlp(3), rtaual(3), trans(3) REAL :: arg COMPLEX :: dwgn(-hybrid%maxlcutm1:hybrid%maxlcutm1,& - & -hybrid%maxlcutm1:hybrid%maxlcutm1,0:hybrid%maxlcutm1) + & -hybrid%maxlcutm1:hybrid%maxlcutm1, 0:hybrid%maxlcutm1) ! COMPLEX :: vecin1(dim,nobd,nbands),vecout1(dim,nobd,nbands) - COMPLEX, ALLOCATABLE :: vecin1(:,:,:),vecout1(:,:,:) - + COMPLEX, ALLOCATABLE :: vecin1(:, :, :), vecout1(:, :, :) call timestart("bra trafo") - ALLOCATE ( vecin1( dim,nobd,nbands), & - & vecout1(dim,nobd,nbands), stat=ok ) - IF ( ok /= 0 ) & + ALLOCATE (vecin1(dim, nobd, nbands), & + & vecout1(dim, nobd, nbands), stat=ok) + IF (ok /= 0) & & STOP 'bra_trafo2: error allocating vecin1 or vecout1' - vecin1 = 0 ; vecout1 = 0 + vecin1 = 0; vecout1 = 0 - IF( hybrid%maxlcutm1 .gt. atoms%lmaxd ) STOP 'bra_trafo2: maxlcutm > atoms%lmaxd' ! very improbable case + IF (hybrid%maxlcutm1 > atoms%lmaxd) STOP 'bra_trafo2: maxlcutm > atoms%lmaxd' ! very improbable case ! transform back to unsymmetrized product basis in case of inversion symmetry if (l_real) THEN vecin1 = vecin_r - DO i=1,nbands - DO j=1,nobd - CALL desymmetrize(vecin1(:hybrid%nbasp,j,i),hybrid%nbasp,1,1,& - atoms,hybrid%lcutm1,hybrid%maxlcutm1, hybrid%nindxm1,sym) + DO i = 1, nbands + DO j = 1, nobd + CALL desymmetrize(vecin1(:hybrid%nbasp, j, i), hybrid%nbasp, 1, 1, & + atoms, hybrid%lcutm1, hybrid%maxlcutm1, hybrid%nindxm1, sym) END DO END DO else - vecin1=vecin_c + vecin1 = vecin_c endif - - IF( iop .le. sym%nop ) THEN - inviop = sym%invtab(iop) - rrot = transpose( sym%mrot(:,:,sym%invtab(iop)) ) - invrot = sym%mrot(:,:,sym%invtab(iop)) - trans = sym%tau(:,iop) - - dwgn (-hybrid%maxlcutm1:hybrid%maxlcutm1,-hybrid%maxlcutm1:hybrid%maxlcutm1,0:hybrid%maxlcutm1) & - = hybrid%d_wgn2(-hybrid%maxlcutm1:hybrid%maxlcutm1,-hybrid%maxlcutm1:hybrid%maxlcutm1,0:hybrid%maxlcutm1,inviop) + IF (iop <= sym%nop) THEN + inviop = sym%invtab(iop) + rrot = transpose(sym%mrot(:, :, sym%invtab(iop))) + invrot = sym%mrot(:, :, sym%invtab(iop)) + trans = sym%tau(:, iop) + dwgn(-hybrid%maxlcutm1:hybrid%maxlcutm1, -hybrid%maxlcutm1:hybrid%maxlcutm1, 0:hybrid%maxlcutm1) & + = hybrid%d_wgn2(-hybrid%maxlcutm1:hybrid%maxlcutm1, -hybrid%maxlcutm1:hybrid%maxlcutm1, 0:hybrid%maxlcutm1, inviop) ELSE - iiop = iop -sym%nop - inviop = sym%invtab(iiop)+sym%nop - rrot = -transpose( sym%mrot(:,:,sym%invtab(iiop)) ) - invrot = sym%mrot(:,:,sym%invtab(iiop)) - trans = sym%tau(:,iiop) + iiop = iop - sym%nop + inviop = sym%invtab(iiop) + sym%nop + rrot = -transpose(sym%mrot(:, :, sym%invtab(iiop))) + invrot = sym%mrot(:, :, sym%invtab(iiop)) + trans = sym%tau(:, iiop) - dwgn (-hybrid%maxlcutm1:hybrid%maxlcutm1,-hybrid%maxlcutm1:hybrid%maxlcutm1,0:hybrid%maxlcutm1)& - = conjg( hybrid%d_wgn2(-hybrid%maxlcutm1:hybrid%maxlcutm1, -hybrid%maxlcutm1:hybrid%maxlcutm1, 0:hybrid%maxlcutm1,inviop)) + dwgn(-hybrid%maxlcutm1:hybrid%maxlcutm1, -hybrid%maxlcutm1:hybrid%maxlcutm1, 0:hybrid%maxlcutm1) & + = conjg(hybrid%d_wgn2(-hybrid%maxlcutm1:hybrid%maxlcutm1, -hybrid%maxlcutm1:hybrid%maxlcutm1, 0:hybrid%maxlcutm1, inviop)) END IF - - rkpt = matmul(rrot,kpts%bkf(:,ikpt0)) + rkpt = matmul(rrot, kpts%bkf(:, ikpt0)) rkpthlp = rkpt - rkpt = modulo1(rkpt,kpts%nkpt3) - g = nint(rkpthlp-rkpt) + rkpt = modulo1(rkpt, kpts%nkpt3) + g = nint(rkpthlp - rkpt) #ifdef CPP_DEBUG - !test - nrkpt=0 - DO i=1,kpts%nkptf - IF ( maxval( abs(rkpt - kpts%bkf(:,i)) ) .le. 1E-06 ) THEN - nrkpt = i - EXIT - END IF + !test + nrkpt = 0 + DO i = 1, kpts%nkptf + IF (maxval(abs(rkpt - kpts%bkf(:, i))) <= 1E-06) THEN + nrkpt = i + EXIT + END IF END DO - IF( nrkpt .NE. ikpt1 ) THEN - PRINT *,ikpt0,ikpt1 - PRINT *,kpts%bkf(:,ikpt1) - PRINT *,kpts%bkf(:,ikpt0) - PRINT *,rkpt + IF (nrkpt /= ikpt1) THEN + PRINT *, ikpt0, ikpt1 + PRINT *, kpts%bkf(:, ikpt1) + PRINT *, kpts%bkf(:, ikpt0) + PRINT *, rkpt STOP 'bra_trafo2: rotation failed' ENDIF #endif ! Define pointer to first mixed-basis functions (with m = -l) - i = 0 - ic = 0 - DO itype = 1,atoms%ntype - DO ieq = 1,atoms%neq(itype) - ic = ic + 1 - DO l = 0,hybrid%lcutm1(itype) - DO n = 1,hybrid%nindxm1(l,itype) - i = i + 1 - pnt(n,l,ic) = i + i = 0 + ic = 0 + DO itype = 1, atoms%ntype + DO ieq = 1, atoms%neq(itype) + ic = ic + 1 + DO l = 0, hybrid%lcutm1(itype) + DO n = 1, hybrid%nindxm1(l, itype) + i = i + 1 + pnt(n, l, ic) = i + END DO + i = i + hybrid%nindxm1(l, itype)*2*l END DO - i = i + hybrid%nindxm1(l,itype) * 2*l - END DO - END DO + END DO END DO ! Multiplication ! MT - cexp = exp(img*tpi_const*dot_product( kpts%bkf(:,ikpt1)+g,trans(:) ) ) - ic = 0 + cexp = exp(img*tpi_const*dot_product(kpts%bkf(:, ikpt1) + g, trans(:))) + ic = 0 iiatom = 0 - DO itype = 1,atoms%ntype - DO ieq = 1,atoms%neq(itype) - ic = ic + 1 + DO itype = 1, atoms%ntype + DO ieq = 1, atoms%neq(itype) + ic = ic + 1 - rcent = hybrid%map(ic,iop) + rcent = hybrid%map(ic, iop) - cdum = cexp *exp(-img*tpi_const*dot_product(g,atoms%taual(:,rcent))) + cdum = cexp*exp(-img*tpi_const*dot_product(g, atoms%taual(:, rcent))) - DO l = 0,hybrid%lcutm1(itype) - nn = hybrid%nindxm1(l,itype) - DO n = 1,nn + DO l = 0, hybrid%lcutm1(itype) + nn = hybrid%nindxm1(l, itype) + DO n = 1, nn - i1 = pnt(n,l,ic) - i2 = i1 + nn * 2*l - j1 = pnt(n,l,rcent) - j2 = j1 + nn * 2*l - - DO i=1,nbands - DO j=1,nobd - vecout1(i1:i2:nn,j,i) = cdum * matmul(vecin1(j1:j2:nn,j,i),dwgn(-l:l,-l:l,l)) - END DO - END DO + i1 = pnt(n, l, ic) + i2 = i1 + nn*2*l + j1 = pnt(n, l, rcent) + j2 = j1 + nn*2*l + DO i = 1, nbands + DO j = 1, nobd + vecout1(i1:i2:nn, j, i) = cdum*matmul(vecin1(j1:j2:nn, j, i), dwgn(-l:l, -l:l, l)) + END DO + END DO + END DO END DO - END DO - END DO - iiatom = iiatom + atoms%neq(itype) + END DO + iiatom = iiatom + atoms%neq(itype) END DO ! PW - DO igptm = 1,hybrid%ngptm(ikpt0) - igptp = hybrid%pgptm(igptm,ikpt0) - g1 = matmul(rrot,hybrid%gptm(:,igptp)) + g - igptm2 = 0 - DO i=1,hybrid%ngptm(ikpt1) - IF ( maxval(abs(g1-hybrid%gptm(:,hybrid%pgptm(i,ikpt1)))) .le. 1E-06 ) THEN - igptm2 = i - EXIT - END IF - END DO - IF(igptm2 .eq. 0) THEN - WRITE(*,*) ikpt0,ikpt1,g1 - WRITE(*,*) hybrid%ngptm(ikpt0),hybrid%ngptm(ikpt1) - WRITE(*,*) - WRITE(*,*) igptp,hybrid%gptm(:,igptp) - WRITE(*,*) g - WRITE(*,*) rrot - WRITE (*,*) "Failed tests:",g1 - DO i=1,hybrid%ngptm(ikpt1) - WRITE(*,*) hybrid%gptm(:,hybrid%pgptm(i,ikpt1)) - ENDDO - STOP 'bra_trafo2: G-point not found in G-point set.' - END IF - cdum = exp(img*tpi_const*dot_product(kpts%bkf(:,ikpt1)+g1,trans(:))) - - vecout1(hybrid%nbasp+igptm,:,:)= cdum * vecin1(hybrid%nbasp+igptm2,:,:) + DO igptm = 1, hybrid%ngptm(ikpt0) + igptp = hybrid%pgptm(igptm, ikpt0) + g1 = matmul(rrot, hybrid%gptm(:, igptp)) + g + igptm2 = 0 + DO i = 1, hybrid%ngptm(ikpt1) + IF (maxval(abs(g1 - hybrid%gptm(:, hybrid%pgptm(i, ikpt1)))) <= 1E-06) THEN + igptm2 = i + EXIT + END IF + END DO + IF (igptm2 == 0) THEN + WRITE (*, *) ikpt0, ikpt1, g1 + WRITE (*, *) hybrid%ngptm(ikpt0), hybrid%ngptm(ikpt1) + WRITE (*, *) + WRITE (*, *) igptp, hybrid%gptm(:, igptp) + WRITE (*, *) g + WRITE (*, *) rrot + WRITE (*, *) "Failed tests:", g1 + DO i = 1, hybrid%ngptm(ikpt1) + WRITE (*, *) hybrid%gptm(:, hybrid%pgptm(i, ikpt1)) + ENDDO + STOP 'bra_trafo2: G-point not found in G-point set.' + END IF + cdum = exp(img*tpi_const*dot_product(kpts%bkf(:, ikpt1) + g1, trans(:))) + + vecout1(hybrid%nbasp + igptm, :, :) = cdum*vecin1(hybrid%nbasp + igptm2, :, :) END DO - DEALLOCATE ( vecin1 ) + DEALLOCATE (vecin1) if (l_real) THEN - DO i=1,nbands - DO j=1,nobd + DO i = 1, nbands + DO j = 1, nobd - CALL symmetrize(vecout1(:,j,i),dim,1,1,.false.,& - atoms,hybrid%lcutm1,hybrid%maxlcutm1, hybrid%nindxm1,sym) + CALL symmetrize(vecout1(:, j, i), dim, 1, 1, .false., & + atoms, hybrid%lcutm1, hybrid%maxlcutm1, hybrid%nindxm1, sym) - CALL commonphase(phase(j,i),vecout1(:,j,i),dim) - vecout1(:,j,i) = vecout1(:,j,i) / phase(j,i) - IF(any(abs(aimag(vecout1(:,j,i))).gt.10.0**-8)) THEN - WRITE(*,*) vecout1(:,j,i) + CALL commonphase(phase(j, i), vecout1(:, j, i), dim) + vecout1(:, j, i) = vecout1(:, j, i)/phase(j, i) + IF (any(abs(aimag(vecout1(:, j, i))) > 10.0**-8)) THEN + WRITE (*, *) vecout1(:, j, i) STOP 'bra_trafo2: Residual imaginary part.' END IF - + END DO - END DO + END DO else - phase = (1.0,0.0) + phase = (1.0, 0.0) endif if (l_real) THEN @@ -775,65 +761,62 @@ else vecout_c = vecout1 endif - DEALLOCATE ( vecout1 ) + DEALLOCATE (vecout1) call timestop("bra trafo") - END SUBROUTINE bra_trafo2 - + END SUBROUTINE bra_trafo2 ! This routine is not very fast at the moment. - SUBROUTINE matrixtrafo(matout,matin,ikpt0,isym,lsymmetrize,atoms, & - kpts,sym, hybrid,cell,maxindxm,nindxm,nbasm,ngptmall,nbasp,& - lcutm,maxlcutm) - + SUBROUTINE matrixtrafo(matout, matin, ikpt0, isym, lsymmetrize, atoms, & + kpts, sym, hybrid, cell, maxindxm, nindxm, nbasm, ngptmall, nbasp, & + lcutm, maxlcutm) USE m_wrapper USE m_dwigner - USE m_util ,ONLY: modulo1 - USE m_constants - USE m_types + USE m_util, ONLY: modulo1 + USE m_constants + USE m_types IMPLICIT NONE - TYPE(t_hybrid),INTENT(IN) :: hybrid - TYPE(t_sym),INTENT(IN) :: sym - TYPE(t_cell),INTENT(IN) :: cell - TYPE(t_kpts),INTENT(IN) :: kpts - TYPE(t_atoms),INTENT(IN) :: atoms - + TYPE(t_hybrid), INTENT(IN) :: hybrid + TYPE(t_sym), INTENT(IN) :: sym + TYPE(t_cell), INTENT(IN) :: cell + TYPE(t_kpts), INTENT(IN) :: kpts + TYPE(t_atoms), INTENT(IN) :: atoms + ! - scalars - - INTEGER , INTENT(IN) :: ikpt0,isym - INTEGER , INTENT(IN) :: nbasp - INTEGER , INTENT(IN) :: maxlcutm,maxindxm - LOGICAL , INTENT(IN) :: lsymmetrize + INTEGER, INTENT(IN) :: ikpt0, isym + INTEGER, INTENT(IN) :: nbasp + INTEGER, INTENT(IN) :: maxlcutm, maxindxm + LOGICAL, INTENT(IN) :: lsymmetrize ! - arrays - - INTEGER , INTENT(IN) :: nbasm(kpts%nkpt) - INTEGER , INTENT(IN) :: nindxm(0:maxlcutm,atoms%ntype) - INTEGER , INTENT(IN) :: ngptmall - INTEGER , INTENT(IN) :: lcutm(atoms%ntype) - + INTEGER, INTENT(IN) :: nbasm(kpts%nkpt) + INTEGER, INTENT(IN) :: nindxm(0:maxlcutm, atoms%ntype) + INTEGER, INTENT(IN) :: ngptmall + INTEGER, INTENT(IN) :: lcutm(atoms%ntype) - COMPLEX , INTENT(IN) :: matin(nbasm(ikpt0),nbasm(ikpt0)) - COMPLEX , INTENT(OUT) :: matout(nbasm(ikpt0),nbasm(ikpt0)) + COMPLEX, INTENT(IN) :: matin(nbasm(ikpt0), nbasm(ikpt0)) + COMPLEX, INTENT(OUT) :: matout(nbasm(ikpt0), nbasm(ikpt0)) ! - local scalars - - INTEGER :: iatom,iatom1,iiatom,itype,ieq,ieq1,ic,& - & l,n,i,nn,i1,i2,j1,j2 - INTEGER :: igptm,igptm1,igptm2,igptp,igptp1,& - & ikpt1,isymi,iisym - INTEGER :: m1,m2 + INTEGER :: iatom, iatom1, iiatom, itype, ieq, ieq1, ic,& + & l, n, i, nn, i1, i2, j1, j2 + INTEGER :: igptm, igptm1, igptm2, igptp, igptp1,& + & ikpt1, isymi, iisym + INTEGER :: m1, m2 - COMPLEX :: cexp,cdum - COMPLEX , PARAMETER :: img=(0.0,1.0) + COMPLEX :: cexp, cdum + COMPLEX, PARAMETER :: img = (0.0, 1.0) - ! - local arrays - - INTEGER :: pnt(maxindxm,0:maxlcutm,atoms%nat),& - & g(3),g1(3),iarr(hybrid%ngptm(ikpt0)) - INTEGER :: rot(3,3),invrot(3,3), rrot(3,3),invrrot(3,3) + ! - local arrays - + INTEGER :: pnt(maxindxm, 0:maxlcutm, atoms%nat),& + & g(3), g1(3), iarr(hybrid%ngptm(ikpt0)) + INTEGER :: rot(3, 3), invrot(3, 3), rrot(3, 3), invrrot(3, 3) - REAL :: rkpt(3),rkpthlp(3),rtaual(3) + REAL :: rkpt(3), rkpthlp(3), rtaual(3) REAL :: trans(3) - COMPLEX :: matin1(nbasm(ikpt0),nbasm(ikpt0)) - COMPLEX :: matout1(nbasm(ikpt0),nbasm(ikpt0)) - COMPLEX :: dwgn (-maxlcutm:maxlcutm,& + COMPLEX :: matin1(nbasm(ikpt0), nbasm(ikpt0)) + COMPLEX :: matout1(nbasm(ikpt0), nbasm(ikpt0)) + COMPLEX :: dwgn(-maxlcutm:maxlcutm,& & -maxlcutm:maxlcutm,& & 0:maxlcutm) COMPLEX :: dwgninv(-maxlcutm:maxlcutm,& @@ -841,104 +824,98 @@ & 0:maxlcutm) COMPLEX :: carr(hybrid%ngptm(ikpt0)) - - ! Transform back to unsymmetrized product basis in case of inversion symmetry. - matin1 = matin - IF(lsymmetrize) THEN - CALL desymmetrize(matin1,nbasm(ikpt0),nbasm(ikpt0),3,& - atoms,lcutm,maxlcutm,nindxm,sym) + matin1 = matin + IF (lsymmetrize) THEN + CALL desymmetrize(matin1, nbasm(ikpt0), nbasm(ikpt0), 3, & + atoms, lcutm, maxlcutm, nindxm, sym) END IF - IF( isym .le. sym%nop ) THEN - iisym = isym - rot = sym%mrot(:,:,iisym) - invrot = sym%mrot(:,:,sym%invtab(iisym)) - rrot = transpose( sym%mrot(:,:,sym%invtab(iisym)) ) - invrrot = transpose( sym%mrot(:,:,iisym) ) - rkpt = matmul(rrot,kpts%bk(:,ikpt0)) - rkpthlp = modulo1(rkpt,kpts%nkpt3) - g = nint(rkpt - rkpthlp) - - - CALL d_wigner(invrot,cell%bmat,maxlcutm,dwgn(:,:,1:maxlcutm)) - dwgn(0,0,0) = 1 - - DO l=0,maxlcutm - dwgn(:,:,l) = transpose(dwgn(:,:,l)) - END DO + IF (isym <= sym%nop) THEN + iisym = isym + rot = sym%mrot(:, :, iisym) + invrot = sym%mrot(:, :, sym%invtab(iisym)) + rrot = transpose(sym%mrot(:, :, sym%invtab(iisym))) + invrrot = transpose(sym%mrot(:, :, iisym)) + rkpt = matmul(rrot, kpts%bk(:, ikpt0)) + rkpthlp = modulo1(rkpt, kpts%nkpt3) + g = nint(rkpt - rkpthlp) + + CALL d_wigner(invrot, cell%bmat, maxlcutm, dwgn(:, :, 1:maxlcutm)) + dwgn(0, 0, 0) = 1 + + DO l = 0, maxlcutm + dwgn(:, :, l) = transpose(dwgn(:, :, l)) + END DO ELSE - iisym = isym - sym%nop - rot = sym%mrot(:,:,iisym) - invrot = sym%mrot(:,:,sym%invtab(iisym)) - rrot = -transpose( sym%mrot(:,:,sym%invtab(iisym)) ) - invrrot = -transpose( sym%mrot(:,:,iisym) ) - rkpt = matmul(rrot,kpts%bk(:,ikpt0)) - rkpthlp = modulo1(rkpt,kpts%nkpt3) - g = nint(rkpt - rkpthlp) - matin1 = conjg(matin1) - - CALL d_wigner(invrot,cell%bmat,maxlcutm,dwgn(:,:,1:maxlcutm)) - dwgn(0,0,0) = 1 - - DO l=0,maxlcutm - dwgn(:,:,l) = transpose(dwgn(:,:,l)) - END DO - - DO l = 0,maxlcutm - DO m1 = -l,l - DO m2 = -l,-1 - cdum = dwgn(m1, m2,l) - dwgn(m1, m2,l) = dwgn(m1,-m2,l) * (-1)**m2 - dwgn(m1,-m2,l) = cdum * (-1)**m2 + iisym = isym - sym%nop + rot = sym%mrot(:, :, iisym) + invrot = sym%mrot(:, :, sym%invtab(iisym)) + rrot = -transpose(sym%mrot(:, :, sym%invtab(iisym))) + invrrot = -transpose(sym%mrot(:, :, iisym)) + rkpt = matmul(rrot, kpts%bk(:, ikpt0)) + rkpthlp = modulo1(rkpt, kpts%nkpt3) + g = nint(rkpt - rkpthlp) + matin1 = conjg(matin1) + + CALL d_wigner(invrot, cell%bmat, maxlcutm, dwgn(:, :, 1:maxlcutm)) + dwgn(0, 0, 0) = 1 + + DO l = 0, maxlcutm + dwgn(:, :, l) = transpose(dwgn(:, :, l)) + END DO + + DO l = 0, maxlcutm + DO m1 = -l, l + DO m2 = -l, -1 + cdum = dwgn(m1, m2, l) + dwgn(m1, m2, l) = dwgn(m1, -m2, l)*(-1)**m2 + dwgn(m1, -m2, l) = cdum*(-1)**m2 + END DO END DO - END DO - END DO + END DO END IF ! determine number of rotated k-point bk(:,ikpt) -> ikpt1 - ! - DO i=1,kpts%nkpt - IF ( maxval( abs(rkpthlp - kpts%bk(:,i)) ) .le. 1E-06 ) THEN - ikpt1 = i - EXIT - END IF + ! + DO i = 1, kpts%nkpt + IF (maxval(abs(rkpthlp - kpts%bk(:, i))) <= 1E-06) THEN + ikpt1 = i + EXIT + END IF END DO - - - DO l = 0,maxlcutm - dwgninv(-l:l,-l:l,l) = conjg(transpose(dwgn(-l:l,-l:l,l))) + DO l = 0, maxlcutm + dwgninv(-l:l, -l:l, l) = conjg(transpose(dwgn(-l:l, -l:l, l))) END DO ! Define pointer to first mixed-basis functions (with m = -l) - i = 0 - ic = 0 - DO itype = 1,atoms%ntype - DO ieq = 1,atoms%neq(itype) - ic = ic + 1 - DO l = 0,lcutm(itype) - DO n = 1,nindxm(l,itype) - i = i + 1 - pnt(n,l,ic) = i + i = 0 + ic = 0 + DO itype = 1, atoms%ntype + DO ieq = 1, atoms%neq(itype) + ic = ic + 1 + DO l = 0, lcutm(itype) + DO n = 1, nindxm(l, itype) + i = i + 1 + pnt(n, l, ic) = i + END DO + i = i + nindxm(l, itype)*2*l END DO - i = i + nindxm(l,itype) * 2*l - END DO - END DO + END DO END DO - ! Right-multiplication ! MT - cexp = exp(img*tpi_const* dot_product(kpts%bk(:,ikpt1)+g,sym%tau(:,iisym))) - iatom = 0 + cexp = exp(img*tpi_const*dot_product(kpts%bk(:, ikpt1) + g, sym%tau(:, iisym))) + iatom = 0 iiatom = 0 - DO itype = 1,atoms%ntype - DO ieq = 1,atoms%neq(itype) - iatom = iatom + 1 - cdum =cexp*exp(-img*tpi_const*dot_product(g,atoms%taual(:,iatom))) + DO itype = 1, atoms%ntype + DO ieq = 1, atoms%neq(itype) + iatom = iatom + 1 + cdum = cexp*exp(-img*tpi_const*dot_product(g, atoms%taual(:, iatom))) -! rtaual = matmul(invrot,taual(:,iatom)) + tau(:,invtab(iisym)) +! rtaual = matmul(invrot,taual(:,iatom)) + tau(:,invtab(iisym)) ! iatom1 = 0 ! DO ieq1 = 1,neq(itype) ! IF( all(abs(modulo(rtaual-taual(:,iiatom+ieq1)+10.0**-12,1.0)) @@ -946,171 +923,164 @@ ! iatom1 = iiatom + ieq1 ! END IF ! END DO -! IF( iatom1 .eq. 0 ) STOP 'matrixtrafo atom not found' +! IF( iatom1 .eq. 0 ) STOP 'matrixtrafo atom not found' - iatom1 = hybrid%map(iatom,sym%invtab(iisym)) - DO l = 0,lcutm(itype) - nn = nindxm(l,itype) - DO n = 1,nn + iatom1 = hybrid%map(iatom, sym%invtab(iisym)) + DO l = 0, lcutm(itype) + nn = nindxm(l, itype) + DO n = 1, nn - i1 = pnt(n,l,iatom) - i2 = i1 + nn * 2*l - j1 = pnt(n,l,iatom1) - j2 = j1 + nn * 2*l + i1 = pnt(n, l, iatom) + i2 = i1 + nn*2*l + j1 = pnt(n, l, iatom1) + j2 = j1 + nn*2*l - matout1(:,i1:i2:nn) = cdum * matmat( matin1(:,j1:j2:nn), & - & dwgn(-l:l,-l:l,l) ) + matout1(:, i1:i2:nn) = cdum*matmat(matin1(:, j1:j2:nn), & + & dwgn(-l:l, -l:l, l)) + END DO END DO - END DO - END DO - iiatom = iiatom + atoms%neq(itype) + END DO + iiatom = iiatom + atoms%neq(itype) END DO - ! PW - DO igptm = 1,hybrid%ngptm(ikpt1) - igptp = hybrid%pgptm(igptm,ikpt1) - g1 = matmul(invrrot,hybrid%gptm(:,igptp)-g) - igptm2 = 0 - DO i=1,hybrid%ngptm(ikpt0) - IF ( maxval( abs(g1-hybrid%gptm(:,hybrid%pgptm(i,ikpt0) )) ) .le. 1E-06 ) THEN - igptm2 = i - EXIT - END IF - END DO + DO igptm = 1, hybrid%ngptm(ikpt1) + igptp = hybrid%pgptm(igptm, ikpt1) + g1 = matmul(invrrot, hybrid%gptm(:, igptp) - g) + igptm2 = 0 + DO i = 1, hybrid%ngptm(ikpt0) + IF (maxval(abs(g1 - hybrid%gptm(:, hybrid%pgptm(i, ikpt0)))) <= 1E-06) THEN + igptm2 = i + EXIT + END IF + END DO ! igptm2 = pntgptm(g1(1),g1(2),g1(3),ikpt0) - IF(igptm2.eq.0) STOP 'matrixtrafo: G point not found in G-point set.' + IF (igptm2 == 0) STOP 'matrixtrafo: G point not found in G-point set.' - cdum = exp(img * tpi_const * dot_product(kpts%bk(:,ikpt1)+hybrid%gptm(:,igptp),sym%tau(:,iisym))) + cdum = exp(img*tpi_const*dot_product(kpts%bk(:, ikpt1) + hybrid%gptm(:, igptp), sym%tau(:, iisym))) - matout1(:,nbasp+igptm) = cdum * matin1(:,nbasp+igptm2) + matout1(:, nbasp + igptm) = cdum*matin1(:, nbasp + igptm2) END DO - ! Left-multiplication ! MT matin1 = matout1 - cexp = conjg(cexp) - iatom = 0 + cexp = conjg(cexp) + iatom = 0 iiatom = 0 - DO itype = 1,atoms%ntype - DO ieq = 1,atoms%neq(itype) - iatom = iatom + 1 - cdum = cexp * exp(img*tpi_const*dot_product(g,atoms%taual(:,iatom))) - - iatom1 = hybrid%map(iatom,sym%invtab(iisym)) + DO itype = 1, atoms%ntype + DO ieq = 1, atoms%neq(itype) + iatom = iatom + 1 + cdum = cexp*exp(img*tpi_const*dot_product(g, atoms%taual(:, iatom))) + + iatom1 = hybrid%map(iatom, sym%invtab(iisym)) - DO l = 0,lcutm(itype) - nn = nindxm(l,itype) - DO n = 1,nn + DO l = 0, lcutm(itype) + nn = nindxm(l, itype) + DO n = 1, nn - i1 = pnt(n,l,iatom) - i2 = i1 + nn * 2*l - j1 = pnt(n,l,iatom1) - j2 = j1 + nn * 2*l + i1 = pnt(n, l, iatom) + i2 = i1 + nn*2*l + j1 = pnt(n, l, iatom1) + j2 = j1 + nn*2*l - matout1(i1:i2:nn,:) = cdum * matmat(dwgninv(-l:l,-l:l,l),matin1(j1:j2:nn,:)) + matout1(i1:i2:nn, :) = cdum*matmat(dwgninv(-l:l, -l:l, l), matin1(j1:j2:nn, :)) + END DO END DO - END DO - END DO - iiatom = iiatom + atoms%neq(itype) + END DO + iiatom = iiatom + atoms%neq(itype) END DO - ! PW - DO igptm = 1,hybrid%ngptm(ikpt1) - igptp = hybrid%pgptm(igptm,ikpt1) - g1 = matmul(invrrot,hybrid%gptm(:,igptp)-g) - igptm2 = 0 - DO i=1,hybrid%ngptm(ikpt0) - IF ( maxval( abs(g1-hybrid%gptm(:,hybrid%pgptm(i,ikpt0) )) ).le. 1E-06 ) THEN - igptm2 = i - EXIT - END IF - END DO + DO igptm = 1, hybrid%ngptm(ikpt1) + igptp = hybrid%pgptm(igptm, ikpt1) + g1 = matmul(invrrot, hybrid%gptm(:, igptp) - g) + igptm2 = 0 + DO i = 1, hybrid%ngptm(ikpt0) + IF (maxval(abs(g1 - hybrid%gptm(:, hybrid%pgptm(i, ikpt0)))) <= 1E-06) THEN + igptm2 = i + EXIT + END IF + END DO ! igptm2 = pntgptm(g1(1),g1(2),g1(3),ikpt0) - IF(igptm2.eq.0) STOP 'matrixtrafo: G point not found in G-point set.' - iarr(igptm) = igptm2 - carr(igptm) = exp(-img * tpi_const * & - & dot_product(kpts%bk(:,ikpt1)+hybrid%gptm(:,igptp),sym%tau(:,iisym))) + IF (igptm2 == 0) STOP 'matrixtrafo: G point not found in G-point set.' + iarr(igptm) = igptm2 + carr(igptm) = exp(-img*tpi_const* & + & dot_product(kpts%bk(:, ikpt1) + hybrid%gptm(:, igptp), sym%tau(:, iisym))) ! cdum = exp(-img * 2*pi * dot_product(bk(:,ikpt1)+gptm(:,igptp),tau(:,isym))) ! matout1(nbasp+igptm,:) = cdum * matin1(nbasp+igptm2,:) END DO - DO i2 = 1,nbasm(ikpt1) - DO i1 = 1,hybrid%ngptm(ikpt1) - matout1(nbasp+i1,i2) = carr(i1) * matin1(nbasp+iarr(i1),i2) - END DO + DO i2 = 1, nbasm(ikpt1) + DO i1 = 1, hybrid%ngptm(ikpt1) + matout1(nbasp + i1, i2) = carr(i1)*matin1(nbasp + iarr(i1), i2) + END DO END DO ! If inversion symmetry is applicable, symmetrize to make the values real. # ifdef CPP_INVERSION - IF(lsymmetrize) THEN - CALL symmetrize(matout1,nbasm(ikpt0),nbasm(ikpt0),3,.false.,& - atoms,lcutm,maxlcutm, nindxm,sym) + IF (lsymmetrize) THEN + CALL symmetrize(matout1, nbasm(ikpt0), nbasm(ikpt0), 3, .false., & + atoms, lcutm, maxlcutm, nindxm, sym) END IF # endif matout = matout1 - END SUBROUTINE matrixtrafo - - - SUBROUTINE matrixtrafo1(& - matout,matin,ikpt0,isym,lsymmetrize,atoms, kpts,sym,& - hybrid,cell,maxindxm,nindxm, nbasm,ngptmall,nbasp,lcutm, maxlcutm) + END SUBROUTINE matrixtrafo + SUBROUTINE matrixtrafo1( & + matout, matin, ikpt0, isym, lsymmetrize, atoms, kpts, sym, & + hybrid, cell, maxindxm, nindxm, nbasm, ngptmall, nbasp, lcutm, maxlcutm) USE m_wrapper USE m_dwigner - USE m_util ,ONLY: modulo1 - USE m_constants - USE m_types + USE m_util, ONLY: modulo1 + USE m_constants + USE m_types IMPLICIT NONE - TYPE(t_hybrid),INTENT(IN) :: hybrid - TYPE(t_sym),INTENT(IN) :: sym - TYPE(t_cell),INTENT(IN) :: cell - TYPE(t_kpts),INTENT(IN) :: kpts - TYPE(t_atoms),INTENT(IN) :: atoms - - ! - scalars - - INTEGER , INTENT(IN) :: ikpt0,isym - INTEGER , INTENT(IN) :: nbasp - INTEGER , INTENT(IN) :: maxlcutm,maxindxm - LOGICAL , INTENT(IN) :: lsymmetrize + TYPE(t_hybrid), INTENT(IN) :: hybrid + TYPE(t_sym), INTENT(IN) :: sym + TYPE(t_cell), INTENT(IN) :: cell + TYPE(t_kpts), INTENT(IN) :: kpts + TYPE(t_atoms), INTENT(IN) :: atoms + ! - scalars - + INTEGER, INTENT(IN) :: ikpt0, isym + INTEGER, INTENT(IN) :: nbasp + INTEGER, INTENT(IN) :: maxlcutm, maxindxm + LOGICAL, INTENT(IN) :: lsymmetrize ! - arrays - - INTEGER , INTENT(IN) :: nbasm(kpts%nkpt) - INTEGER , INTENT(IN) :: nindxm(0:maxlcutm,atoms%ntype) - INTEGER , INTENT(IN) :: ngptmall - INTEGER , INTENT(IN) :: lcutm(atoms%ntype) - + INTEGER, INTENT(IN) :: nbasm(kpts%nkpt) + INTEGER, INTENT(IN) :: nindxm(0:maxlcutm, atoms%ntype) + INTEGER, INTENT(IN) :: ngptmall + INTEGER, INTENT(IN) :: lcutm(atoms%ntype) - COMPLEX , INTENT(IN) :: matin(nbasm(ikpt0),nbasm(ikpt0)) - COMPLEX , INTENT(OUT) :: matout(nbasm(ikpt0),nbasm(ikpt0)) + COMPLEX, INTENT(IN) :: matin(nbasm(ikpt0), nbasm(ikpt0)) + COMPLEX, INTENT(OUT) :: matout(nbasm(ikpt0), nbasm(ikpt0)) ! - local scalars - - INTEGER :: iatom,iatom1,iiatom,itype,ieq,ieq1,ic,l,& - & n,i,nn,i1,i2,j1,j2 - INTEGER :: igptm,igptm1,igptm2,igptp,igptp1,ikpt1,& - & isymi,iisym - INTEGER :: m1,m2 + INTEGER :: iatom, iatom1, iiatom, itype, ieq, ieq1, ic, l,& + & n, i, nn, i1, i2, j1, j2 + INTEGER :: igptm, igptm1, igptm2, igptp, igptp1, ikpt1,& + & isymi, iisym + INTEGER :: m1, m2 - COMPLEX :: cexp,cdum - COMPLEX , PARAMETER :: img=(0.0,1.0) + COMPLEX :: cexp, cdum + COMPLEX, PARAMETER :: img = (0.0, 1.0) - ! - local arrays - - INTEGER :: pnt(maxindxm,0:maxlcutm,atoms%nat),g(3),& - & g1(3),iarr(hybrid%ngptm(ikpt0)) - INTEGER :: rrot(3,3) + ! - local arrays - + INTEGER :: pnt(maxindxm, 0:maxlcutm, atoms%nat), g(3),& + & g1(3), iarr(hybrid%ngptm(ikpt0)) + INTEGER :: rrot(3, 3) - REAL :: rkpt(3),rkpthlp(3),rtaual(3) + REAL :: rkpt(3), rkpthlp(3), rtaual(3) REAL :: trans(3) - COMPLEX :: matin1(nbasm(ikpt0),nbasm(ikpt0)) - COMPLEX :: matout1(nbasm(ikpt0),nbasm(ikpt0)) - COMPLEX :: dwgn (-maxlcutm:maxlcutm,& + COMPLEX :: matin1(nbasm(ikpt0), nbasm(ikpt0)) + COMPLEX :: matout1(nbasm(ikpt0), nbasm(ikpt0)) + COMPLEX :: dwgn(-maxlcutm:maxlcutm,& & -maxlcutm:maxlcutm,& & 0:maxlcutm) COMPLEX :: dwgninv(-maxlcutm:maxlcutm,& @@ -1118,572 +1088,553 @@ & 0:maxlcutm) COMPLEX :: carr(hybrid%ngptm(ikpt0)) + IF (maxlcutm > atoms%lmaxd) STOP 'matrixtrafo1: maxlcutm .gt. atoms%lmaxd' - IF( maxlcutm .gt. atoms%lmaxd )STOP 'matrixtrafo1: maxlcutm .gt. atoms%lmaxd' - - ! Transform back to unsymmetrized product basis in case of inversion symmetry. matin1 = matin - IF(lsymmetrize) THEN - CALL desymmetrize(matin1,nbasm(ikpt0),nbasm(ikpt0),3,& - atoms,lcutm,maxlcutm,nindxm,sym) + IF (lsymmetrize) THEN + CALL desymmetrize(matin1, nbasm(ikpt0), nbasm(ikpt0), 3, & + atoms, lcutm, maxlcutm, nindxm, sym) END IF - IF( isym .le. sym%nop ) THEN - iisym = isym - rrot = transpose( sym%mrot(:,:,sym%invtab(iisym)) ) + IF (isym <= sym%nop) THEN + iisym = isym + rrot = transpose(sym%mrot(:, :, sym%invtab(iisym))) ELSE - iisym = isym - sym%nop - rrot = -transpose( sym%mrot(:,:,sym%invtab(iisym)) ) + iisym = isym - sym%nop + rrot = -transpose(sym%mrot(:, :, sym%invtab(iisym))) END IF - DO l = 0,maxlcutm - dwgn(-maxlcutm:maxlcutm,-maxlcutm:maxlcutm,l) =& - transpose(hybrid%d_wgn2(-maxlcutm:maxlcutm,-maxlcutm:maxlcutm,l,isym)) + DO l = 0, maxlcutm + dwgn(-maxlcutm:maxlcutm, -maxlcutm:maxlcutm, l) = & + transpose(hybrid%d_wgn2(-maxlcutm:maxlcutm, -maxlcutm:maxlcutm, l, isym)) END DO - rkpt = matmul(rrot,kpts%bk(:,ikpt0)) - rkpthlp = modulo1(rkpt,kpts%nkpt3) - g = nint(rkpt - rkpthlp) + rkpt = matmul(rrot, kpts%bk(:, ikpt0)) + rkpthlp = modulo1(rkpt, kpts%nkpt3) + g = nint(rkpt - rkpthlp) ! determine number of rotated k-point bk(:,ikpt) -> ikpt1 - DO i=1,kpts%nkpt - IF ( maxval( abs(rkpthlp - kpts%bk(:,i)) ) .le. 1E-06 ) THEN - ikpt1 = i - EXIT - END IF + DO i = 1, kpts%nkpt + IF (maxval(abs(rkpthlp - kpts%bk(:, i))) <= 1E-06) THEN + ikpt1 = i + EXIT + END IF END DO ! Define pointer to first mixed-basis functions (with m = -l) - i = 0 - ic = 0 - DO itype = 1,atoms%ntype - DO ieq = 1,atoms%neq(itype) - ic = ic + 1 - DO l = 0,lcutm(itype) - DO n = 1,nindxm(l,itype) - i = i + 1 - pnt(n,l,ic) = i + i = 0 + ic = 0 + DO itype = 1, atoms%ntype + DO ieq = 1, atoms%neq(itype) + ic = ic + 1 + DO l = 0, lcutm(itype) + DO n = 1, nindxm(l, itype) + i = i + 1 + pnt(n, l, ic) = i + END DO + i = i + nindxm(l, itype)*2*l END DO - i = i + nindxm(l,itype) * 2*l - END DO - END DO + END DO END DO - ! Right-multiplication ! MT - cexp = exp(-img*tpi_const*dot_product(kpts%bk(:,ikpt1)+g,sym%tau(:,iisym))) - iatom = 0 + cexp = exp(-img*tpi_const*dot_product(kpts%bk(:, ikpt1) + g, sym%tau(:, iisym))) + iatom = 0 iiatom = 0 - DO itype = 1,atoms%ntype - DO ieq = 1,atoms%neq(itype) - iatom = iatom + 1 - - iatom1 = hybrid%map(iatom,iisym) - cdum = cexp * exp(img *tpi_const*dot_product(g,atoms%taual(:,iatom1))) + DO itype = 1, atoms%ntype + DO ieq = 1, atoms%neq(itype) + iatom = iatom + 1 + iatom1 = hybrid%map(iatom, iisym) + cdum = cexp*exp(img*tpi_const*dot_product(g, atoms%taual(:, iatom1))) - DO l = 0,lcutm(itype) - nn = nindxm(l,itype) - DO n = 1,nn + DO l = 0, lcutm(itype) + nn = nindxm(l, itype) + DO n = 1, nn - i1 = pnt(n,l,iatom) - i2 = i1 + nn * 2*l - j1 = pnt(n,l,iatom1) - j2 = j1 + nn * 2*l + i1 = pnt(n, l, iatom) + i2 = i1 + nn*2*l + j1 = pnt(n, l, iatom1) + j2 = j1 + nn*2*l - matout1(:,i1:i2:nn) = cdum * matmat( matin1(:,j1:j2:nn) , dwgn(-l:l,-l:l,l)) + matout1(:, i1:i2:nn) = cdum*matmat(matin1(:, j1:j2:nn), dwgn(-l:l, -l:l, l)) + END DO END DO - END DO - END DO - iiatom = iiatom + atoms%neq(itype) + END DO + iiatom = iiatom + atoms%neq(itype) END DO ! PW - DO igptm = 1,hybrid%ngptm(ikpt0) - igptp = hybrid%pgptm(igptm,ikpt0) - g1 = matmul(rrot,hybrid%gptm(:,igptp)) + g - igptm1 = 0 - DO i=1,hybrid%ngptm(ikpt1) - IF( maxval( abs(g1-hybrid%gptm(:,hybrid%pgptm(i,ikpt1) )) ) <= 1E-06 ) THEN - igptm1 = i - igptp1 = hybrid%pgptm(i,ikpt1) - EXIT - END IF - END DO - IF(igptm1.eq.0) STOP 'matrixtrafo1: G point not found in G-point set.' - - cdum = exp(-img * tpi_const * dot_product(kpts%bk(:,ikpt1)+hybrid%gptm(:,igptp1),sym%tau(:,iisym))) - - matout1(:,nbasp+igptm) = cdum * matin1(:,nbasp+igptm1) + DO igptm = 1, hybrid%ngptm(ikpt0) + igptp = hybrid%pgptm(igptm, ikpt0) + g1 = matmul(rrot, hybrid%gptm(:, igptp)) + g + igptm1 = 0 + DO i = 1, hybrid%ngptm(ikpt1) + IF (maxval(abs(g1 - hybrid%gptm(:, hybrid%pgptm(i, ikpt1)))) <= 1E-06) THEN + igptm1 = i + igptp1 = hybrid%pgptm(i, ikpt1) + EXIT + END IF + END DO + IF (igptm1 == 0) STOP 'matrixtrafo1: G point not found in G-point set.' - END DO + cdum = exp(-img*tpi_const*dot_product(kpts%bk(:, ikpt1) + hybrid%gptm(:, igptp1), sym%tau(:, iisym))) + matout1(:, nbasp + igptm) = cdum*matin1(:, nbasp + igptm1) + END DO ! Left-multiplication ! MT - DO l = 0,maxlcutm - dwgninv(-l:l,-l:l,l) = conjg(transpose(dwgn(-l:l,-l:l,l))) + DO l = 0, maxlcutm + dwgninv(-l:l, -l:l, l) = conjg(transpose(dwgn(-l:l, -l:l, l))) END DO matin1 = matout1 - cexp = conjg(cexp) + cexp = conjg(cexp) - iatom = 0 + iatom = 0 iiatom = 0 - DO itype = 1,atoms%ntype - DO ieq = 1,atoms%neq(itype) - iatom = iatom + 1 - + DO itype = 1, atoms%ntype + DO ieq = 1, atoms%neq(itype) + iatom = iatom + 1 - iatom1 = hybrid%map(iatom,iisym) - cdum = cexp*exp(-img*tpi_const*dot_product(g,atoms%taual(:,iatom1))) + iatom1 = hybrid%map(iatom, iisym) + cdum = cexp*exp(-img*tpi_const*dot_product(g, atoms%taual(:, iatom1))) - DO l = 0,lcutm(itype) - nn = nindxm(l,itype) - DO n = 1,nn + DO l = 0, lcutm(itype) + nn = nindxm(l, itype) + DO n = 1, nn - i1 = pnt(n,l,iatom) - i2 = i1 + nn * 2*l - j1 = pnt(n,l,iatom1) - j2 = j1 + nn * 2*l + i1 = pnt(n, l, iatom) + i2 = i1 + nn*2*l + j1 = pnt(n, l, iatom1) + j2 = j1 + nn*2*l - matout1(i1:i2:nn,:) = cdum * matmat(dwgninv(-l:l,-l:l,l), matin1(j1:j2:nn,:)) + matout1(i1:i2:nn, :) = cdum*matmat(dwgninv(-l:l, -l:l, l), matin1(j1:j2:nn, :)) + END DO END DO - END DO - END DO - iiatom = iiatom + atoms%neq(itype) + END DO + iiatom = iiatom + atoms%neq(itype) END DO - ! PW - DO igptm = 1,hybrid%ngptm(ikpt0) - igptp = hybrid%pgptm(igptm,ikpt0) - g1 = matmul(rrot,hybrid%gptm(:,igptp)) + g - igptm1 = 0 - DO i=1,hybrid%ngptm(ikpt1) - IF( maxval( abs(g1-hybrid%gptm(:,hybrid%pgptm(i,ikpt1) )) ) <= 1E-06 ) THEN - igptm1 = i - igptp1 = hybrid%pgptm(i,ikpt1) - EXIT - END IF - END DO - IF(igptm1.eq.0) STOP 'matrixtrafo1: G point not found in G-point set.' - iarr(igptm) = igptm1 - carr(igptm) = exp(img * tpi_const * dot_product(kpts%bk(:,ikpt1)+hybrid%gptm(:,igptp1),sym%tau(:,iisym))) - END DO - DO i2 = 1,nbasm(ikpt0) - DO i1 = 1,hybrid%ngptm(ikpt0) - matout1(nbasp+i1,i2) = carr(i1) * matin1(nbasp+iarr(i1),i2) - END DO + DO igptm = 1, hybrid%ngptm(ikpt0) + igptp = hybrid%pgptm(igptm, ikpt0) + g1 = matmul(rrot, hybrid%gptm(:, igptp)) + g + igptm1 = 0 + DO i = 1, hybrid%ngptm(ikpt1) + IF (maxval(abs(g1 - hybrid%gptm(:, hybrid%pgptm(i, ikpt1)))) <= 1E-06) THEN + igptm1 = i + igptp1 = hybrid%pgptm(i, ikpt1) + EXIT + END IF + END DO + IF (igptm1 == 0) STOP 'matrixtrafo1: G point not found in G-point set.' + iarr(igptm) = igptm1 + carr(igptm) = exp(img*tpi_const*dot_product(kpts%bk(:, ikpt1) + hybrid%gptm(:, igptp1), sym%tau(:, iisym))) + END DO + DO i2 = 1, nbasm(ikpt0) + DO i1 = 1, hybrid%ngptm(ikpt0) + matout1(nbasp + i1, i2) = carr(i1)*matin1(nbasp + iarr(i1), i2) + END DO END DO - ! If inversion symmetry is applicable, symmetrize to make the values real. - IF(lsymmetrize) THEN - CALL symmetrize(matout1,nbasm(ikpt0),nbasm(ikpt0),3,.false.,& - atoms,lcutm,maxlcutm, nindxm,sym) + IF (lsymmetrize) THEN + CALL symmetrize(matout1, nbasm(ikpt0), nbasm(ikpt0), 3, .false., & + atoms, lcutm, maxlcutm, nindxm, sym) END IF - IF( isym .le. sym%nop ) THEN - matout = matout1 + IF (isym <= sym%nop) THEN + matout = matout1 ELSE - matout = conjg(matout1) + matout = conjg(matout1) END IF - END SUBROUTINE matrixtrafo1 - + END SUBROUTINE matrixtrafo1 - SUBROUTINE ket_trafo(& - & vecout,vecin,ikpt0,isym,lreal,lsymmetrize,& - & atoms,kpts,sym,& - & hybrid,cell,maxindxm,nindxm,nbasm,& - & ngptmall,nbasp,lcutm,maxlcutm) + SUBROUTINE ket_trafo(& + & vecout, vecin, ikpt0, isym, lreal, lsymmetrize,& + & atoms, kpts, sym,& + & hybrid, cell, maxindxm, nindxm, nbasm,& + & ngptmall, nbasp, lcutm, maxlcutm) - USE m_constants - USE m_util ,ONLY: modulo1 + USE m_constants + USE m_util, ONLY: modulo1 USE m_dwigner - USE m_types + USE m_types IMPLICIT NONE - TYPE(t_hybrid),INTENT(IN) :: hybrid - TYPE(t_sym),INTENT(IN) :: sym - TYPE(t_cell),INTENT(IN) :: cell - TYPE(t_kpts),INTENT(IN) :: kpts - TYPE(t_atoms),INTENT(IN) :: atoms + TYPE(t_hybrid), INTENT(IN) :: hybrid + TYPE(t_sym), INTENT(IN) :: sym + TYPE(t_cell), INTENT(IN) :: cell + TYPE(t_kpts), INTENT(IN) :: kpts + TYPE(t_atoms), INTENT(IN) :: atoms ! -scalars - - INTEGER , INTENT(IN) :: ikpt0,isym - INTEGER , INTENT(IN) :: nbasp - INTEGER , INTENT(IN) :: maxlcutm,maxindxm - LOGICAL , INTENT(IN) :: lreal,lsymmetrize + INTEGER, INTENT(IN) :: ikpt0, isym + INTEGER, INTENT(IN) :: nbasp + INTEGER, INTENT(IN) :: maxlcutm, maxindxm + LOGICAL, INTENT(IN) :: lreal, lsymmetrize ! - arrays - - INTEGER , INTENT(IN) :: nbasm(kpts%nkpt) - INTEGER , INTENT(IN) :: nindxm(0:maxlcutm,atoms%ntype) - INTEGER , INTENT(IN) :: ngptmall - INTEGER , INTENT(IN) :: lcutm(atoms%ntype) + INTEGER, INTENT(IN) :: nbasm(kpts%nkpt) + INTEGER, INTENT(IN) :: nindxm(0:maxlcutm, atoms%ntype) + INTEGER, INTENT(IN) :: ngptmall + INTEGER, INTENT(IN) :: lcutm(atoms%ntype) - - COMPLEX , INTENT(IN) :: vecin(nbasm(ikpt0)) - COMPLEX , INTENT(OUT) :: vecout(nbasm(ikpt0)) + COMPLEX, INTENT(IN) :: vecin(nbasm(ikpt0)) + COMPLEX, INTENT(OUT) :: vecout(nbasm(ikpt0)) ! -local scalars - - INTEGER :: iatom,iatom1,iiatom,itype,ieq,ieq1,ic,l,& - & n,i,nn,i1,i2,j1,j2 - INTEGER :: igptm,igptm1,igptm2,igptp,igptp1,ikpt1,& - & isymi,iisym - INTEGER :: m1,m2 + INTEGER :: iatom, iatom1, iiatom, itype, ieq, ieq1, ic, l,& + & n, i, nn, i1, i2, j1, j2 + INTEGER :: igptm, igptm1, igptm2, igptp, igptp1, ikpt1,& + & isymi, iisym + INTEGER :: m1, m2 - COMPLEX :: cexp,cdum - COMPLEX , PARAMETER :: img=(0.0,1.0) + COMPLEX :: cexp, cdum + COMPLEX, PARAMETER :: img = (0.0, 1.0) ! - local arrays - - INTEGER :: pnt(maxindxm,0:maxlcutm,atoms%nat),g(3),g1(3) - INTEGER :: rot(3,3),invrot(3,3),& - & rrot(3,3),invrrot(3,3) + INTEGER :: pnt(maxindxm, 0:maxlcutm, atoms%nat), g(3), g1(3) + INTEGER :: rot(3, 3), invrot(3, 3),& + & rrot(3, 3), invrrot(3, 3) - REAL :: rkpt(3),rkpthlp(3),rtaual(3) + REAL :: rkpt(3), rkpthlp(3), rtaual(3) - COMPLEX :: vecin1 (nbasm(ikpt0)) + COMPLEX :: vecin1(nbasm(ikpt0)) COMPLEX :: vecout1(nbasm(ikpt0)) - COMPLEX :: dwgn (-maxlcutm:maxlcutm,& + COMPLEX :: dwgn(-maxlcutm:maxlcutm,& & -maxlcutm:maxlcutm,& & 0:maxlcutm) COMPLEX :: dwgninv(-maxlcutm:maxlcutm,& & -maxlcutm:maxlcutm,& & 0:maxlcutm) - - ! Transform back to unsymmetrized product basis in case of inversion symmetry. vecin1 = vecin!(:nbasp) - IF(lsymmetrize) THEN - CALL desymmetrize(vecin1(:nbasp),1,nbasp,2,& - atoms,lcutm,maxlcutm, nindxm,sym) + IF (lsymmetrize) THEN + CALL desymmetrize(vecin1(:nbasp), 1, nbasp, 2, & + atoms, lcutm, maxlcutm, nindxm, sym) END IF - IF( isym .le. sym%nop ) THEN - iisym = isym - rot = sym%mrot(:,:,iisym) - invrot = sym%mrot(:,:,sym%invtab(iisym)) - rrot = transpose( sym%mrot(:,:,sym%invtab(iisym)) ) - invrrot = transpose( sym%mrot(:,:,iisym) ) - rkpt = matmul(rrot,kpts%bk(:,ikpt0)) - rkpthlp = modulo1(rkpt,kpts%nkpt3) - g = nint(rkpt - rkpthlp) - - CALL d_wigner(invrot,cell%bmat,maxlcutm,dwgn(:,:,1:maxlcutm)) - dwgn(0,0,0) = 1 - - DO l=0,maxlcutm - dwgn(:,:,l) = transpose(dwgn(:,:,l)) - END DO + IF (isym <= sym%nop) THEN + iisym = isym + rot = sym%mrot(:, :, iisym) + invrot = sym%mrot(:, :, sym%invtab(iisym)) + rrot = transpose(sym%mrot(:, :, sym%invtab(iisym))) + invrrot = transpose(sym%mrot(:, :, iisym)) + rkpt = matmul(rrot, kpts%bk(:, ikpt0)) + rkpthlp = modulo1(rkpt, kpts%nkpt3) + g = nint(rkpt - rkpthlp) + + CALL d_wigner(invrot, cell%bmat, maxlcutm, dwgn(:, :, 1:maxlcutm)) + dwgn(0, 0, 0) = 1 + + DO l = 0, maxlcutm + dwgn(:, :, l) = transpose(dwgn(:, :, l)) + END DO ELSE - iisym = isym - sym%nop - rot = sym%mrot(:,:,iisym) - rrot = -transpose( sym%mrot(:,:,sym%invtab(iisym)) ) - invrot = sym%mrot(:,:,sym%invtab(iisym)) - invrrot = -transpose( sym%mrot(:,:,iisym) ) - rkpt = matmul(rrot,kpts%bk(:,ikpt0)) - rkpthlp = modulo1(rkpt,kpts%nkpt3) - g = nint(rkpt - rkpthlp) - vecin1 = conjg(vecin1) - - CALL d_wigner(invrot,cell%bmat,maxlcutm,dwgn(:,:,1:maxlcutm)) - dwgn(0,0,0) = 1 - - DO l=0,maxlcutm - dwgn(:,:,l) = transpose(dwgn(:,:,l)) - END DO - - DO l = 0,maxlcutm - DO m1 = -l,l - DO m2 = -l,-1 - cdum = dwgn(m1, m2,l) - dwgn(m1, m2,l) = dwgn(m1,-m2,l) * (-1)**m2 - dwgn(m1,-m2,l) = cdum * (-1)**m2 + iisym = isym - sym%nop + rot = sym%mrot(:, :, iisym) + rrot = -transpose(sym%mrot(:, :, sym%invtab(iisym))) + invrot = sym%mrot(:, :, sym%invtab(iisym)) + invrrot = -transpose(sym%mrot(:, :, iisym)) + rkpt = matmul(rrot, kpts%bk(:, ikpt0)) + rkpthlp = modulo1(rkpt, kpts%nkpt3) + g = nint(rkpt - rkpthlp) + vecin1 = conjg(vecin1) + + CALL d_wigner(invrot, cell%bmat, maxlcutm, dwgn(:, :, 1:maxlcutm)) + dwgn(0, 0, 0) = 1 + + DO l = 0, maxlcutm + dwgn(:, :, l) = transpose(dwgn(:, :, l)) + END DO + + DO l = 0, maxlcutm + DO m1 = -l, l + DO m2 = -l, -1 + cdum = dwgn(m1, m2, l) + dwgn(m1, m2, l) = dwgn(m1, -m2, l)*(-1)**m2 + dwgn(m1, -m2, l) = cdum*(-1)**m2 + END DO END DO - END DO - END DO + END DO END IF ! determine number of rotated k-point bk(:,ikpt) -> ikpt1 - ! - DO i=1,kpts%nkpt - IF ( maxval( abs(rkpthlp - kpts%bk(:,i)) ) .le. 1E-06 ) THEN - ikpt1 = i - EXIT - END IF + ! + DO i = 1, kpts%nkpt + IF (maxval(abs(rkpthlp - kpts%bk(:, i))) <= 1E-06) THEN + ikpt1 = i + EXIT + END IF END DO - - ! DO l = 0,maxlcutm ! dwgninv(-l:l,-l:l,l) = conjg(transpose(dwgn(-l:l,-l:l,l))) ! END DO ! Define pointer to first mixed-basis functions (with m = -l) - i = 0 - ic = 0 - DO itype = 1,atoms%ntype - DO ieq = 1,atoms%neq(itype) - ic = ic + 1 - DO l = 0,lcutm(itype) - DO n = 1,nindxm(l,itype) - i = i + 1 - pnt(n,l,ic) = i + i = 0 + ic = 0 + DO itype = 1, atoms%ntype + DO ieq = 1, atoms%neq(itype) + ic = ic + 1 + DO l = 0, lcutm(itype) + DO n = 1, nindxm(l, itype) + i = i + 1 + pnt(n, l, ic) = i + END DO + i = i + nindxm(l, itype)*2*l END DO - i = i + nindxm(l,itype) * 2*l - END DO - END DO + END DO END DO ! Multiplication ! MT - cexp =exp(img*tpi_const*dot_product(kpts%bk(:,ikpt1)+g,sym%tau(:,iisym))) - iatom = 0 + cexp = exp(img*tpi_const*dot_product(kpts%bk(:, ikpt1) + g, sym%tau(:, iisym))) + iatom = 0 iiatom = 0 - DO itype = 1,atoms%ntype - DO ieq = 1,atoms%neq(itype) - iatom = iatom + 1 - cdum =cexp*exp(-img*tpi_const*dot_product(g,atoms%taual(:,iatom))) - - rtaual = matmul(rot,atoms%taual(:,iatom)) + sym%tau(:,iisym) - iatom1 = 0 - DO ieq1 = 1,atoms%neq(itype) - IF( all(abs(modulo(rtaual-atoms%taual(:,iiatom+ieq1)+10.0**-12,1.0))& - & .lt. 10.0**-10) ) THEN ! The 10.0**-12 is a dirty fix. - iatom1 = iiatom + ieq1 - END IF - END DO - IF( iatom1 .eq. 0 ) STOP 'ket_trafo: rotated atom not found' + DO itype = 1, atoms%ntype + DO ieq = 1, atoms%neq(itype) + iatom = iatom + 1 + cdum = cexp*exp(-img*tpi_const*dot_product(g, atoms%taual(:, iatom))) + + rtaual = matmul(rot, atoms%taual(:, iatom)) + sym%tau(:, iisym) + iatom1 = 0 + DO ieq1 = 1, atoms%neq(itype) + IF (all(abs(modulo(rtaual - atoms%taual(:, iiatom + ieq1) + 10.0**-12, 1.0))& + & < 10.0**-10)) THEN ! The 10.0**-12 is a dirty fix. + iatom1 = iiatom + ieq1 + END IF + END DO + IF (iatom1 == 0) STOP 'ket_trafo: rotated atom not found' - DO l = 0,lcutm(itype) - nn = nindxm(l,itype) - DO n = 1,nn + DO l = 0, lcutm(itype) + nn = nindxm(l, itype) + DO n = 1, nn - i1 = pnt(n,l,iatom) - i2 = i1 + nn * 2*l - j1 = pnt(n,l,iatom1) - j2 = j1 + nn * 2*l + i1 = pnt(n, l, iatom) + i2 = i1 + nn*2*l + j1 = pnt(n, l, iatom1) + j2 = j1 + nn*2*l - vecout1(i1:i2:nn) = cdum * matmul( vecin1(j1:j2:nn),& - & dwgn(-l:l,-l:l,l) ) + vecout1(i1:i2:nn) = cdum*matmul(vecin1(j1:j2:nn),& + & dwgn(-l:l, -l:l, l)) + END DO END DO - END DO - END DO - iiatom = iiatom + atoms%neq(itype) + END DO + iiatom = iiatom + atoms%neq(itype) ENDDO ! PW - DO igptm = 1,hybrid%ngptm(ikpt1) - igptp = hybrid%pgptm(igptm,ikpt1) - g1 = matmul(invrrot,hybrid%gptm(:,igptp)-g) - igptm2 = 0 - DO i=1,hybrid%ngptm(ikpt0) - IF ( maxval( abs(g1-hybrid%gptm(:,hybrid%pgptm(i,ikpt0) )) ) <= 1E-06 ) THEN - igptm2 = i - EXIT - END IF - END DO - IF(igptm2.eq.0) & - & STOP 'ket_trafo: G point not found in G-point set.' + DO igptm = 1, hybrid%ngptm(ikpt1) + igptp = hybrid%pgptm(igptm, ikpt1) + g1 = matmul(invrrot, hybrid%gptm(:, igptp) - g) + igptm2 = 0 + DO i = 1, hybrid%ngptm(ikpt0) + IF (maxval(abs(g1 - hybrid%gptm(:, hybrid%pgptm(i, ikpt0)))) <= 1E-06) THEN + igptm2 = i + EXIT + END IF + END DO + IF (igptm2 == 0) & + & STOP 'ket_trafo: G point not found in G-point set.' - cdum = exp(img * tpi_const * & - & dot_product(kpts%bk(:,ikpt1)+hybrid%gptm(:,igptp),sym%tau(:,iisym))) + cdum = exp(img*tpi_const* & + & dot_product(kpts%bk(:, ikpt1) + hybrid%gptm(:, igptp), sym%tau(:, iisym))) - vecout1(nbasp+igptm) = cdum * vecin1(nbasp+igptm2) + vecout1(nbasp + igptm) = cdum*vecin1(nbasp + igptm2) END DO ! If inversion symmetry is applicable, define the phase of vecout and symmetrize to make the values real. - IF(lsymmetrize) CALL symmetrize(vecout1,1,nbasm(ikpt1),2,lreal,& - atoms,lcutm,maxlcutm, nindxm,sym) + IF (lsymmetrize) CALL symmetrize(vecout1, 1, nbasm(ikpt1), 2, lreal, & + atoms, lcutm, maxlcutm, nindxm, sym) vecout = vecout1 - END SUBROUTINE ket_trafo + END SUBROUTINE ket_trafo - - SUBROUTINE ket_trafo1(vecout,vecin,ikpt0,isym,lreal,lsymmetrize,& - atoms,kpts,sym, hybrid,& - cell,maxindxm,nindxm,nbasm,ngptmall,nbasp,lcutm,maxlcutm) + SUBROUTINE ket_trafo1(vecout, vecin, ikpt0, isym, lreal, lsymmetrize, & + atoms, kpts, sym, hybrid, & + cell, maxindxm, nindxm, nbasm, ngptmall, nbasp, lcutm, maxlcutm) USE m_constants - USE m_util ,ONLY: modulo1 + USE m_util, ONLY: modulo1 USE m_dwigner USE m_types IMPLICIT NONE - TYPE(t_hybrid),INTENT(IN) :: hybrid - TYPE(t_sym),INTENT(IN) :: sym - TYPE(t_cell),INTENT(IN) :: cell - TYPE(t_kpts),INTENT(IN) :: kpts - TYPE(t_atoms),INTENT(IN) :: atoms + TYPE(t_hybrid), INTENT(IN) :: hybrid + TYPE(t_sym), INTENT(IN) :: sym + TYPE(t_cell), INTENT(IN) :: cell + TYPE(t_kpts), INTENT(IN) :: kpts + TYPE(t_atoms), INTENT(IN) :: atoms ! -scalars - - INTEGER , INTENT(IN) :: ikpt0,isym - INTEGER , INTENT(IN) :: nbasp - INTEGER , INTENT(IN) :: maxlcutm,maxindxm - LOGICAL , INTENT(IN) :: lreal,lsymmetrize + INTEGER, INTENT(IN) :: ikpt0, isym + INTEGER, INTENT(IN) :: nbasp + INTEGER, INTENT(IN) :: maxlcutm, maxindxm + LOGICAL, INTENT(IN) :: lreal, lsymmetrize ! - arrays - - INTEGER , INTENT(IN) :: nbasm(kpts%nkpt) - INTEGER , INTENT(IN) :: nindxm(0:maxlcutm,atoms%ntype) - INTEGER , INTENT(IN) :: ngptmall - INTEGER , INTENT(IN) :: lcutm(atoms%ntype) + INTEGER, INTENT(IN) :: nbasm(kpts%nkpt) + INTEGER, INTENT(IN) :: nindxm(0:maxlcutm, atoms%ntype) + INTEGER, INTENT(IN) :: ngptmall + INTEGER, INTENT(IN) :: lcutm(atoms%ntype) - COMPLEX , INTENT(IN) :: vecin(nbasm(ikpt0)) - COMPLEX , INTENT(OUT) :: vecout(nbasm(ikpt0)) + COMPLEX, INTENT(IN) :: vecin(nbasm(ikpt0)) + COMPLEX, INTENT(OUT) :: vecout(nbasm(ikpt0)) ! -local scalars - - INTEGER :: iatom,iatom1,iiatom,itype,ieq,ieq1,ic,l,& - & n,i,nn,i1,i2,j1,j2 - INTEGER :: igptm,igptm1,igptm2,igptp,igptp1,ikpt1,& - & isymi,iisym - INTEGER :: m1,m2 + INTEGER :: iatom, iatom1, iiatom, itype, ieq, ieq1, ic, l,& + & n, i, nn, i1, i2, j1, j2 + INTEGER :: igptm, igptm1, igptm2, igptp, igptp1, ikpt1,& + & isymi, iisym + INTEGER :: m1, m2 - COMPLEX :: cexp,cdum - COMPLEX , PARAMETER :: img=(0.0,1.0) + COMPLEX :: cexp, cdum + COMPLEX, PARAMETER :: img = (0.0, 1.0) ! - local arrays - - INTEGER :: pnt(maxindxm,0:maxlcutm,atoms%nat),g(3),g1(3) - INTEGER :: rrot(3,3) + INTEGER :: pnt(maxindxm, 0:maxlcutm, atoms%nat), g(3), g1(3) + INTEGER :: rrot(3, 3) - REAL :: rkpt(3),rkpthlp(3),rtaual(3) + REAL :: rkpt(3), rkpthlp(3), rtaual(3) - COMPLEX :: vecin1 (nbasm(ikpt0)) + COMPLEX :: vecin1(nbasm(ikpt0)) COMPLEX :: vecout1(nbasm(ikpt0)) COMPLEX :: dwgn(-maxlcutm:maxlcutm,& & -maxlcutm:maxlcutm,& & 0:maxlcutm) + IF (maxlcutm > atoms%lmaxd) STOP 'kettrafo1: maxlcutm > atoms%lmaxd' - IF( maxlcutm .gt. atoms%lmaxd) STOP 'kettrafo1: maxlcutm > atoms%lmaxd' - - ! Transform back to unsymmetrized product basis in case of inversion symmetry. vecin1 = vecin!(:nbasp) - IF(lsymmetrize) CALL desymmetrize(vecin1(:nbasp),1,nbasp,2,& - atoms,lcutm,maxlcutm, nindxm,sym) + IF (lsymmetrize) CALL desymmetrize(vecin1(:nbasp), 1, nbasp, 2, & + atoms, lcutm, maxlcutm, nindxm, sym) - IF( isym .le. sym%nop ) THEN - iisym = isym - rrot = transpose( sym%mrot(:,:,sym%invtab(iisym)) ) + IF (isym <= sym%nop) THEN + iisym = isym + rrot = transpose(sym%mrot(:, :, sym%invtab(iisym))) ELSE - iisym = isym - sym%nop - rrot = -transpose( sym%mrot(:,:,sym%invtab(iisym)) ) + iisym = isym - sym%nop + rrot = -transpose(sym%mrot(:, :, sym%invtab(iisym))) END IF - rkpt = matmul(rrot,kpts%bk(:,ikpt0)) - rkpthlp = modulo1(rkpt,kpts%nkpt3) - g = nint(rkpt - rkpthlp) + rkpt = matmul(rrot, kpts%bk(:, ikpt0)) + rkpthlp = modulo1(rkpt, kpts%nkpt3) + g = nint(rkpt - rkpthlp) - DO l = 0,maxlcutm - dwgn(-maxlcutm:maxlcutm,-maxlcutm:maxlcutm,l) =& - transpose(hybrid%d_wgn2(-maxlcutm:maxlcutm,-maxlcutm:maxlcutm,l,isym)) + DO l = 0, maxlcutm + dwgn(-maxlcutm:maxlcutm, -maxlcutm:maxlcutm, l) = & + transpose(hybrid%d_wgn2(-maxlcutm:maxlcutm, -maxlcutm:maxlcutm, l, isym)) END DO - ! ! determine number of rotated k-point bk(:,ikpt) -> ikpt1 ! - DO i=1,kpts%nkpt - IF ( maxval( abs(rkpthlp - kpts%bk(:,i)) ) .le. 1E-06 ) THEN - ikpt1 = i - EXIT - END IF + DO i = 1, kpts%nkpt + IF (maxval(abs(rkpthlp - kpts%bk(:, i))) <= 1E-06) THEN + ikpt1 = i + EXIT + END IF END DO ! Define pointer to first mixed-basis functions (with m = -l) - i = 0 - ic = 0 - DO itype = 1,atoms%ntype - DO ieq = 1,atoms%neq(itype) - ic = ic + 1 - DO l = 0,lcutm(itype) - DO n = 1,nindxm(l,itype) - i = i + 1 - pnt(n,l,ic) = i + i = 0 + ic = 0 + DO itype = 1, atoms%ntype + DO ieq = 1, atoms%neq(itype) + ic = ic + 1 + DO l = 0, lcutm(itype) + DO n = 1, nindxm(l, itype) + i = i + 1 + pnt(n, l, ic) = i + END DO + i = i + nindxm(l, itype)*2*l END DO - i = i + nindxm(l,itype) * 2*l - END DO - END DO + END DO END DO ! Multiplication ! MT - cexp =exp(-img*tpi_const*dot_product(kpts%bk(:,ikpt1)+g,sym%tau(:,iisym))) - iatom = 0 + cexp = exp(-img*tpi_const*dot_product(kpts%bk(:, ikpt1) + g, sym%tau(:, iisym))) + iatom = 0 iiatom = 0 - DO itype = 1,atoms%ntype - DO ieq = 1,atoms%neq(itype) - iatom = iatom + 1 + DO itype = 1, atoms%ntype + DO ieq = 1, atoms%neq(itype) + iatom = iatom + 1 - iatom1 = hybrid%map(iatom,iisym) - cdum =cexp*exp(img*tpi_const*dot_product(g,atoms%taual(:,iatom1))) + iatom1 = hybrid%map(iatom, iisym) + cdum = cexp*exp(img*tpi_const*dot_product(g, atoms%taual(:, iatom1))) - DO l = 0,lcutm(itype) - nn = nindxm(l,itype) - DO n = 1,nn + DO l = 0, lcutm(itype) + nn = nindxm(l, itype) + DO n = 1, nn - i1 = pnt(n,l,iatom) - i2 = i1 + nn * 2*l - j1 = pnt(n,l,iatom1) - j2 = j1 + nn * 2*l + i1 = pnt(n, l, iatom) + i2 = i1 + nn*2*l + j1 = pnt(n, l, iatom1) + j2 = j1 + nn*2*l - vecout1(i1:i2:nn) = cdum * matmul(vecin1(j1:j2:nn), dwgn(-l:l,-l:l,l)) + vecout1(i1:i2:nn) = cdum*matmul(vecin1(j1:j2:nn), dwgn(-l:l, -l:l, l)) + END DO END DO - END DO - END DO - iiatom = iiatom + atoms%neq(itype) + END DO + iiatom = iiatom + atoms%neq(itype) ENDDO ! PW - DO igptm = 1,hybrid%ngptm(ikpt0) - igptp = hybrid%pgptm(igptm,ikpt0) - g1 = matmul(rrot,hybrid%gptm(:,igptp)) +g - igptm1 = 0 - DO i=1,hybrid%ngptm(ikpt1) - IF (maxval( abs(g1-hybrid%gptm(:,hybrid%pgptm(i,ikpt1) )) ) <= 1E-06 ) THEN - igptm1 = i - igptp1 = hybrid%pgptm(i,ikpt1) - EXIT - END IF - END DO - IF(igptm1.eq.0) STOP 'ket_trafo: G point not found in G-point set.' + DO igptm = 1, hybrid%ngptm(ikpt0) + igptp = hybrid%pgptm(igptm, ikpt0) + g1 = matmul(rrot, hybrid%gptm(:, igptp)) + g + igptm1 = 0 + DO i = 1, hybrid%ngptm(ikpt1) + IF (maxval(abs(g1 - hybrid%gptm(:, hybrid%pgptm(i, ikpt1)))) <= 1E-06) THEN + igptm1 = i + igptp1 = hybrid%pgptm(i, ikpt1) + EXIT + END IF + END DO + IF (igptm1 == 0) STOP 'ket_trafo: G point not found in G-point set.' - cdum = exp(-img * tpi_const * dot_product(kpts%bk(:,ikpt1)+hybrid%gptm(:,igptp1),sym%tau(:,iisym))) + cdum = exp(-img*tpi_const*dot_product(kpts%bk(:, ikpt1) + hybrid%gptm(:, igptp1), sym%tau(:, iisym))) - vecout1(nbasp+igptm) = cdum * vecin1(nbasp+igptm1) + vecout1(nbasp + igptm) = cdum*vecin1(nbasp + igptm1) - END DO + END DO ! If inversion symmetry is applicable, define the phase of vecout and symmetrize to make the values real. - IF(lsymmetrize) CALL symmetrize(vecout1,1,nbasm(ikpt1),2,lreal,& - atoms,lcutm,maxlcutm, nindxm,sym) - IF( isym .le. sym%nop ) THEN - vecout = vecout1 + IF (lsymmetrize) CALL symmetrize(vecout1, 1, nbasm(ikpt1), 2, lreal, & + atoms, lcutm, maxlcutm, nindxm, sym) + IF (isym <= sym%nop) THEN + vecout = vecout1 ELSE - vecout = conjg(vecout1) + vecout = conjg(vecout1) END IF - END SUBROUTINE ket_trafo1 + END SUBROUTINE ket_trafo1 - ! Determines common phase factor (with unit norm) - SUBROUTINE commonphase(cfac,carr,n) + ! Determines common phase factor (with unit norm) + SUBROUTINE commonphase(cfac, carr, n) IMPLICIT NONE - INTEGER,INTENT(IN) :: n - COMPLEX,INTENT(IN) :: carr(n) - COMPLEX,INTENT(OUT) :: cfac - REAL :: rdum,rmax + INTEGER, INTENT(IN) :: n + COMPLEX, INTENT(IN) :: carr(n) + COMPLEX, INTENT(OUT) :: cfac + REAL :: rdum, rmax INTEGER :: i ! IF( all( abs(carr) .lt. 1E-12 ) ) THEN @@ -1693,174 +1644,173 @@ cfac = 0 rmax = 0 - DO i = 1,n - rdum = abs(carr(i)) - IF (rdum.gt.10.0**-6) THEN ; cfac = carr(i) / rdum ; EXIT - ELSE IF(rdum.gt.rmax) THEN ; cfac = carr(i) / rdum ; rmax = rdum - END IF + DO i = 1, n + rdum = abs(carr(i)) + IF (rdum > 10.0**-6) THEN; cfac = carr(i)/rdum; EXIT + ELSE IF (rdum > rmax) THEN; cfac = carr(i)/rdum; rmax = rdum + END IF END DO - IF(cfac .eq. 0 .and. all(carr .ne. 0) ) THEN - WRITE(999,*) carr - STOP 'commonphase: Could not determine common phase factor. (Wrote carr to fort.999)' + IF (cfac == 0 .and. all(carr /= 0)) THEN + WRITE (999, *) carr + STOP 'commonphase: Could not determine common phase factor. (Wrote carr to fort.999)' END IF - END SUBROUTINE commonphase + END SUBROUTINE commonphase - SUBROUTINE bramat_trafo(& - vecout,igptm_out, vecin,igptm_in,ikpt0,iop,writevec,pointer,sym,& - rrot,invrrot,hybrid,kpts,maxlcutm,atoms,lcutm,nindxm,maxindxm, dwgn,nbasp,nbasm) + SUBROUTINE bramat_trafo( & + vecout, igptm_out, vecin, igptm_in, ikpt0, iop, writevec, pointer, sym, & + rrot, invrrot, hybrid, kpts, maxlcutm, atoms, lcutm, nindxm, maxindxm, dwgn, nbasp, nbasm) - USE m_constants + USE m_constants USE m_util USE m_types IMPLICIT NONE - TYPE(t_hybrid),INTENT(IN) :: hybrid - TYPE(t_sym),INTENT(IN) :: sym - TYPE(t_kpts),INTENT(IN) :: kpts - TYPE(t_atoms),INTENT(IN) :: atoms + TYPE(t_hybrid), INTENT(IN) :: hybrid + TYPE(t_sym), INTENT(IN) :: sym + TYPE(t_kpts), INTENT(IN) :: kpts + TYPE(t_atoms), INTENT(IN) :: atoms ! - scalars - INTEGER,INTENT(IN) :: ikpt0,igptm_in,iop ,maxindxm - INTEGER,INTENT(IN) :: maxlcutm - INTEGER,INTENT(IN) :: nbasp - LOGICAL,INTENT(IN) :: writevec - INTEGER,INTENT(OUT) :: igptm_out + INTEGER, INTENT(IN) :: ikpt0, igptm_in, iop, maxindxm + INTEGER, INTENT(IN) :: maxlcutm + INTEGER, INTENT(IN) :: nbasp + LOGICAL, INTENT(IN) :: writevec + INTEGER, INTENT(OUT) :: igptm_out ! - arrays - - INTEGER,INTENT(IN) :: rrot(3,3),invrrot(3,3) - INTEGER,INTENT(IN) :: lcutm(atoms%ntype),& - & nindxm(0:maxlcutm,atoms%ntype) - INTEGER,INTENT(IN) :: nbasm(kpts%nkptf) - INTEGER,INTENT(IN) :: pointer(& - & minval(hybrid%gptm(1,:))-1:maxval(hybrid%gptm(1,:))+1,& - & minval(hybrid%gptm(2,:))-1:maxval(hybrid%gptm(2,:))+1,& - & minval(hybrid%gptm(3,:))-1:maxval(hybrid%gptm(3,:))+1) - - COMPLEX,INTENT(IN) :: vecin(nbasm(ikpt0)) - COMPLEX,INTENT(IN) :: dwgn(-maxlcutm:maxlcutm,& + INTEGER, INTENT(IN) :: rrot(3, 3), invrrot(3, 3) + INTEGER, INTENT(IN) :: lcutm(atoms%ntype),& + & nindxm(0:maxlcutm, atoms%ntype) + INTEGER, INTENT(IN) :: nbasm(kpts%nkptf) + INTEGER, INTENT(IN) :: pointer(& + & minval(hybrid%gptm(1, :)) - 1:maxval(hybrid%gptm(1, :)) + 1,& + & minval(hybrid%gptm(2, :)) - 1:maxval(hybrid%gptm(2, :)) + 1,& + & minval(hybrid%gptm(3, :)) - 1:maxval(hybrid%gptm(3, :)) + 1) + + COMPLEX, INTENT(IN) :: vecin(nbasm(ikpt0)) + COMPLEX, INTENT(IN) :: dwgn(-maxlcutm:maxlcutm,& & -maxlcutm:maxlcutm,& & 0:maxlcutm) - COMPLEX,INTENT(OUT) :: vecout(nbasm(ikpt0)) + COMPLEX, INTENT(OUT) :: vecout(nbasm(ikpt0)) ! - private scalars - - INTEGER :: itype,ieq,ic,l,n,i,nn,i1,i2,j1,j2,m1 - INTEGER :: m2,igptm,igptm2,igptp,iiop,isym - INTEGER :: ikpt1,isymi,rcent + INTEGER :: itype, ieq, ic, l, n, i, nn, i1, i2, j1, j2, m1 + INTEGER :: m2, igptm, igptm2, igptp, iiop, isym + INTEGER :: ikpt1, isymi, rcent LOGICAL :: trs - COMPLEX,PARAMETER :: img=(0.0,1.0) - COMPLEX :: cexp,cdum + COMPLEX, PARAMETER :: img = (0.0, 1.0) + COMPLEX :: cexp, cdum ! - private arrays - - INTEGER :: pnt(maxindxm,0:maxlcutm,atoms%nat),g(3),& - & g1(3),iarr(hybrid%ngptm(ikpt0)) - REAL :: rkpt(3),rkpthlp(3),trans(3) + INTEGER :: pnt(maxindxm, 0:maxlcutm, atoms%nat), g(3),& + & g1(3), iarr(hybrid%ngptm(ikpt0)) + REAL :: rkpt(3), rkpthlp(3), trans(3) COMPLEX :: vecin1(nbasm(ikpt0)) COMPLEX :: carr(hybrid%ngptm(ikpt0)) - - IF( iop .le. sym%nop ) THEN - isym = iop - trs = .false. - trans = sym%tau(:,isym) + IF (iop <= sym%nop) THEN + isym = iop + trs = .false. + trans = sym%tau(:, isym) ELSE - isym = iop - sym%nop - trs = .true. - trans = sym%tau(:,isym) + isym = iop - sym%nop + trs = .true. + trans = sym%tau(:, isym) END IF - rkpthlp = matmul(rrot,kpts%bk(:,ikpt0)) - rkpt = modulo1(rkpthlp,kpts%nkpt3) - g = nint(rkpthlp-rkpt) + rkpthlp = matmul(rrot, kpts%bk(:, ikpt0)) + rkpt = modulo1(rkpthlp, kpts%nkpt3) + g = nint(rkpthlp - rkpt) ! ! determine number of rotated k-point bk(:,ikpt) -> ikpt1 - ! - DO i=1,kpts%nkpt - IF ( maxval( abs(rkpt - kpts%bk(:,i)) ) .le. 1E-06 ) THEN - ikpt1 = i - EXIT - END IF + ! + DO i = 1, kpts%nkpt + IF (maxval(abs(rkpt - kpts%bk(:, i))) <= 1E-06) THEN + ikpt1 = i + EXIT + END IF END DO - DO igptm = 1,hybrid%ngptm(ikpt1) - igptp = hybrid%pgptm(igptm,ikpt1) - g1 = matmul(invrrot,hybrid%gptm(:,igptp)-g) - igptm2 = pointer(g1(1),g1(2),g1(3)) - IF(igptm2.eq.igptm_in) THEN - igptm_out = igptm - IF(writevec) THEN - cdum = exp(img * tpi_const * dot_product(kpts%bk(:,ikpt1)+hybrid%gptm(:,igptp),trans)) - EXIT - ELSE - RETURN - END IF - END IF + DO igptm = 1, hybrid%ngptm(ikpt1) + igptp = hybrid%pgptm(igptm, ikpt1) + g1 = matmul(invrrot, hybrid%gptm(:, igptp) - g) + igptm2 = pointer(g1(1), g1(2), g1(3)) + IF (igptm2 == igptm_in) THEN + igptm_out = igptm + IF (writevec) THEN + cdum = exp(img*tpi_const*dot_product(kpts%bk(:, ikpt1) + hybrid%gptm(:, igptp), trans)) + EXIT + ELSE + RETURN + END IF + END IF END DO ! Transform back to unsymmetrized product basis in case of inversion symmetry. vecout = vecin - if (sym%invs) CALL desymmetrize(vecout,nbasp,1,1,& - atoms,lcutm,maxlcutm,nindxm,sym) + if (sym%invs) CALL desymmetrize(vecout, nbasp, 1, 1, & + atoms, lcutm, maxlcutm, nindxm, sym) ! Right-multiplication ! PW - IF(trs) THEN ; vecin1 = cdum * conjg ( vecout ) - ELSE ; vecin1 = cdum * vecout + IF (trs) THEN; vecin1 = cdum*conjg(vecout) + ELSE; vecin1 = cdum*vecout END IF ! Define pointer to first mixed-basis functions (with m = -l) - i = 0 - ic = 0 - DO itype = 1,atoms%ntype - DO ieq = 1,atoms%neq(itype) - ic = ic + 1 - DO l = 0,lcutm(itype) - DO n = 1,nindxm(l,itype) - i = i + 1 - pnt(n,l,ic) = i + i = 0 + ic = 0 + DO itype = 1, atoms%ntype + DO ieq = 1, atoms%neq(itype) + ic = ic + 1 + DO l = 0, lcutm(itype) + DO n = 1, nindxm(l, itype) + i = i + 1 + pnt(n, l, ic) = i + END DO + i = i + nindxm(l, itype)*2*l END DO - i = i + nindxm(l,itype) * 2*l - END DO - END DO + END DO END DO ! Left-multiplication ! MT - cexp = exp( -img *tpi_const * dot_product(kpts%bk(:,ikpt1)+g,trans)) - ic = 0 - DO itype = 1,atoms%ntype - DO ieq = 1,atoms%neq(itype) - ic = ic + 1 - rcent = hybrid%map(ic,sym%invtab(isym)) - cdum = cexp * exp(img *tpi_const*dot_product(g,atoms%taual(:,ic))) !rcent))) - cdum = conjg(cdum) - DO l = 0,lcutm(itype) - nn = nindxm(l,itype) - DO n = 1,nn - - i1 = pnt(n,l,ic) - i2 = i1 + nn * 2*l - j1 = pnt(n,l,rcent) - j2 = j1 + nn * 2*l - - vecout(i1:i2:nn) = cdum * matmul(dwgn(-l:l,-l:l,l), vecin1(j1:j2:nn) ) + cexp = exp(-img*tpi_const*dot_product(kpts%bk(:, ikpt1) + g, trans)) + ic = 0 + DO itype = 1, atoms%ntype + DO ieq = 1, atoms%neq(itype) + ic = ic + 1 + rcent = hybrid%map(ic, sym%invtab(isym)) + cdum = cexp*exp(img*tpi_const*dot_product(g, atoms%taual(:, ic))) !rcent))) + cdum = conjg(cdum) + DO l = 0, lcutm(itype) + nn = nindxm(l, itype) + DO n = 1, nn + + i1 = pnt(n, l, ic) + i2 = i1 + nn*2*l + j1 = pnt(n, l, rcent) + j2 = j1 + nn*2*l + + vecout(i1:i2:nn) = cdum*matmul(dwgn(-l:l, -l:l, l), vecin1(j1:j2:nn)) + END DO END DO - END DO - END DO + END DO END DO ! PW - DO igptm = 1,hybrid%ngptm(ikpt1) - igptp = hybrid%pgptm(igptm,ikpt1) - g1 = matmul(invrrot,hybrid%gptm(:,igptp)-g) - iarr(igptm) = pointer(g1(1),g1(2),g1(3)) - carr(igptm) = exp(-img * tpi_const * dot_product(kpts%bk(:,ikpt1)+hybrid%gptm(:,igptp),trans)) + DO igptm = 1, hybrid%ngptm(ikpt1) + igptp = hybrid%pgptm(igptm, ikpt1) + g1 = matmul(invrrot, hybrid%gptm(:, igptp) - g) + iarr(igptm) = pointer(g1(1), g1(2), g1(3)) + carr(igptm) = exp(-img*tpi_const*dot_product(kpts%bk(:, ikpt1) + hybrid%gptm(:, igptp), trans)) END DO - DO i1 = 1,hybrid%ngptm(ikpt1) - vecout(nbasp+i1) = carr(i1) * vecin1(nbasp+iarr(i1)) + DO i1 = 1, hybrid%ngptm(ikpt1) + vecout(nbasp + i1) = carr(i1)*vecin1(nbasp + iarr(i1)) END DO ! If inversion symmetry is applicable, symmetrize to make the values real. - if(sym%invs) CALL symmetrize(vecout,nbasp,1,1,.false.,& - atoms,lcutm,maxlcutm, nindxm,sym) + if (sym%invs) CALL symmetrize(vecout, nbasp, 1, 1, .false., & + atoms, lcutm, maxlcutm, nindxm, sym) - END SUBROUTINE bramat_trafo + END SUBROUTINE bramat_trafo - END MODULE m_trafo +END MODULE m_trafo diff --git a/hybrid/wavefproducts.F90 b/hybrid/wavefproducts.F90 index 5821a0dd9959fbdf6ce1f55ce17987f120ccff3c..361c702a406d7797a127cc56ba855ec4df5221b1 100644 --- a/hybrid/wavefproducts.F90 +++ b/hybrid/wavefproducts.F90 @@ -3,2439 +3,2362 @@ ! 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_wavefproducts - USE m_judft - PRIVATE - PUBLIC wavefproducts_noinv, wavefproducts_noinv5 - PUBLIC wavefproducts_inv, wavefproducts_inv5 - CONTAINS - - SUBROUTINE wavefproducts_noinv(bandi,bandf,nk,iq,dimension,input,jsp,& !cprod,& - & cell,atoms,hybrid,hybdat,& - & kpts,mnobd,& - & lapw,sym,noco,nbasm_mt,nkqpt,cprod) - +MODULE m_wavefproducts + USE m_judft + PRIVATE + PUBLIC wavefproducts_noinv, wavefproducts_noinv5 + PUBLIC wavefproducts_inv, wavefproducts_inv5 +CONTAINS + + SUBROUTINE wavefproducts_noinv(bandi, bandf, nk, iq, dimension, input, jsp,& !cprod,& + & cell, atoms, hybrid, hybdat,& + & kpts, mnobd,& + & lapw, sym, noco, nbasm_mt, nkqpt, cprod) USE m_constants - USE m_util , ONLY : modulo1 + USE m_util, ONLY: modulo1 USE m_wrapper USE m_types USE m_io_hybrid IMPLICIT NONE - TYPE(t_input),INTENT(IN) :: input - TYPE(t_dimension),INTENT(IN) :: dimension - TYPE(t_hybrid),INTENT(IN) :: hybrid - TYPE(t_sym),INTENT(IN) :: sym - TYPE(t_noco),INTENT(IN) :: noco - TYPE(t_cell),INTENT(IN) :: cell - TYPE(t_kpts),INTENT(IN) :: kpts - TYPE(t_atoms),INTENT(IN) :: atoms - TYPE(t_lapw),INTENT(IN) :: lapw - TYPE(t_hybdat),INTENT(INOUT) :: hybdat + TYPE(t_input), INTENT(IN) :: input + TYPE(t_dimension), INTENT(IN) :: dimension + TYPE(t_hybrid), INTENT(IN) :: hybrid + TYPE(t_sym), INTENT(IN) :: sym + TYPE(t_noco), INTENT(IN) :: noco + TYPE(t_cell), INTENT(IN) :: cell + TYPE(t_kpts), INTENT(IN) :: kpts + TYPE(t_atoms), INTENT(IN) :: atoms + TYPE(t_lapw), INTENT(IN) :: lapw + TYPE(t_hybdat), INTENT(INOUT) :: hybdat ! - scalars - - INTEGER,INTENT(IN) :: nk,iq ,jsp - INTEGER,INTENT(IN) :: mnobd - INTEGER,INTENT(IN) :: nbasm_mt - INTEGER,INTENT(IN) :: bandi,bandf - INTEGER,INTENT(OUT) :: nkqpt - - - -! - arrays - - - - - COMPLEX ,INTENT(OUT) :: cprod(hybrid%maxbasm1,mnobd,bandf-bandi+1) - - -! - local scalars - - INTEGER :: ic,l,n,l1,l2,n1,n2,lm_0,lm1_0,lm2_0, lm,lm1,lm2 ,m1,m2,i,j,ll - INTEGER :: itype,ieq,ikpt,ikpt1,ikpt2,igpt,igptp, igpt1,igpt2,iband,iband1,iband2 - INTEGER :: k,ic1,ioffset,ibando - INTEGER :: q,idum,m + INTEGER, INTENT(IN) :: nk, iq, jsp + INTEGER, INTENT(IN) :: mnobd + INTEGER, INTENT(IN) :: nbasm_mt + INTEGER, INTENT(IN) :: bandi, bandf + INTEGER, INTENT(OUT) :: nkqpt + +! - arrays - + + COMPLEX, INTENT(OUT) :: cprod(hybrid%maxbasm1, mnobd, bandf - bandi + 1) + +! - local scalars - + INTEGER :: ic, l, n, l1, l2, n1, n2, lm_0, lm1_0, lm2_0, lm, lm1, lm2, m1, m2, i, j, ll + INTEGER :: itype, ieq, ikpt, ikpt1, ikpt2, igpt, igptp, igpt1, igpt2, iband, iband1, iband2 + INTEGER :: k, ic1, ioffset, ibando + INTEGER :: q, idum, m INTEGER :: nbasm_ir INTEGER :: nbasmmt, nbasfcn INTEGER :: ok - REAL :: rdum,svol,s2,pi - REAL :: mtthr= 0 - COMPLEX :: cdum,cdum0 - COMPLEX,PARAMETER :: img = (0.0,1.0) + REAL :: rdum, svol, s2, pi + REAL :: mtthr = 0 + COMPLEX :: cdum, cdum0 + COMPLEX, PARAMETER :: img = (0.0, 1.0) - LOGICAL :: offdiag + LOGICAL :: offdiag ! - local arrays - INTEGER :: iarr(lapw%nv(jsp)) - INTEGER :: g(3),ghelp(3),lmstart(0:atoms%lmaxd,atoms%ntype) - INTEGER :: gpthlp(3,dimension%nvd),nvhlp(input%jspins) - INTEGER :: gpt_nk(3,lapw%nv(jsp)) + INTEGER :: g(3), ghelp(3), lmstart(0:atoms%lmaxd, atoms%ntype) + INTEGER :: gpthlp(3, dimension%nvd), nvhlp(input%jspins) + INTEGER :: gpt_nk(3, lapw%nv(jsp)) INTEGER :: g_t(3) INTEGER :: gsum(3) REAL :: bkpt(3) REAL :: bkhlp(3) - REAL :: kqpt(3),kqpthlp(3) - COMPLEX :: carr(1:mnobd,bandf-bandi+1) + REAL :: kqpt(3), kqpthlp(3) + COMPLEX :: carr(1:mnobd, bandf - bandi + 1) ! COMPLEX :: chelp(maxbasm,mnobd,bandf-bandi+1,nkpt_EIBZ) COMPLEX :: cexp COMPLEX :: z_help(lapw%nv(jsp)) - COMPLEX :: cmt (dimension%neigd,hybrid%maxlmindx,atoms%nat) - COMPLEX :: cmt_nk(dimension%neigd,hybrid%maxlmindx,atoms%nat) - COMPLEX,ALLOCATABLE :: cprod_ir(:,:,:) - TYPE(t_mat) :: z_nk,z_kqpt + COMPLEX :: cmt(dimension%neigd, hybrid%maxlmindx, atoms%nat) + COMPLEX :: cmt_nk(dimension%neigd, hybrid%maxlmindx, atoms%nat) + COMPLEX, ALLOCATABLE :: cprod_ir(:, :, :) + TYPE(t_mat) :: z_nk, z_kqpt TYPE(t_lapw) :: lapw_nkqpt CALL timestart("wavefproducts_noinv") ! preparations svol = sqrt(cell%omtil) - s2 = sqrt(2.0) + s2 = sqrt(2.0) - gpt_nk(1,:) = lapw%k1(:lapw%nv(jsp),jsp) - gpt_nk(2,:) = lapw%k2(:lapw%nv(jsp),jsp) - gpt_nk(3,:) = lapw%k3(:lapw%nv(jsp),jsp) + gpt_nk(1, :) = lapw%k1(:lapw%nv(jsp), jsp) + gpt_nk(2, :) = lapw%k2(:lapw%nv(jsp), jsp) + gpt_nk(3, :) = lapw%k3(:lapw%nv(jsp), jsp) ! ! compute k+q point for given q point in EIBZ(k) ! - kqpthlp = kpts%bkf(:,nk) + kpts%bkf(:,iq) + kqpthlp = kpts%bkf(:, nk) + kpts%bkf(:, iq) ! k+q can lie outside the first BZ, transfer ! it back into the 1. BZ - kqpt = modulo1(kqpthlp,kpts%nkpt3) - g_t(:) = nint( kqpt - kqpthlp ) + kqpt = modulo1(kqpthlp, kpts%nkpt3) + g_t(:) = nint(kqpt - kqpthlp) ! determine number of kqpt - nkqpt = 0 - DO ikpt = 1,kpts%nkptf - IF ( maxval( abs( kqpt - kpts%bkf(:,ikpt) ) ) .le. 1E-06 ) THEN - nkqpt = ikpt - EXIT - END IF + nkqpt = 0 + DO ikpt = 1, kpts%nkptf + IF (maxval(abs(kqpt - kpts%bkf(:, ikpt))) <= 1E-06) THEN + nkqpt = ikpt + EXIT + END IF END DO - IF ( nkqpt .eq. 0) STOP 'wavefproducts: k-point not found' - - + IF (nkqpt == 0) STOP 'wavefproducts: k-point not found' ! lmstart = lm start index for each l-quantum number and atom type (for cmt-coefficients) - DO itype = 1,atoms%ntype - DO l = 0,atoms%lmax(itype) - lmstart(l,itype) = sum( (/ (hybrid%nindx(ll,itype)*(2*ll+1),ll=0,l-1) /) ) - END DO + DO itype = 1, atoms%ntype + DO l = 0, atoms%lmax(itype) + lmstart(l, itype) = sum((/(hybrid%nindx(ll, itype)*(2*ll + 1), ll=0, l - 1)/)) + END DO END DO - nbasm_ir = maxval(hybrid%ngptm) - ALLOCATE( cprod_ir(bandf-bandi+1,mnobd,nbasm_ir),stat=ok ) - IF( ok .ne. 0) STOP 'wavefproducts: failure allocation cprod_ir' + ALLOCATE (cprod_ir(bandf - bandi + 1, mnobd, nbasm_ir), stat=ok) + IF (ok /= 0) STOP 'wavefproducts: failure allocation cprod_ir' cprod_ir = 0 - + cprod = 0 - - CALL lapw_nkqpt%init(input,noco,kpts,atoms,sym,nkqpt,cell,sym%zrfs) - nbasfcn = MERGE(lapw%nv(1)+lapw%nv(2)+2*atoms%nlotot,lapw%nv(1)+atoms%nlotot,noco%l_noco) - call z_nk%alloc(.false.,nbasfcn,dimension%neigd) - nbasfcn = MERGE(lapw_nkqpt%nv(1)+lapw_nkqpt%nv(2)+2*atoms%nlotot,lapw_nkqpt%nv(1)+atoms%nlotot,noco%l_noco) - call z_kqpt%alloc(.false.,nbasfcn,dimension%neigd) - - call read_z(z_nk,nk) - call read_z(z_kqpt,nkqpt) - + + CALL lapw_nkqpt%init(input, noco, kpts, atoms, sym, nkqpt, cell, sym%zrfs) + nbasfcn = MERGE(lapw%nv(1) + lapw%nv(2) + 2*atoms%nlotot, lapw%nv(1) + atoms%nlotot, noco%l_noco) + call z_nk%alloc(.false., nbasfcn, dimension%neigd) + nbasfcn = MERGE(lapw_nkqpt%nv(1) + lapw_nkqpt%nv(2) + 2*atoms%nlotot, lapw_nkqpt%nv(1) + atoms%nlotot, noco%l_noco) + call z_kqpt%alloc(.false., nbasfcn, dimension%neigd) + + call read_z(z_nk, nk) + call read_z(z_kqpt, nkqpt) + ! read in cmt coefficients from direct access file cmt - call read_cmt(cmt_nk,nk) - + call read_cmt(cmt_nk, nk) + ! IR contribution - + CALL timestart("wavefproducts_noinv IR") - DO igpt = 1,hybrid%ngptm(iq) - igptp = hybrid%pgptm(igpt,iq) - ghelp = hybrid%gptm(:,igptp)- g_t(:) - DO i=1,lapw%nv(jsp) - gsum(:) = ghelp + gpt_nk(:,i) - IF( all( abs(gsum) .le. hybdat%pntgptd ) ) THEN - iarr(i) = hybdat%pntgpt(gsum(1),gsum(2),gsum(3),nkqpt) - ELSE - iarr(i) = 0 - END IF + DO igpt = 1, hybrid%ngptm(iq) + igptp = hybrid%pgptm(igpt, iq) + ghelp = hybrid%gptm(:, igptp) - g_t(:) + DO i = 1, lapw%nv(jsp) + gsum(:) = ghelp + gpt_nk(:, i) + IF (all(abs(gsum) <= hybdat%pntgptd)) THEN + iarr(i) = hybdat%pntgpt(gsum(1), gsum(2), gsum(3), nkqpt) + ELSE + iarr(i) = 0 + END IF - END DO + END DO - DO iband1 = 1, hybrid%nobd(nkqpt) - where (iarr>0) - z_help(:) = z_kqpt%data_c(iarr(:),iband1) - elsewhere - z_help=0.0 - end where + DO iband1 = 1, hybrid%nobd(nkqpt) + where (iarr > 0) + z_help(:) = z_kqpt%data_c(iarr(:), iband1) + elsewhere + z_help = 0.0 + end where - DO iband = bandi,bandf - cprod_ir(iband,iband1,igpt) = 1/svol * dotprod( z_nk%data_c(:lapw%nv(jsp),iband),z_help ) - END DO !iband + DO iband = bandi, bandf + cprod_ir(iband, iband1, igpt) = 1/svol*dotprod(z_nk%data_c(:lapw%nv(jsp), iband), z_help) + END DO !iband - END DO !iband1 + END DO !iband1 END DO !igpt CALL timestop("wavefproducts_noinv IR") - - - ! ! MT contribution - ! - call read_cmt(cmt,nkqpt) - lm_0 = 0 - ic = 0 - - DO itype = 1,atoms%ntype - DO ieq = 1,atoms%neq(itype) - ic = ic + 1 - ic1 = 0 - - cexp = exp ( -2*img*pi_const* dot_product( kpts%bkf(:,iq),atoms%taual(:,ic) ) ) - - - DO l = 0,hybrid%lcutm1(itype) - DO n = 1,hybdat%nindxp1(l,itype) ! loop over basis-function products - - l1 = hybdat%prod(n,l,itype)%l1 ! - l2 = hybdat%prod(n,l,itype)%l2 ! current basis-function product - n1 = hybdat%prod(n,l,itype)%n1 ! = bas(:,n1,l1,itype)*bas(:,n2,l2,itype) = b1*b2 - n2 = hybdat%prod(n,l,itype)%n2 ! - - IF( mod(l1+l2+l,2) .ne. 0 ) cycle - - offdiag = l1.ne.l2.or.n1.ne.n2 ! offdiag=true means that b1*b2 and b2*b1 are different combinations - !(leading to the same basis-function product) - - lm1_0 = lmstart(l1,itype) ! start at correct lm index of cmt-coefficients - lm2_0 = lmstart(l2,itype) ! (corresponding to l1 and l2) - - lm = lm_0 - DO m = -l,l - - carr = 0.0 - - lm1 = lm1_0 + n1 ! go to lm index for m1=-l1 - DO m1 = -l1,l1 - m2 = m1 + m ! Gaunt condition -m1+m2-m=0 - IF(abs(m2).le.l2) THEN - lm2 = lm2_0 + n2 + (m2+l2)*hybrid%nindx(l2,itype) - rdum = hybdat%gauntarr(1,l1,l2,l,m1,m) ! precalculated Gaunt coefficient - IF(rdum.ne.0) THEN - DO iband = bandi,bandf - cdum = rdum * conjg(cmt_nk(iband,lm1,ic)) !nk - DO iband1 = 1,mnobd - carr(iband1,iband) = carr(iband1,iband) + cdum * cmt(iband1,lm2,ic) !ikpt + ! + call read_cmt(cmt, nkqpt) + lm_0 = 0 + ic = 0 - END DO - END DO - END IF - END IF - - m2 = m1 - m ! switch role of b1 and b2 - IF(abs(m2).le.l2.and.offdiag) THEN - lm2 = lm2_0 + n2 + (m2+l2)*hybrid%nindx(l2,itype) - rdum = hybdat%gauntarr(2,l1,l2,l,m1,m) ! precalculated Gaunt coefficient - IF(rdum.ne.0) THEN - DO iband = bandi,bandf - cdum = rdum * conjg(cmt_nk(iband,lm2,ic)) !nk - DO iband1 = 1,mnobd - carr(iband1,iband) = carr(iband1,iband) + cdum * cmt(iband1,lm1,ic) - END DO - END DO - END IF - END IF + DO itype = 1, atoms%ntype + DO ieq = 1, atoms%neq(itype) + ic = ic + 1 + ic1 = 0 + + cex