!=======================================================================
!
!  PROGRAM  PHASE/0 2014.03 ($Rev: 409 $)
!
!  MODULE: m_ES_LHXC
!
!  AUTHOR(S): T. Yamasaki   August/20/2003
!  
!  Contact address :  Phase System Consortium
!                     E-mail: phase_system@nims.go.jp URL https://azuma.nims.go.jp
!  
!
!
!=======================================================================
!
!     The original version of this set of the computer programs "PHASE"
!  was developed by the members of the Theory Group of Joint Research
!  Center for Atom Technology (JRCAT), based in Tsukuba, in the period
!  1993-2001.
!
!     Since 2002, this set has been tuned and new functions have been
!  added to it as a part of the national project "Frontier Simulation 
!  Software for Industrial Science (FSIS)",  which is supported by
!  the IT program of the Ministry of Education, Culture, Sports,
!  Science and Technology (MEXT) of Japan. 
!     Since 2006, this program set has been developed as a part of the
!  national project "Revolutionary Simulation Software (RSS21)", which
!  is supported by the next-generation IT program of MEXT of Japan.
!   Since 2013, this program set has been further developed centering on PHASE System
!  Consortium.
!   The activity of development of this program set has been supervised by Takahisa Ohno.
!
!
module m_ES_LHXC
! $Id: m_ES_LHXC.F90 409 2014-10-27 09:24:52Z jkoga $
  use m_Electronic_Structure, only : vlhxc_l, vloc_esm
  use m_PlaneWaveBasisSet,    only : kg,kgp,gr_l
  use m_PseudoPotential,      only : psc_l, ival
  use m_Ionic_System,         only : ntyp, zfm3_l
  use m_Timing,               only : tstatc0_begin, tstatc0_end
#ifdef ENABLE_ESM_PACK
  use m_Control_Parameters,   only : nspin, ipri,iprivlhxcq, kimg, sw_dipole_correction &
                                   , sw_screening_correction, sw_external_potential &
  &                                , sw_esm
#else
  use m_Control_Parameters,   only : nspin, ipri,iprivlhxcq, kimg, sw_dipole_correction &
                                   , sw_screening_correction, sw_external_potential 
#endif
  use m_Const_Parameters,     only : DP, PAI4, UP, DOWN, ON, OFF, CMPLDP
  use m_Parallelization,      only : ista_kngp, iend_kngp, mype, myrank_g, mpi_comm_group
  use m_Crystal_Structure,    only : univol
  use m_Dipole,               only : vdip_l, vext_l
  use m_Screening,            only : screening
  use m_External_Potential,   only : espot_g

! ========================== added by K. Tagami ===================== 11.0
  use m_Control_Parameters,   only : ndim_chgpot, ndim_magmom
! =================================================================== 11.0

  use m_Charge_Density,       only : chgq_l

  use m_FFT,                  only : fft_box_size_CD
  use m_PlaneWaveBasisSet,    only : igfp_l

implicit none
  include 'mpif.h'
!  61. m_ESlhxc_potential
contains

!=======================================================================
!=======================================================================
!=======================================================================
  subroutine m_ESlhxc_potential_3D(nfout,chg,vxc)
   use m_Dipole,               only : m_Dipole_potential_3D, m_Dipole_calc_3D 

    integer, intent(in)       :: nfout
    real(kind=DP), intent(in) :: chg(ista_kngp:iend_kngp,kimg,nspin)
    real(kind=DP), intent(in) :: vxc(ista_kngp:iend_kngp,kimg,nspin)

    complex(kind=CMPLDP),allocatable :: vhar(:)
    complex(kind=CMPLDP),allocatable, dimension(:,:) :: chgc
    real(kind=DP) :: ehar
    integer :: is,ik,i,it
    integer :: ist
    integer :: nfftcd,ierr,ig
    integer :: id_sname = -1

#ifdef __TIMER_SUB__
  call timer_sta(1050)
#endif
    call tstatc0_begin('m_ESlhxc_potential_3D ',id_sname)

    vlhxc_l = 0.d0
    ist = ista_kngp
    if(ist == 1) ist = 2
#ifdef ENABLE_ESM_PACK
    if(sw_esm==ON) then
       nfftcd = fft_box_size_CD(1,0)*fft_box_size_CD(2,0)*fft_box_size_CD(3,0)
       allocate(vhar(nfftcd));vhar=(0.d0,0.d0)
       allocate(chgc(iend_kngp-ista_kngp+1,nspin));chgc=(0.d0,0.d0)
       if(kimg==1)then
          do ig=ista_kngp,iend_kngp
             chgc(ig-ista_kngp+1,1:nspin) = dcmplx(chg(ig,1,1:nspin),0.d0)
          enddo
       else
          do ig=ista_kngp,iend_kngp
             chgc(ig-ista_kngp+1,1:nspin) = dcmplx(chg(ig,1,1:nspin),chg(ig,2,1:nspin))
          enddo
       endif
       call esm_hartree(chgc,ehar,vhar)
       vhar(:) = 0.5d0*vhar(:) !Ry -> Ha
       deallocate(chgc)
    endif
