From 290543465432b38b94df124a0046287fdfb3b934 Mon Sep 17 00:00:00 2001 From: dalcorso Date: Tue, 20 Oct 2009 13:46:17 +0000 Subject: [PATCH] Further cleanup using becp_type. git-svn-id: http://qeforge.qe-forge.org/svn/q-e/trunk/espresso@6057 c92efa57-630b-4861-b058-cf58834340f0 --- PH/add_for_charges.f90 | 103 +++++++++++++++++------------------------ 1 file changed, 42 insertions(+), 61 deletions(-) diff --git a/PH/add_for_charges.f90 b/PH/add_for_charges.f90 index f9d933657..049c3b736 100644 --- a/PH/add_for_charges.f90 +++ b/PH/add_for_charges.f90 @@ -21,7 +21,7 @@ subroutine add_for_charges (ik, uact) USE spin_orb, ONLY : lspinorb USE uspp, ONLY : nkb, qq, qq_so, vkb USE wvfct, ONLY : npwx, npw, nbnd, igk - USE becmod, ONLY: calbec + USE becmod, ONLY: calbec, bec_type, allocate_bec_type, deallocate_bec_type USE noncollin_module, ONLY : noncolin, npol USE uspp_param, only: nh USE eqv, ONLY : dvpsi, dpsi @@ -42,7 +42,7 @@ subroutine add_for_charges (ik, uact) ! integer :: na, nb, mu, nu, ikk, ikq, ig, igg, nt, ibnd, ijkb0, & - ikb, jkb, ih, jh, ipol, is + ikb, jkb, ih, jh, ipol, is, js, ijs ! counter on atoms ! counter on modes ! the point k @@ -65,22 +65,22 @@ subroutine add_for_charges (ik, uact) ! the scalar product ! the scalar product ! a mesh space for psi - complex(DP), allocatable :: bedp(:,:), aux1(:,:), alphapp(:,:,:) - complex(DP), allocatable :: bedp_nc(:,:,:), alphapp_nc(:,:,:,:) + TYPE(bec_type) :: bedp, alphapp(3) + complex(DP), allocatable :: aux1(:,:) logical :: ok ! used to save time allocate (aux ( npwx)) allocate (aux1( npwx*npol, nbnd)) + CALL allocate_bec_type(nkb,nbnd,bedp) + DO ipol=1,3 + CALL allocate_bec_type(nkb,nbnd,alphapp(ipol)) + ENDDO IF (noncolin) THEN - allocate (bedp_nc( nkb, npol, nbnd) ) - allocate (alphapp_nc (nkb, npol, nbnd,3)) allocate (ps1_nc ( nkb, npol, nbnd)) allocate (ps2_nc ( nkb, npol, nbnd , 3)) ELSE - allocate (bedp( nkb, nbnd) ) - allocate (alphapp (nkb,nbnd,3)) allocate (ps1 ( nkb , nbnd)) allocate (ps2 ( nkb , nbnd , 3)) ENDIF @@ -97,24 +97,24 @@ subroutine add_for_charges (ik, uact) if (noncolin) then ps1_nc = (0.d0, 0.d0) ps2_nc = (0.d0, 0.d0) - alphapp_nc = (0.d0,0.d0) - bedp_nc = (0.d0,0.d0) + bedp%nc = (0.d0,0.d0) + DO ipol=1,3 + alphapp(ipol)%nc = (0.d0,0.d0) + END DO else ps1 = (0.d0, 0.d0) ps2 = (0.d0, 0.d0) - alphapp = (0.d0,0.d0) - bedp = (0.d0,0.d0) + bedp%k = (0.d0,0.d0) + DO ipol=1,3 + alphapp(ipol)%k = (0.d0,0.d0) + END DO endif aux1 = (0.d0, 0.d0) ! ! first we calculate the products of the beta functions with dpsi ! - IF (noncolin) THEN - call calbec (npw, vkb, dpsi, bedp_nc) - ELSE - call calbec (npw, vkb, dpsi, bedp) - ENDIF + CALL calbec (npw, vkb, dpsi, bedp) do ipol = 1, 3 aux1=(0.d0,0.d0) do ibnd = 1, nbnd @@ -131,11 +131,7 @@ subroutine add_for_charges (ik, uact) enddo endif enddo - if (noncolin) then - call calbec ( npw, vkb, aux1, alphapp_nc(:,:,:,ipol) ) - else - call calbec ( npw, vkb, aux1, alphapp(:,:,ipol) ) - endif + CALL calbec ( npw, vkb, aux1, alphapp(ipol) ) enddo @@ -155,55 +151,41 @@ subroutine add_for_charges (ik, uact) do ibnd = 1, nbnd if (noncolin) then if (lspinorb) then - ps1_nc(ikb,1,ibnd)=ps1_nc(ikb,1,ibnd) + & - (qq_so (ih, jh, 1, nt) * & - alphapp_nc(jkb, 1, ibnd, ipol) + & - qq_so (ih, jh, 2, nt) * & - alphapp_nc(jkb, 2, ibnd, ipol) )* & - uact (mu + ipol) - ps1_nc(ikb,2,ibnd)=ps1_nc(ikb,2,ibnd) + & - (qq_so (ih, jh, 3, nt) * & - alphapp_nc(jkb, 1, ibnd, ipol) + & - qq_so (ih, jh, 4, nt) * & - alphapp_nc(jkb, 2, ibnd, ipol) )* & - uact (mu + ipol) - ps2_nc(ikb,1,ibnd,ipol)= & - ps2_nc(ikb,1,ibnd,ipol) + & - (qq_so (ih, jh, 1, nt) * & - bedp_nc (jkb, 1, ibnd) + & - qq_so (ih, jh, 2, nt) * & - bedp_nc (jkb, 2, ibnd) )*(0.d0,-1.d0) * & - uact (mu + ipol) * tpiba - ps2_nc(ikb,2,ibnd,ipol)= & - ps2_nc(ikb,2,ibnd,ipol) + & - (qq_so (ih, jh, 3, nt) * & - bedp_nc (jkb, 1, ibnd) + & - qq_so (ih, jh, 4, nt) * & - bedp_nc (jkb, 2, ibnd) )*(0.d0,-1.d0)* & - uact (mu + ipol) * tpiba + ijs=0 + DO is=1,npol + DO js=1,npol + ijs=ijs+1 + ps1_nc(ikb,is,ibnd)=ps1_nc(ikb,is,ibnd)+& + (qq_so (ih, jh, ijs, nt) * & + alphapp(ipol)%nc(jkb,js,ibnd))* & + uact (mu + ipol) + ps2_nc(ikb,is,ibnd,ipol)= & + ps2_nc(ikb,is,ibnd,ipol) + & + (qq_so (ih, jh, ijs, nt) * & + bedp%nc (jkb, js, ibnd))*(0.d0,-1.d0)* & + uact (mu + ipol) * tpiba + ENDDO + ENDDO else do is=1,npol ps1_nc(ikb,is,ibnd)=ps1_nc(ikb,is,ibnd) + & qq (ih, jh, nt) * & - alphapp_nc(jkb, is, ibnd, ipol) * & + alphapp(ipol)%nc(jkb, is, ibnd) * & uact (mu + ipol) ps2_nc(ikb,is,ibnd,ipol)= & ps2_nc(ikb,is, ibnd, ipol) + & qq (ih, jh, nt) * (0.d0, -1.d0) * & - bedp_nc (jkb, is, ibnd) * & + bedp%nc (jkb, is, ibnd) * & uact (mu + ipol) * tpiba end do endif else ps1 (ikb, ibnd) = ps1 (ikb, ibnd) + & - qq (ih, jh, nt) * & - alphapp(jkb, ibnd, ipol) * & + qq (ih, jh, nt)*alphapp(ipol)%k(jkb, ibnd)* & uact (mu + ipol) ps2 (ikb, ibnd, ipol) = ps2 (ikb, ibnd, ipol) + & - qq (ih, jh, nt) * & - (0.d0, -1.d0) * & - bedp (jkb, ibnd) * & - uact (mu + ipol) * tpiba + qq (ih, jh, nt) * (0.d0, -1.d0) * & + bedp%k(jkb, ibnd) *uact (mu + ipol) * tpiba endif enddo enddo @@ -270,17 +252,16 @@ subroutine add_for_charges (ik, uact) deallocate (aux) deallocate (aux1) IF (noncolin) THEN - deallocate (bedp_nc) - deallocate (alphapp_nc) deallocate (ps1_nc) deallocate (ps2_nc) ELSE - deallocate (bedp) - deallocate (alphapp) deallocate (ps1) deallocate (ps2) END IF + CALL deallocate_bec_type(bedp) + DO ipol=1,3 + CALL deallocate_bec_type(alphapp(ipol)) + END DO return end subroutine add_for_charges -