! ! Copyright (C) 2001-2018 Quantum ESPRESSO ! This file is distributed under the terms ! GNU General Public License. See the file ! in the root directory of the present dis ! or http://www.gnu.org/copyleft/gpl.txt . ! ! !---------------------------------------------------------------------------------- MODULE doubleprojqq_module ! CONTAINS ! !---------------------------------------------------------------------------------- SUBROUTINE doubleprojqq (na, vec1, vec2, vec3, vec4, npw1, npw2, dpqq) !-------------------------------------------------------------------------------- ! ! This routine calculates for all ibnd: ! dpqq(ibnd) = \sum{l1 l2} < vec1(ibnd) | vec2(na,l1) > * qq(na, l1 ,l2) * & ! < vec3(na,l2) | vec4 > ! USE kinds, ONLY : DP USE uspp_param, ONLY : nh USE ions_base, ONLY : ityp USE uspp, ONLY : qq_nt USE wvfct, ONLY : npwx, nbnd USE mp_pools, ONLY : intra_pool_comm USE mp, ONLY : mp_sum USE control_lr, ONLY : ofsbeta ! IMPLICIT NONE ! INTEGER, INTENT(IN) :: na ! index of the displaced atom COMPLEX(DP), INTENT(IN) :: vec1(:,:), & ! (npwx,nkb) vec2(:,:), & ! (npwx,nkb) vec3(:,:), & ! (npwx,nkb) vec4(:) ! (npwx) INTEGER, INTENT(IN) :: npw1, npw2 COMPLEX(DP), INTENT(OUT) :: dpqq(:) ! (nbnd) ! ! Local variables ! INTEGER :: nt, l1, l2, ibeta1, ibeta2, ibnd COMPLEX(DP) :: projauxvec4 COMPLEX(DP), ALLOCATABLE :: aux1(:), projvec1vec2(:) COMPLEX(DP), EXTERNAL :: ZDOTC ! CALL start_clock ( 'doubleprojqq' ) ! ALLOCATE (aux1(npwx)) ALLOCATE (projvec1vec2(nbnd)) ! dpqq = (0.d0, 0.d0) ! nt = ityp(na) ! DO l1 = 1, nh(nt) ! ibeta1 = ofsbeta(na) + l1 ! ! Calculate: projvec1vec2(ibnd) = < vec1(ibnd) | vec2 > for each l1 ! DO ibnd = 1, nbnd projvec1vec2(ibnd) = ZDOTC (npw1, vec1(:,ibnd), 1, vec2(:,ibeta1), 1) ENDDO ! #if defined(__MPI) CALL mp_sum(projvec1vec2, intra_pool_comm) #endif ! aux1 = (0.d0, 0.d0) ! ! aux1 = \sum_l2 qq_nt(l1,l2,nt) * |vec3_(na,l2)> ! DO l2 = 1, nh(nt) ibeta2 = ofsbeta(na) + l2 aux1(:) = aux1(:) + qq_nt(l1,l2,nt) * vec3(:,ibeta2) ENDDO ! ! Calculate projauxvec4 = < aux1 | vec4 > ! projauxvec4 = ZDOTC (npw2, aux1, 1, vec4, 1) ! #if defined(__MPI) CALL mp_sum(projauxvec4, intra_pool_comm) #endif ! ! Summing on l1 for each band ibnd ! dpqq(:) = dpqq(:) + projvec1vec2(:) * projauxvec4 ! ENDDO ! DEALLOCATE (aux1) DEALLOCATE (projvec1vec2) ! CALL stop_clock ( 'doubleprojqq' ) ! RETURN ! END SUBROUTINE doubleprojqq !--------------------------------------------------------------------- !----------------------------------------------------------------------- SUBROUTINE doubleprojqq2 (na, proj, vec3, vec4, npw2, dpqq) ! ! This routine calculates for all ibnd: ! dpqq(ibnd) = \sum{l1 l2} proj(ibnd,na,l1) * qq_nt(na, l1 ,l2) * & ! < vec3 (na,l2) | vec4 > ! USE kinds, ONLY : DP USE uspp_param, ONLY : nh USE ions_base, ONLY : ityp USE uspp, ONLY : qq_nt USE wvfct, ONLY : npwx, nbnd USE mp_pools, ONLY : intra_pool_comm USE mp, ONLY : mp_sum USE control_lr, ONLY : ofsbeta ! IMPLICIT NONE ! INTEGER, INTENT(IN) :: na ! index of the displaced atom COMPLEX(DP), INTENT(IN) :: proj(:,:), & ! (nbnd,nkb) vec3(:,:), & ! (npwx,nkb) vec4 (:) ! (npwx) INTEGER, INTENT (IN) :: npw2 COMPLEX(DP), INTENT(OUT) :: dpqq(:) ! (nbnd) ! ! Local variables ! INTEGER :: nt, l1, l2, ibeta1, ibeta2, ibnd COMPLEX(DP), ALLOCATABLE :: aux1(:) COMPLEX(DP) :: projauxvec4 COMPLEX(DP), EXTERNAL :: ZDOTC ! CALL start_clock ( 'doubleprojqq2' ) ! ALLOCATE (aux1(npwx)) ! dpqq = (0.d0, 0.d0) ! nt = ityp(na) ! DO l1 = 1, nh(nt) ! ibeta1 = ofsbeta(na) + l1 ! aux1 = (0.d0, 0.d0) ! DO l2 = 1, nh(nt) ibeta2 = ofsbeta(na) + l2 aux1(:) = aux1(:) + qq_nt(l1,l2,nt) * vec3(:,ibeta2) ENDDO ! ! Calculate projauxvec4 = < aux1 | vec4 > ! projauxvec4 = ZDOTC (npw2, aux1, 1, vec4, 1) ! #if defined(__MPI) CALL mp_sum(projauxvec4, intra_pool_comm) #endif ! ! Summing over l1 for each band ibnd ! dpqq(:) = dpqq(:) + proj(:,ibeta1) * projauxvec4 ! ENDDO ! DEALLOCATE (aux1) ! CALL stop_clock ( 'doubleprojqq2' ) ! RETURN ! END SUBROUTINE doubleprojqq2 !-------------------------------------------------------------- END MODULE doubleprojqq_module !-------------------------------------------------------------- !-------------------------------------------------------- MODULE term_one_1_module !-------------------------------------------------------- USE mp_pools, ONLY : intra_pool_comm USE mp, ONLY: mp_sum ! CONTAINS ! !-------------------------------------------------------- SUBROUTINE term_one_1 (ik, icart, jcart, evc_, & wfcatom_, proj_, vkb_, resone_1) !---------------------------------------------------- ! USE kinds, ONLY : DP USE wvfct, ONLY : npwx, nbnd, wg USE uspp, ONLY : vkb, nkb USE klist, ONLY : ngk, igk_k USE qpoint, ONLY : ikks USE doubleprojqq_module ! IMPLICIT NONE ! INTEGER, INTENT(IN) :: ik, icart, jcart COMPLEX(DP), INTENT(IN) :: evc_(:,:), & ! (npwx,nbnd) wfcatom_(:), & ! (npwx) proj_(:), & ! (nbnd) vkb_(:,:) ! (npwx,nkb) COMPLEX(DP), INTENT(INOUT) :: resone_1 ! ! Local variables ! INTEGER :: npw, ikk, ibnd COMPLEX(DP), ALLOCATABLE :: d2wfcatomk(:), sd2wfcatomk(:), projd2(:) COMPLEX(DP), EXTERNAL :: ZDOTC ! ALLOCATE(d2wfcatomk(npwx)) ALLOCATE(sd2wfcatomk(npwx)) ALLOCATE(projd2(nbnd)) ! resone_1 = (0.d0, 0.d0) ! ikk = ikks(ik) npw = ngk(ikk) ! ! Calculate the 2nd derivative of the atomic orbitals: ! | d2_^(I,icart,jcart) \phi_(k,I,m) > ! CALL d2wfc (npw, igk_k(1,ikk), ikk, icart, jcart, & wfcatom_, d2wfcatomk) ! ! Apply the S operator to the result above: ! | S d2_^(I,icart,jcart) \phi_(k,I,m) > ! CALL swfc (npw, 1, vkb_, d2wfcatomk, sd2wfcatomk) ! ! Calculate projd2(ibnd) = < psi(ibnd,k) | S d2_^(I,icart,jcart) \phi_(k,I,m) > ! at ihubst1 (i.e. I m) ! DO ibnd = 1, nbnd projd2(ibnd) = ZDOTC (npw, evc_(:,ibnd), 1, sd2wfcatomk, 1) ENDDO ! CALL mp_sum(projd2, intra_pool_comm) ! DO ibnd = 1, nbnd resone_1 = resone_1 + wg(ibnd,ikk) * projd2(ibnd) * proj_(ibnd) ENDDO ! DEALLOCATE(d2wfcatomk) DEALLOCATE(sd2wfcatomk) DEALLOCATE(projd2) ! RETURN ! END SUBROUTINE term_one_1 !------------------------------------------------------------------------------ END MODULE term_one_1_module !------------------------------------------------------------------------------- !------------------------------------------------------------------------------- MODULE term_three_1_module ! CONTAINS ! !------------------------------------------------------------------------------- SUBROUTINE term_three_1 (ik, icart, jcart, ihubst1, ihubst2, & projdphi, resthree_1) !--------------------------------------------------------------------------- ! USE kinds, ONLY : DP USE wvfct, ONLY : wg, nbnd USE qpoint, ONLY : ikks ! IMPLICIT NONE ! INTEGER, INTENT(IN) :: ik, icart, jcart, ihubst1, ihubst2 COMPLEX(DP), INTENT(IN) :: projdphi(:,:,:) ! (nbnd,nwfcU,3) COMPLEX(DP), INTENT(INOUT) :: resthree_1 ! ! Local variables ! INTEGER :: ibnd, ikk ! resthree_1 = (0.d0, 0.d0) ! ikk = ikks(ik) ! DO ibnd = 1, nbnd resthree_1 = resthree_1 + wg(ibnd,ikk) * projdphi(ibnd,ihubst1,icart) * & CONJG(projdphi (ibnd,ihubst2, jcart)) ENDDO ! RETURN ! END SUBROUTINE term_three_1 !---------------------------------------------------------------------------------- END MODULE term_three_1_module !---------------------------------------------------------------------------------- !----------------------------------------------------------------------- MODULE term_one_module !----------------------------------------------------------------------- USE doubleprojqq_module ! CONTAINS ! !------------------------------------------------------------------------ SUBROUTINE term_one (ik, icart, jcart, na, nap, nah, ihubst1, ihubst2, & evc_, wfcatomk, swfcatomk, vkb_, vkbkpq_, dvkb_, & dvkbkpq_, dwfcatomkpq_, res_one) !-------------------------------------------------------------------- ! USE kinds, ONLY : DP USE uspp, ONLY : nkb, okvan USE wvfct, ONLY : npwx, nbnd, wg USE uspp_param, ONLY : nh USE ions_base, ONLY : ityp USE control_lr, ONLY : ofsbeta USE ldaU_ph, ONLY : proj1, projpb, projpdb USE klist, ONLY : ngk, igk_k USE qpoint, ONLY : ikks, ikqs USE doubleprojqq_module USE term_one_1_module ! IMPLICIT NONE ! INTEGER, INTENT(IN) :: ik, icart, jcart, na, nap, nah, ihubst1, ihubst2 COMPLEX(DP), INTENT(IN) :: evc_(:,:), & ! (npwx,nbnd) wfcatomk(:,:), & ! (npwx,nwfcU) swfcatomk(:,:), & ! (npwx,nwfcU) vkb_(:,:), & ! (npwx,nkb) vkbkpq_(:,:), & ! (npwx,nkb) dvkb_(:,:,:), & ! (npwx,nkb,3) dvkbkpq_(:,:,:), & ! (npwx,nkb,3) dwfcatomkpq_(:,:,:) ! (npwx,nwfcU,3) COMPLEX(DP), INTENT(INOUT) :: res_one ! ! Local variables ! INTEGER :: npw, npwq, ikk, ikq, ibnd, nt, l1, l2, l, ibeta COMPLEX(DP) :: resone_1, resone_2,resone_3, resone_4, resone_5, & resone_6_9 COMPLEX(DP), ALLOCATABLE :: dpqq(:), dpqq1(:), dpqq2(:), & dpqq3(:), dpqq4(:), d2vkb(:,:) ! res_one = 0.d0 ! ALLOCATE(dpqq(nbnd)) ALLOCATE(dpqq1(nbnd)) ALLOCATE(dpqq2(nbnd)) ALLOCATE(dpqq3(nbnd)) ALLOCATE(dpqq4(nbnd)) ALLOCATE(d2vkb(npwx,nkb)) ! ikk = ikks(ik) ikq = ikqs(ik) npw = ngk(ikk) npwq= ngk(ikq) ! IF ((na==nap) .AND. (nah==na)) THEN ! term_one_1 contains a delta_na_nap ! ! Calculate term_one_1 ! CALL term_one_1 (ik, icart, jcart, evc_, wfcatomk(:,ihubst1), & proj1(:,ihubst2), vkb_, resone_1) ! res_one = res_one + resone_1 ! ENDIF ! ! USPP case ! IF (okvan) THEN ! IF (nah==nap) THEN ! ! Calculate term_one_2 ! resone_2 = (0.d0, 0.d0) CALL doubleprojqq2 (na, projpdb(:,:,icart), vkbkpq_, & dwfcatomkpq_(:,ihubst1,jcart), npwq, dpqq) ! DO ibnd = 1, nbnd resone_2 = resone_2 + wg(ibnd,ikk) * dpqq(ibnd) * proj1(ibnd,ihubst2) ENDDO ! res_one = res_one + CONJG(resone_2) ! ! Calculate term_one_3 ! resone_3 = (0.d0, 0.d0) ! CALL doubleprojqq2 (na, projpb, dvkbkpq_(:,:,icart), & dwfcatomkpq_(:,ihubst1,jcart), npwq, dpqq) ! DO ibnd = 1, nbnd resone_3 = resone_3 + wg(ibnd,ikk) * dpqq(ibnd) * proj1(ibnd,ihubst2) ENDDO ! res_one = res_one + CONJG(resone_3) ! ENDIF ! IF (nah==na) THEN ! ! Calculate term_one_4 ! resone_4 = (0.d0, 0.d0) ! CALL doubleprojqq2 (nap, projpdb(:,:,jcart), vkbkpq_, & dwfcatomkpq_(:,ihubst1,icart), npwq, dpqq) ! DO ibnd = 1, nbnd resone_4 = resone_4 + wg(ibnd,ikk) * dpqq(ibnd) * proj1(ibnd,ihubst2) ENDDO ! res_one = res_one + resone_4 ! ! Calculate term_one_5 ! resone_5 = (0.d0, 0.d0) ! CALL doubleprojqq2 (nap, projpb, dvkbkpq_(:,:,jcart), & dwfcatomkpq_(:,ihubst1,icart), npwq, dpqq) ! DO ibnd = 1, nbnd resone_5 = resone_5 + wg(ibnd,ikk) * dpqq(ibnd) * proj1(ibnd,ihubst2) ENDDO ! res_one = res_one + resone_5 ! ENDIF ! IF (na==nap) THEN ! resone_6_9 = (0.d0, 0.d0) ! d2vkb = (0.d0, 0.d0) ! nt = ityp(na) ! DO l = 1, nh(nt) ! ibeta = ofsbeta(na) + l ! ! Calculate the 2nd derivative of the beta functions for ! all l states of atom na ! CALL d2wfc (npw, igk_k(1,ikk), ikk, icart, jcart, & vkb_(:,ibeta), d2vkb(:,ibeta)) ! ! d2vkb is always the 2nd derivative at icart and jcart, ! displacing the atom na and looking at the beta of atom j=na_ ! ENDDO ! ! doubleprojqq, unlike doubleprojqq2, calculates the first proj1 inside ! CALL doubleprojqq (na, evc_, d2vkb, vkb_, wfcatomk(:,ihubst1), & npw, npw,dpqq1) ! CALL doubleprojqq2 (na, projpb, d2vkb, wfcatomk(:,ihubst1), & npw,dpqq2) ! CALL doubleprojqq2 (na, projpdb(:,:,icart), dvkb_(:,:,jcart), & wfcatomk(:,ihubst1), npw, dpqq3) ! CALL doubleprojqq2 (na, projpdb(:,:,jcart), dvkb_(:,:,icart), & wfcatomk(:,ihubst1), npw,dpqq4) ! DO ibnd = 1, nbnd resone_6_9 = resone_6_9 + ( dpqq1(ibnd) + dpqq2(ibnd) + & dpqq3(ibnd) + dpqq4(ibnd) ) * & proj1(ibnd,ihubst2) * wg(ibnd,ikk) ENDDO ! res_one = res_one + resone_6_9 ! ENDIF ! ENDIF ! DEALLOCATE(dpqq) DEALLOCATE(dpqq1) DEALLOCATE(dpqq2) DEALLOCATE(dpqq3) DEALLOCATE(dpqq4) DEALLOCATE(d2vkb) ! RETURN ! END SUBROUTINE term_one !---------------------------------------------------------------------------- !---------------------------------------------------------------------------- SUBROUTINE term_one_diag (ik, icart, jcart, na, nap, nah, ihubst1, ihubst2, & evc_, wfcatomk, swfcatomk, vkb_, vkbkpq_, dvkb_, & dvkbkpq_, dwfcatomkpq_, res_one) !------------------------------------------------------------------------ ! USE kinds, ONLY : DP USE uspp, ONLY : nkb, okvan USE wvfct, ONLY : npwx, nbnd, wg USE uspp_param, ONLY : nh USE ions_base, ONLY : ityp USE control_lr, ONLY : ofsbeta USE ldaU_ph, ONLY : proj1, projpb, projpdb USE klist, ONLY : ngk, igk_k USE qpoint, ONLY : ikks, ikqs USE doubleprojqq_module USE term_one_1_module ! IMPLICIT NONE ! INTEGER, INTENT(IN) :: ik, icart, jcart, na, nap, nah, ihubst1, ihubst2 COMPLEX(DP), INTENT(IN) :: evc_(:,:), & ! (npwx,nbnd) wfcatomk(:,:), & ! (npwx,nwfcU) swfcatomk(:,:), & ! (npwx,nwfcU) vkb_(:,:), & ! (npwx,nkb) vkbkpq_(:,:), & ! (npwx,nkb) dvkb_(:,:,:), & ! (npwx,nkb,3) dvkbkpq_(:,:,:), & ! (npwx,nkb,3) dwfcatomkpq_(:,:,:) ! (npwx,nwfcU,3) COMPLEX(DP), INTENT(INOUT) :: res_one ! ! Local variables ! INTEGER :: npw, npwq, ikk, ikq, ibnd, nt, l1, l2, l, ibeta COMPLEX(DP), ALLOCATABLE :: dpqq(:), dpqq1(:), dpqq2(:), dpqq3(:), dpqq4(:), d2vkb(:,:) COMPLEX(DP) :: resone_1, resone_2,resone_3, resone_4, resone_5, & resone_6_9 ! res_one = 0.d0 ! ALLOCATE(dpqq(nbnd)) ALLOCATE(dpqq1(nbnd)) ALLOCATE(dpqq2(nbnd)) ALLOCATE(dpqq3(nbnd)) ALLOCATE(dpqq4(nbnd)) ALLOCATE(d2vkb(npwx,nkb)) ! ikk = ikks(ik) ikq = ikqs(ik) npw = ngk(ikk) npwq= ngk(ikq) ! ! In the diagonal approximation J=HUBBARD_I, ! all terms are such that na=nap=nah ! IF ((na==nap) .AND. (nah==na)) THEN ! term_one_1 contains a delta_na_nap ! ! Calculate term_one_1 ! CALL term_one_1 (ik, icart, jcart, evc_, wfcatomk(:,ihubst1), & proj1(:,ihubst2), vkb_, resone_1) ! res_one = res_one + resone_1 ! ! USPP case ! IF (okvan) THEN ! ! Calculate term_one_2 ! resone_2 = (0.d0, 0.d0) ! CALL doubleprojqq2 (na, projpdb(:,:,icart), vkbkpq_, & dwfcatomkpq_(:,ihubst1,jcart), npwq, dpqq) ! DO ibnd = 1, nbnd resone_2 = resone_2 + wg(ibnd,ikk) * dpqq(ibnd) * proj1(ibnd,ihubst2) ENDDO ! res_one = res_one + CONJG(resone_2) ! ! Calculate term_one_3 ! resone_3 = (0.d0, 0.d0) ! CALL doubleprojqq2 (na, projpb, dvkbkpq_(:,:,icart), & dwfcatomkpq_(:,ihubst1,jcart), npwq, dpqq) ! DO ibnd = 1, nbnd resone_3 = resone_3 + wg(ibnd,ikk) * dpqq(ibnd) * proj1(ibnd,ihubst2) ENDDO ! res_one = res_one + CONJG(resone_3) ! ! Calculate term_one_4 ! resone_4 = (0.d0, 0.d0) ! CALL doubleprojqq2 (nap, projpdb(:,:,jcart), vkbkpq_, & dwfcatomkpq_(:,ihubst1,icart), npwq, dpqq) ! DO ibnd = 1, nbnd resone_4 = resone_4 + wg(ibnd,ikk) * dpqq(ibnd) * proj1(ibnd,ihubst2) ENDDO ! res_one = res_one + resone_4 ! ! Calculate term_one_5 ! resone_5 = (0.d0, 0.d0) ! CALL doubleprojqq2 (nap, projpb, dvkbkpq_(:,:,jcart), & dwfcatomkpq_(:,ihubst1,icart), npwq, dpqq) ! DO ibnd = 1, nbnd resone_5 = resone_5 + wg(ibnd,ikk) * dpqq(ibnd) * proj1(ibnd,ihubst2) ENDDO ! res_one = res_one + resone_5 ! resone_6_9 = (0.d0, 0.d0) ! d2vkb = (0.d0, 0.d0) ! nt = ityp(na) ! DO l = 1, nh(nt) ! ibeta = ofsbeta(na) + l ! ! Calculate the 2nd derivative of the beta functions ! for all l states of atom na ! CALL d2wfc (npw, igk_k(1,ikk), ikk, icart, jcart, & vkb_(:,ibeta), d2vkb(:,ibeta)) ! ! d2vkb is always the 2nd derivative at icart and jcart, ! displacing the atom na and looking at the beta of atom j=na_ ! ENDDO ! ! doubleprojqq, unlike doubleprojqq2, calculates the first proj1 inside ! CALL doubleprojqq (na, evc_, d2vkb, vkb_, wfcatomk(:,ihubst1), & npw, npw, dpqq1) ! CALL doubleprojqq2 (na, projpb, d2vkb, wfcatomk(:,ihubst1), & npw, dpqq2) ! CALL doubleprojqq2 (na, projpdb(:,:,icart), dvkb_(:,:,jcart), & wfcatomk(:,ihubst1), npw, dpqq3) ! CALL doubleprojqq2 (na, projpdb(:,:,jcart), dvkb_(:,:,icart), & wfcatomk(:,ihubst1), npw, dpqq4) ! DO ibnd = 1, nbnd resone_6_9 = resone_6_9 + ( dpqq1(ibnd) + dpqq2(ibnd) + & dpqq3(ibnd) + dpqq4(ibnd) ) * & proj1(ibnd,ihubst2) * wg(ibnd,ikk) ENDDO ! res_one = res_one + resone_6_9 ! ENDIF ! ENDIF ! DEALLOCATE(dpqq) DEALLOCATE(dpqq1) DEALLOCATE(dpqq2) DEALLOCATE(dpqq3) DEALLOCATE(dpqq4) DEALLOCATE(d2vkb) ! RETURN ! END SUBROUTINE term_one_diag !------------------------------------------------------------------------ END MODULE term_one_module !------------------------------------------------------------------------ !------------------------------------------------------------------------- MODULE term_three_module !------------------------------------------------------------------------- USE mp_pools, ONLY : intra_pool_comm USE mp, ONLY : mp_sum ! CONTAINS ! !------------------------------------------------------------------------- SUBROUTINE term_three (ik, icart, jcart, na, nap, nah, ihubst1, ihubst2, & evc_, wfcatomk, dwfcatomk, vkb_, dvkb_, wfcatomkpq, & vkbkpq_, dvkbkpq_, res_three) !----------------------------------------------------------------------- ! USE kinds, ONLY : DP USE uspp, ONLY : vkb, nkb, okvan USE wvfct, ONLY : npwx, nbnd, wg USE ldaU, ONLY : nwfcU USE ldaU_ph, ONLY : projpb, projpdb USE klist, ONLY : ngk, igk_k USE qpoint, ONLY : ikks, ikqs USE doubleprojqq_module USE term_three_1_module ! IMPLICIT NONE ! INTEGER, INTENT(IN) :: ik, icart, jcart, na, nap, nah, ihubst1, ihubst2 COMPLEX(DP), INTENT(IN) :: evc_(:,:), & ! (npwx,nbnd) wfcatomk(:,:), & ! (npwx,nwfcU) dwfcatomk(:,:,:), & ! (npwx,nwfcU,3) vkb_(:,:), & ! (npwx,nkb) dvkb_(:,:,:), & ! (npwx,nkb,3) wfcatomkpq(:,:), & ! (npwx,nwfcU) vkbkpq_(:,:), & ! (npwx,nkb) dvkbkpq_(:,:,:) ! (npwx,nkb,3) COMPLEX(DP), INTENT(INOUT) :: res_three ! ! Local variables ! INTEGER :: npw, npwq, ikk, ikq, icar, ibnd COMPLEX(DP) :: resthree_1, resthree_2, resthree_3, resthree_4 COMPLEX(DP), ALLOCATABLE :: sdwfcatomk(:,:,:), projdphi(:,:,:), & dpqq1(:), dpqq2(:), dpqq3(:), & dpqq4(:), aux(:), aux2(:) COMPLEX(DP), EXTERNAL :: ZDOTC ! ALLOCATE (sdwfcatomk(npwx,nwfcU,3)) ALLOCATE (projdphi(nbnd,nwfcU,3)) ALLOCATE (dpqq1(nbnd)) ALLOCATE (dpqq2(nbnd)) ALLOCATE (dpqq3(nbnd)) ALLOCATE (dpqq4(nbnd)) ALLOCATE (aux(nbnd)) ALLOCATE (aux2(nbnd)) ! res_three=0.d0 ! ikk = ikks(ik) ikq = ikqs(ik) npw = ngk(ikk) npwq= ngk(ikq) ! DO icar = 1, 3 IF ((icar==icart) .OR. (icar==jcart)) THEN ! we want only icart jcart ! ! Calculate | S d^{icar} \phi_(k,I,m) > ! CALL swfc (npw, 1, vkb_, dwfcatomk(:,ihubst1,icar), sdwfcatomk(:,ihubst1,icar)) ! ! Calculate | S d^{icar} \phi_(k,I,m') > ! CALL swfc (npw, 1, vkb_, dwfcatomk(:,ihubst2,icar), sdwfcatomk(:,ihubst2,icar)) ! ! Calculate projdphi(ibnd) = < psi(inbd,k) | S d_^(I,icart) \phi_(k,I,m) > ! at ihubst1 (i.e. I m). ! DO ibnd = 1, nbnd projdphi(ibnd, ihubst1, icar) = & ZDOTC (npw, evc_(:,ibnd), 1, sdwfcatomk(:,ihubst1,icar), 1) projdphi(ibnd, ihubst2, icar) = & ZDOTC (npw, evc_(:,ibnd), 1, sdwfcatomk(:,ihubst2,icar), 1) ENDDO ! ENDIF ENDDO ! CALL mp_sum(projdphi, intra_pool_comm) ! ! Calculate term_three_1 ! IF ((na==nap) .AND. (nah==na)) THEN ! resthree_1 = (0.d0, 0.d0) ! CALL term_three_1 (ik, icart, jcart, ihubst1, ihubst2, projdphi, resthree_1) ! res_three = res_three + resthree_1 ! ENDIF ! ! USPP case ! IF (okvan) THEN ! ! Calculate term_three_2 ! resthree_2 = (0.d0, 0.d0) ! CALL doubleprojqq2 (na, projpdb(:,:,icart), vkbkpq_, wfcatomkpq(:,ihubst1), & npwq, dpqq1) ! CALL doubleprojqq2 (na, projpb, dvkbkpq_(:,:,icart), wfcatomkpq(:,ihubst1), & npwq, dpqq2) ! aux = dpqq1 + dpqq2 ! CALL doubleprojqq2 (nap, projpdb(:,:,jcart), vkbkpq_, wfcatomkpq(:,ihubst2), & npwq, dpqq3) ! CALL doubleprojqq2 (nap, projpb, dvkbkpq_(:,:,jcart), wfcatomkpq(:,ihubst2), & npwq, dpqq4) ! aux2 = dpqq3 + dpqq4 ! DO ibnd = 1, nbnd resthree_2 = resthree_2 + wg(ibnd,ikk) * CONJG(aux(ibnd)) * aux2(ibnd) ENDDO ! res_three = res_three + resthree_2 ! ! Calculate term_three_3 ! IF (nah == na) THEN ! resthree_3 = (0.d0, 0.d0) ! ! Calculate \sum {l1 l2} [ < psi | \beta(k,na_,l1) > qq(na_, l1 ,l2) * & ! < \dbeta^jcar(k+q,na_,l2) | phi_(k+q,nah,m) > ] ! CALL doubleprojqq2 (nap, projpb, dvkbkpq_(:,:,jcart), wfcatomkpq(:,ihubst2), & npwq, dpqq1) ! ! Calculate \sum {l1 l2} [ < psi| \dbeta^jcar_(k,na_,l1)> qq(na_, l1 ,l2) * & ! < \beta_(k+q,na_,l2) | phi_(k+q,nah,m) > ] ! CALL doubleprojqq2 (nap, projpdb(:,:,jcart), vkbkpq_, wfcatomkpq(:,ihubst2), & npwq, dpqq2) ! DO ibnd = 1, nbnd resthree_3 = resthree_3 + wg(ibnd,ikk) * (dpqq1(ibnd)+dpqq2(ibnd)) * & CONJG(projdphi(ibnd,ihubst1,icart)) ENDDO ! res_three = res_three + resthree_3 ! ENDIF ! ! Calculate term_three_4 ! IF (nah == nap) THEN ! resthree_4 = (0.d0, 0.d0) ! CALL doubleprojqq2 (na, projpb, dvkbkpq_(:,:,icart), wfcatomkpq(:,ihubst1), & npwq, dpqq2) ! CALL doubleprojqq2 (na, projpdb(:,:,icart), vkbkpq_, wfcatomkpq(:,ihubst1), & npwq, dpqq1) ! DO ibnd = 1, nbnd resthree_4 = resthree_4 + wg(ibnd,ikk) * (CONJG(dpqq1(ibnd))+CONJG(dpqq2(ibnd))) * & projdphi(ibnd,ihubst2,jcart) ENDDO ! res_three = res_three + resthree_4 ! ENDIF ! ENDIF ! DEALLOCATE (sdwfcatomk) DEALLOCATE (projdphi) DEALLOCATE (dpqq1) DEALLOCATE (dpqq2) DEALLOCATE (dpqq3) DEALLOCATE (dpqq4) DEALLOCATE (aux) DEALLOCATE (aux2) ! RETURN ! END SUBROUTINE term_three !-------------------------------------------------------------------------------- !-------------------------------------------------------------------------------- SUBROUTINE term_three_diag (ik, icart, jcart, na, nap, nah, ihubst1, ihubst2, & evc_, wfcatomk, dwfcatomk, vkb_, dvkb_, wfcatomkpq, & vkbkpq_, dvkbkpq_, res_three) !------------------------------------------------------------------------------ ! USE kinds, ONLY : DP USE uspp, ONLY : vkb, nkb, okvan USE wvfct, ONLY : npwx, nbnd, wg USE ldaU, ONLY : nwfcU USE ldaU_ph, ONLY : projpb, projpdb USE klist, ONLY : ngk, igk_k USE qpoint, ONLY : ikks, ikqs USE doubleprojqq_module USE term_three_1_module IMPLICIT NONE ! INTEGER, INTENT(IN) :: ik, icart, jcart, na, nap, nah, ihubst1, ihubst2 COMPLEX(DP), INTENT(IN) :: evc_(:,:), & ! (npwx,nbnd) wfcatomk(:,:), & ! (npwx,nwfcU) dwfcatomk(:,:,:), & ! (npwx,nwfcU,3) vkb_(:,:), & ! (npwx,nkb) dvkb_(:,:,:), & ! (npwx,nkb,3) wfcatomkpq(:,:), & ! (npwx,nwfcU) vkbkpq_(:,:), & ! (npwx,nkb) dvkbkpq_(:,:,:) ! (npwx,nkb,3) COMPLEX(DP), INTENT(INOUT) :: res_three ! ! Local variables ! INTEGER :: ikk, ikq, npw, npwq, icar, ibnd COMPLEX(DP) :: resthree_1, resthree_2, resthree_3, resthree_4 COMPLEX(DP), ALLOCATABLE :: sdwfcatomk(:,:,:), projdphi(:,:,:), & dpqq1(:), dpqq2(:), dpqq3(:), dpqq4(:), & aux(:), aux2(:) COMPLEX(DP), EXTERNAL :: ZDOTC ! ALLOCATE (sdwfcatomk(npwx,nwfcU,3)) ALLOCATE (projdphi(nbnd,nwfcU,3)) ALLOCATE (dpqq1(nbnd)) ALLOCATE (dpqq2(nbnd)) ALLOCATE (dpqq3(nbnd)) ALLOCATE (dpqq4(nbnd)) ALLOCATE (aux(nbnd)) ALLOCATE (aux2(nbnd)) ! res_three = 0.d0 ! ikk = ikks(ik) ikq = ikqs(ik) npw = ngk(ikk) npwq= ngk(ikq) ! DO icar = 1, 3 IF ((icar == icart) .OR. (icar == jcart)) THEN ! we want only icart jcart ! ! Calculate | S d^{icar} \phi_(k,I,m) > ! CALL swfc (npw, 1, vkb_, dwfcatomk(:,ihubst1,icar), sdwfcatomk(:,ihubst1,icar)) ! ! Calculate | S d^{icar} \phi_(k,I,m') > ! CALL swfc (npw, 1, vkb_, dwfcatomk(:,ihubst2,icar), sdwfcatomk(:,ihubst2,icar)) ! ! Calculate projdphi(ibnd) = < \psi(inbd,k) | S d_^(I,icart) \phi_(k,I,m) > ! at ihubst1 (i.e. I m). ! DO ibnd = 1, nbnd projdphi(ibnd, ihubst1, icar) = & & ZDOTC (npw, evc_(:,ibnd), 1, sdwfcatomk(:,ihubst1,icar), 1) projdphi(ibnd, ihubst2, icar) = & & ZDOTC (npw, evc_(:,ibnd), 1, sdwfcatomk(:,ihubst2,icar), 1) ENDDO ! ENDIF ENDDO ! CALL mp_sum(projdphi, intra_pool_comm) ! IF ((na==nap) .AND. (nah==na)) THEN ! ! Calculate term_three_1 ! resthree_1 = (0.d0, 0.d0) ! CALL term_three_1 (ik, icart, jcart, ihubst1, ihubst2, projdphi, resthree_1) ! res_three = res_three + resthree_1 ! ! USPP case ! IF (okvan) THEN ! ! Calculate term_three_2 ! resthree_2 = (0.d0, 0.d0) ! CALL doubleprojqq2 (na, projpdb(:,:,icart), vkbkpq_, wfcatomkpq(:,ihubst1), & npwq, dpqq1) ! CALL doubleprojqq2 (na, projpb, dvkbkpq_(:,:,icart), wfcatomkpq(:,ihubst1), & npwq, dpqq2) ! aux = dpqq1 + dpqq2 ! CALL doubleprojqq2 (nap, projpdb(:,:,jcart), vkbkpq_, wfcatomkpq(:,ihubst2), & npwq, dpqq3) ! CALL doubleprojqq2 (nap, projpb, dvkbkpq_(:,:,jcart), wfcatomkpq(:,ihubst2), & npwq, dpqq4) ! aux2 = dpqq3 + dpqq4 ! DO ibnd = 1, nbnd resthree_2 = resthree_2 + wg(ibnd,ikk) * CONJG(aux(ibnd)) * aux2(ibnd) ENDDO ! res_three = res_three + resthree_2 ! ! Calculate term_three_3 ! resthree_3 = (0.d0, 0.d0) ! ! Calculate \sum {l1 l2} [ < psi | \beta(k,na_,l1) > qq_nt(na_, l1 ,l2) * & ! < \dbeta^jcar(k+q ,na_,l2) | phi_(k+q,nah,m) > ] ! CALL doubleprojqq2 (nap, projpb, dvkbkpq_(:,:,jcart), wfcatomkpq(:,ihubst2), & npwq, dpqq1) ! ! Calculate \sum {l1 l2} [ < psi | \dbeta^jcar_(k,na_,l1)> qq_nt(na_, l1 ,l2) * & ! < \beta_(k+q,na_,l2) | phi_(k+q,nah,m) > ] ! CALL doubleprojqq2 (nap, projpdb(:,:,jcart), vkbkpq_, wfcatomkpq(:,ihubst2), & npwq, dpqq2) ! DO ibnd = 1, nbnd resthree_3 = resthree_3 + wg(ibnd,ikk) * (dpqq1(ibnd)+dpqq2(ibnd)) * & CONJG(projdphi(ibnd,ihubst1,icart)) ENDDO ! res_three = res_three + resthree_3 ! ! Calculate term_three_4 ! resthree_4 = (0.d0, 0.d0) ! CALL doubleprojqq2 (na, projpb, dvkbkpq_(:,:,icart), wfcatomkpq(:,ihubst1), & npwq, dpqq2) ! CALL doubleprojqq2 (na, projpdb(:,:,icart), vkbkpq_, wfcatomkpq(:,ihubst1), & npwq, dpqq1) ! DO ibnd = 1, nbnd resthree_4 = resthree_4 + wg(ibnd,ikk) * (CONJG(dpqq1(ibnd))+CONJG(dpqq2(ibnd))) * & projdphi (ibnd,ihubst2,jcart) ENDDO ! res_three = res_three + resthree_4 ! ENDIF ! ENDIF ! DEALLOCATE (sdwfcatomk) DEALLOCATE (projdphi) DEALLOCATE (dpqq1) DEALLOCATE (dpqq2) DEALLOCATE (dpqq3) DEALLOCATE (dpqq4) DEALLOCATE (aux) DEALLOCATE (aux2) ! RETURN ! END SUBROUTINE term_three_diag !-------------------------------------------------------- END MODULE term_three_module !-------------------------------------------------------- !------------------------------------------------------------ MODULE d2nsq_bare_module !------------------------------------------------------------ ! CONTAINS ! !------------------------------------------------------------ SUBROUTINE d2nsq_bare_k (ik, icart, jcart, na, nap, nah, & & ihubst1, ihubst2, d2ns_bare_k) !--------------------------------------------------------- ! ! DFPT+U: This routine calculates the second bare derivative ! of the occupation matrix ns. ns is derived ! two times w.r.t. the atomic positions, using the ! unperturbed wfc's ! ! Written by A. Floris ! Modified by I. Timrov (01.10.2018) ! USE kinds, ONLY : DP USE units_lr, ONLY : iuwfc, lrwfc USE ions_base, ONLY : nat, ityp, ntyp => nsp USE klist, ONLY : xk, ngk, igk_k USE ldaU_ph, ONLY : wfcatomk, swfcatomk, wfcatomkpq, dwfcatomk, dwfcatomkpq, & dvkb, vkbkpq, dvkbkpq, proj1, d2ns_type USE wvfct, ONLY : npwx, nbnd, wg USE uspp, ONLY : vkb, nkb USE qpoint, ONLY : nksq, ikks, ikqs USE control_lr, ONLY : lgamma USE uspp_param, ONLY : nh USE lsda_mod, ONLY : lsda, isk, nspin USE io_global, ONLY : stdout USE wavefunctions, ONLY : evc USE term_one_module USE term_three_module ! IMPLICIT NONE ! INTEGER, INTENT(IN) :: ik, icart, jcart, na, nap, nah, ihubst1, ihubst2 COMPLEX(DP), INTENT(INOUT) :: d2ns_bare_k ! k point index ! cartesian component ! cartesian component ! displaced atom index ! displaced atom index ! hubbard atom index ! atomic state ! atomic state ! second bare derivative of the occupation matrix ! ! Local variables ! INTEGER :: ikk, ikq, npw, npwq, icar, & nt, ic, nti, ina, ih, ibeta, ibnd COMPLEX(DP) :: res_one, res_two, res_three, res_four ! CALL start_clock( 'd2nsq_bare_k' ) ! ikk = ikks(ik) ikq = ikqs(ik) npw = ngk(ikk) npwq= ngk(ikq) ! d2ns_bare_k = (0.d0, 0.d0) ! ! Calculate the derivatives of atomic functions at k and k+q ! DO icar = 1, 3 ! IF ( (icar == icart) .OR. (icar == jcart)) THEN ! we want only icart jcart ! IF ((nah == na) .OR. (nah == nap)) THEN ! we want only dphi at na or nap ! ! Calculate |d_icart\phi_(k,I,m))> ! CALL dwfc (npw, igk_k(1,ikk), ikk, icar, & wfcatomk(:,ihubst1), dwfcatomk(:,ihubst1,icar)) ! ! Calculate |d_icart\phi_(k,I,m')> ! CALL dwfc (npw, igk_k(1,ikk), ikk, icar, & wfcatomk(:,ihubst2), dwfcatomk(:,ihubst2,icar)) ! IF (.NOT.lgamma) THEN ! ! Calculate |d_icart\phi_(k+q,I,m))> ! CALL dwfc (npwq, igk_k(1,ikq), ikq, icar, & wfcatomkpq(:,ihubst1), dwfcatomkpq(:,ihubst1,icar)) ! ! Calculate |d_icart\phi_(k+q,I,m'))> ! CALL dwfc (npwq, igk_k(1,ikq), ikq, icar, & wfcatomkpq(:,ihubst2), dwfcatomkpq(:,ihubst2,icar)) ! ENDIF ! ENDIF ! ENDIF ! ENDDO ! !-------------------- term1 ------------------------------------------ ! CALL term_one (ik, icart, jcart, na, nap, nah, ihubst1, ihubst2, & evc, wfcatomk, swfcatomk, vkb, vkbkpq, dvkb, & dvkbkpq, dwfcatomkpq, res_one) ! d2ns_bare_k = d2ns_bare_k + res_one ! IF (d2ns_type == 'fmmp') THEN ! ! fmmp approximation, we just have a factor of 2 ! for both term_one and term_three, ! without recalculating term_two and term_four. ! d2ns_bare_k = d2ns_bare_k + res_one ! ELSE ! ! term2 = term1 with the exchange of indices m <=> m' ! IF (ihubst1==ihubst2) THEN d2ns_bare_k = d2ns_bare_k + res_one ELSE CALL term_one (ik, icart, jcart, na, nap, nah, ihubst2, ihubst1, & evc, wfcatomk, swfcatomk, vkb, vkbkpq, dvkb, & dvkbkpq, dwfcatomkpq, res_two) d2ns_bare_k = d2ns_bare_k + res_two ENDIF ! ENDIF ! !-------------------- term3 ------------------------------------------ ! CALL term_three (ik, icart, jcart, na, nap, nah, ihubst1, ihubst2, & evc, wfcatomk, dwfcatomk, vkb, dvkb, wfcatomkpq, vkbkpq, & dvkbkpq, res_three) ! d2ns_bare_k = d2ns_bare_k + res_three ! IF (d2ns_type == 'fmmp') THEN ! ! fmmp approximation, we just have a factor of 2 ! for both term_one and term_three, ! without recalculating term_two and term_four. ! d2ns_bare_k = d2ns_bare_k + res_three ! ELSE ! ! term4 = term3 with the exchange of indices m <=> m' ! IF (ihubst1==ihubst2) THEN d2ns_bare_k = d2ns_bare_k + res_three ELSE CALL term_three (ik, icart, jcart, na, nap, nah, ihubst2, ihubst1, & evc, wfcatomk, dwfcatomk, vkb, dvkb, wfcatomkpq, vkbkpq, & dvkbkpq, res_four) d2ns_bare_k = d2ns_bare_k + res_four ENDIF ! ENDIF ! CALL stop_clock( 'd2nsq_bare_k' ) ! RETURN ! END SUBROUTINE d2nsq_bare_k !------------------------------------------------------------------ !------------------------------------------------------------------ SUBROUTINE d2nsq_bare_k_diag (ik, icart, jcart, na, nap, nah, & & ihubst1, ihubst2, d2ns_bare_k) !-------------------------------------------------------------- ! ! DFPT+U: This routine calculates the second bare derivative ! of the occupation matrix ns. ns is derived ! two times w.r.t. the atomic positions, using the ! unperturbed wfc's. ! This routines does an approximate calculation. ! ! d2ns_type='diag': if okvan=.true. the d2ns_bare matrix ! is calculated retaining only ! the <\beta_J|\phi_I> products on the ! same atomic site, i.e. for J==I. ! WARNING: Check against 'full' ! ! d2ns_type='dmmp': same as 'diag', but also assuming a m <=> m' ! symmetry in the various contributions of ! the d2ns_bare_k matrix. ! WARNING: Check against 'full' ! ! Written by A. Floris ! Modified by I. Timrov (01.10.2018) ! USE kinds, ONLY : DP USE units_lr, ONLY : iuwfc, lrwfc USE ions_base, ONLY : nat, ityp, ntyp => nsp USE klist, ONLY : xk, ngk, igk_k USE ldaU_ph, ONLY : wfcatomk, swfcatomk, wfcatomkpq, dwfcatomk, dwfcatomkpq, & dvkb, vkbkpq, dvkbkpq, proj1, d2ns_type USE wvfct, ONLY : npwx, nbnd, wg USE uspp, ONLY : vkb, nkb USE qpoint, ONLY : nksq, ikks, ikqs USE control_lr, ONLY : lgamma USE uspp_param, ONLY : nh USE lsda_mod, ONLY : lsda, isk, nspin USE io_global, ONLY : stdout USE wavefunctions, ONLY : evc USE term_one_module USE term_three_module ! IMPLICIT NONE ! INTEGER, INTENT(IN) :: ik, icart, jcart, na, nap, nah, ihubst1, ihubst2 COMPLEX(DP), INTENT(INOUT) :: d2ns_bare_k ! k point index ! cartesian component ! cartesian component ! displaced atom index ! displaced atom index ! hubbard atom index ! atomic state ! atomic state ! second bare derivative of the occupation matrix ! ! Local variables ! INTEGER :: ikk, ikq, npw, npwq, icar, nt, ic, nti, ina, ih, ibeta, ibnd COMPLEX(DP) :: res_one,res_two,res_three,res_four ! CALL start_clock( 'd2nsq_bare_k_diag' ) ! ikk = ikks(ik) ikq = ikqs(ik) npw = ngk(ikk) npwq= ngk(ikq) ! d2ns_bare_k = (0.d0, 0.d0) ! ! Calculate the derivatives of atomic functions at k and k+q ! DO icar = 1, 3 ! IF ((icar==icart) .OR. (icar==jcart)) THEN ! Wwe want only icart jcart ! In the diagonal approximation J=HUBBARD_I ! IF ((na == nah).AND. (nap == nah)) THEN ! we want only NA=NAP=NAH ! we want only dphi at na or nap ! ! Calculate |d_icart\phi_(k,I,m))> ! CALL dwfc (npw, igk_k(1,ikk), ikk, icar, & wfcatomk(:,ihubst1), dwfcatomk(:,ihubst1,icar)) ! ! Calculate |d_icart\phi_(k,I,m')> ! CALL dwfc (npw, igk_k(1,ikk), ikk, icar, & wfcatomk(:,ihubst2), dwfcatomk(:,ihubst2,icar)) ! IF (.NOT.lgamma) THEN ! ! Calculate |d_icart\phi_(k+q,I,m))> ! CALL dwfc (npwq, igk_k(1,ikq), ikq, icar, & wfcatomkpq(:,ihubst1), dwfcatomkpq(:,ihubst1,icar)) ! ! calculate |d_icart\fi_(k+q,I,m')) > ! CALL dwfc (npwq, igk_k(1,ikq), ikq, icar, & wfcatomkpq(:,ihubst2), dwfcatomkpq(:,ihubst2,icar)) ! ENDIF ! ENDIF ! ENDIF ! ENDDO ! !-------------------- term1 --------------------------------------------- ! CALL term_one_diag (ik, icart, jcart, na, nap, nah, ihubst1, ihubst2, & evc, wfcatomk, swfcatomk, vkb, vkbkpq, dvkb, & dvkbkpq, dwfcatomkpq, res_one) ! d2ns_bare_k = d2ns_bare_k + res_one ! IF (d2ns_type == 'dmmp') THEN ! ! dmmp approximation, we just have a factor of 2 ! for both term_one and term_three, ! without recalculating term_two and term_four. ! d2ns_bare_k = d2ns_bare_k + res_one ! ELSE ! ! term2 = term1 with the exchange of indices m <=> m' ! IF (ihubst1==ihubst2) THEN d2ns_bare_k = d2ns_bare_k + res_one ELSE CALL term_one_diag (ik, icart, jcart, na, nap, nah, ihubst2, ihubst1, & evc, wfcatomk, swfcatomk, vkb, vkbkpq, dvkb, & dvkbkpq, dwfcatomkpq, res_two) d2ns_bare_k = d2ns_bare_k + res_two ENDIF ! ENDIF ! !-------------------- term3 ------------------------------------------------- ! CALL term_three_diag (ik, icart, jcart, na, nap, nah, ihubst1, ihubst2, & evc, wfcatomk, dwfcatomk, vkb, dvkb, wfcatomkpq, vkbkpq, & dvkbkpq, res_three) ! d2ns_bare_k = d2ns_bare_k + res_three ! ! term4 = term3 with the exchange of indices m <=> m' ! IF (d2ns_type == 'dmmp') THEN ! ! dmmp approximation, we just have a factor of 2 ! for both term_one and term_three, ! without recalculating term_two and term_four. ! d2ns_bare_k = d2ns_bare_k + res_three ! ELSE ! IF (ihubst1==ihubst2) THEN d2ns_bare_k = d2ns_bare_k + res_three ELSE CALL term_three_diag (ik, icart, jcart, na, nap, nah, ihubst2, ihubst1, & evc, wfcatomk, dwfcatomk, vkb, dvkb, wfcatomkpq, vkbkpq, & dvkbkpq, res_four) d2ns_bare_k = d2ns_bare_k + res_four ENDIF ! ENDIF ! CALL stop_clock( 'd2nsq_bare_k_diag' ) ! RETURN ! END SUBROUTINE d2nsq_bare_k_diag !----------------------------------------------------------------------- END MODULE d2nsq_bare_module !-----------------------------------------------------------------------