#endif
    do is = 1, nspin
       do ik = 1, kimg
#ifdef __TIMER_DO__
  call timer_sta(1064)
#endif
          if(myrank_g==0) vlhxc_l(1,ik,is)   = vxc(1,ik,is)
#ifdef ENABLE_ESM_PACK
          if(nspin == 1 .and. sw_esm==OFF) then
#else
          if(nspin == 1) then
#endif
             do i = ist, iend_kngp  !for mpi
                vlhxc_l(i,ik,is) = vxc(i,ik,is) &
                     & +PAI4*chg(i,ik,is)/gr_l(i)**2
             end do
#ifdef ENABLE_ESM_PACK
          else if(nspin == 2.and.sw_esm==OFF) then
#else
          else if(nspin == 2) then
#endif
             do i = ist, iend_kngp  !for mpi
                vlhxc_l(i,ik,is) = vxc(i,ik,is) &
                     & +PAI4*(chg(i,ik,UP)+chg(i,ik,DOWN))/gr_l(i)**2
             end do
#ifdef ENABLE_ESM_PACK
          else if (sw_esm == ON)then
             do i = ist, iend_kngp  !for mpi
                vlhxc_l(i,ik,is) = vxc(i,ik,is) 
             end do
#endif
          endif
#ifdef __TIMER_DO__
  call timer_end(1064)
#endif
#ifdef __TIMER_DO__
  call timer_sta(1065)
#endif
          do it    = 1,ntyp
             do i = ista_kngp, iend_kngp  !for mpi
                vlhxc_l(i,ik,is) &
                     & = vlhxc_l(i,ik,is)+psc_l(i,it)*zfm3_l(i,it,ik)
             end do
          end do
#ifdef ENABLE_ESM_PACK
          if(sw_esm==ON)then
             if(ik==1)then
                do i=ista_kngp,iend_kngp
                   vlhxc_l(i,1,is) = vlhxc_l(i,1,is)+dble(vhar(igfp_l(i)))+dble(vloc_esm(igfp_l(i)))
                enddo
             else if(ik==2) then
                do i=ista_kngp,iend_kngp
                   vlhxc_l(i,2,is) = vlhxc_l(i,2,is)+aimag(vhar(igfp_l(i)))+aimag(vloc_esm(igfp_l(i)))
                enddo
             endif
          endif
#endif
#ifdef __TIMER_DO__
  call timer_end(1065)
#endif
       end do
    end do
#ifdef ENABLE_ESM_PACK
    if(sw_esm==ON) then
       deallocate(vhar)
    endif
#endif
    if(sw_dipole_correction==ON) then
       call m_Dipole_calc_3D(nfout)
       call m_Dipole_potential_3D(nfout,chg)
#ifdef __TIMER_DO__
  call timer_sta(1066)
#endif
       do is = 1, nspin
          do ik = 1, kimg
             do i = ista_kngp, iend_kngp  !for mpi
                vlhxc_l(i,ik,is) = vlhxc_l(i,ik,is) + vdip_l(i,ik) + vext_l(i,ik)
             end do
          end do
       end do
#ifdef __TIMER_DO__
  call timer_end(1066)
#endif
    end if
    if(iprivlhxcq >= 2) call m_ESlhxc_wd_vlhxc_3D(nfout)
    call tstatc0_end(id_sname)
#ifdef __TIMER_SUB__
  call timer_end(1050)
#endif
  end subroutine m_ESlhxc_potential_3D

  subroutine m_ESlhxc_wd_vlhxc_3D(nfout)

    integer, intent(in) :: nfout
    integer :: ispin, i, is, ie, ri
#ifdef __TIMER_SUB__
  call timer_sta(1056)
#endif

    is = ista_kngp
    ie = min(is+20, iend_kngp)
    do ispin = 1, nspin
       if(nspin == 2) write(nfout,'(" !lhxc ispin = ",i5)') ispin
       write(nfout,'(" vlhxc_l")')
       do ri = 1, kimg
          if(kimg == 1 .and. ri == 1) write(nfout,*) '       real part'
          if(ri == 2)                 write(nfout,*) '       imaginary part'
          write(nfout,'(" ",4d20.12)') (vlhxc_l(i,ri,ispin),i=is,ie) ! MPI
       end do
    end do
#ifdef __TIMER_SUB__
  call timer_end(1056)
#endif
  end subroutine m_ESlhxc_wd_vlhxc_3D
!=======================================================================
end module m_ES_LHXC
