! @@@@@@@@@@@@@@@@@@@@@@@@@@@@@@@@@@@@@@@@@@@@@@@@@@@@@@@@@@@@@@@@@@@@ !
! @@                                                                @@ !
! @@       PROGRAM  ASCOT 2014.440 (ver.4.53)                       @@ !
! @@     "Abinitio Simulation Code for Quantum Transport"           @@ !
! @@                                                                @@ !
! @@                                                                @@ !
! @@  AUTHOR(S): Naoki WATANABE, Nobutaka NISHIKAWA (Mizuho I.R.)   @@ !
! @@             Hisashi KONDO (Univ. Tokyo)                        @@ !
! @@                                                09/May/2014     @@ !
! @@                                                                @@ !
! @@  Contact address: Phase System Consortium                      @@ !
! @@                                                                @@ !
! @@@@@@@@@@@@@@@@@@@@@@@@@@@@@@@@@@@@@@@@@@@@@@@@@@@@@@@@@@@@@@@@@@@@ !

subroutine Hartree__PhiK(PhiK,kk)
  use ac_parameter
  implicit none
  real(8), intent(in)  :: kk
  real(8), intent(out) :: PhiK

  if(kk<1.d-14) then
     PhiK = 0.d0
  else
     PhiK = 4.d0*M_PI/kk
  end if

  return
end subroutine Hartree__PhiK

subroutine HartreeLS__calcPotential( Ehar, Vhar, rhoLS, rhoval )
  use ac_parameter
  implicit none
  real(8), intent(out) :: Ehar
  real(8), intent(out) :: Vhar(Param%Cell%Na, Param%Cell%Nb, Param%Cell%Nc)
  complex(8), intent(in)  :: rhoLS(Param%Option%nspin,Param%Cell%Na, Param%Cell%Nb, Param%Cell%Nc)
  real(8), intent(in)  :: rhoval(Param%Cell%Na, Param%Cell%Nb, Param%Cell%Nc)

  integer :: ia, ib, ic
  integer :: ika, ikb, ikc
  real(8) :: kk
  real(8) :: K(3)
  real(8) :: phi, c
  real(8) :: rhoKr, rhoKi, workr, worki
  real(8), allocatable :: rhoK(:,:,:)   

  allocate( rhoK(2*(Param%Cell%Na/2+1),Param%Cell%Nb,Param%Cell%Nc) )

  if( Param%Option%na ) then
     do ic=1, Param%Cell%Nc
        do ib=1, Param%Cell%Nb
           do ia=1, Param%Cell%Na
              rhoK(ia,ib,ic) = &
                   dreal(rhoLS(1,ia,ib,ic)) + dreal(rhoLS(4,ia,ib,ic)) - rhoval(ia,ib,ic)
           end do
        end do
     end do
  else
     do ic=1, Param%Cell%Nc
        do ib=1, Param%Cell%Nb
           do ia=1, Param%Cell%Na
              rhoK(ia,ib,ic) = dreal(rhoLS(1,ia,ib,ic)) + dreal(rhoLS(4,ia,ib,ic))
           end do
        end do
     end do
  end if

  call RFFT3D__forward( &
       Param%Cell%Na, Param%Cell%Nb, Param%Cell%Nc, &
       rhoK, rhoK )

  Ehar = 0.d0
  c = 1.d0/(Param%Cell%Na*Param%Cell%Nb*Param%Cell%Nc)

  do ikc=1, Param%Cell%Nc
     do ikb=1, Param%Cell%Nb
        do ika=1, Param%Cell%Na/2+1
           call Param__Cell__K(K,ika,ikb,ikc)
           kk = dot_product(K,K)

           if( Param%Option%cluster ) then
              call Hartree__PhiK(phi,kk)
              phi = c*(phi+Screening%PhiK(2*ika-1,ikb,ikc))
           else
              call Hartree__PhiK(phi,kk)
              phi = c*phi
           end if

           rhoKr = rhoK(2*ika-1,ikb,ikc)
           rhoKi = rhoK(2*ika-0,ikb,ikc)
           workr = rhoKr*phi
           worki = rhoKi*phi

           if( ika == 1 ) then
              Ehar = Ehar + (rhoKr*workr+rhoKi*worki)
           else
              Ehar = Ehar + (rhoKr*workr+rhoKi*worki)*2
           end if

           rhoK(2*ika-1,ikb,ikc) = workr
           rhoK(2*ika-0,ikb,ikc) = worki
        end do
     end do
  end do

  call RFFT3D__backward( &
       Param%Cell%Na, Param%Cell%Nb, Param%Cell%Nc, &
       rhoK, Vhar )

  Ehar = Ehar*0.5d0*Param%Cell%dV

  deallocate( rhoK )

  return
end subroutine HartreeLS__calcPotential

subroutine Hartree__calcPotential( Ehar, Vhar, rho, rhoval )
  use ac_parameter
  implicit none
  real(8), intent(out) :: Ehar
  real(8), intent(out) :: Vhar(Param%Cell%Na, Param%Cell%Nb, Param%Cell%Nc)
  real(8), intent(in)  :: rho(Param%Option%nspin,Param%Cell%Na, Param%Cell%Nb, Param%Cell%Nc)
  real(8), intent(in)  :: rhoval(Param%Cell%Na, Param%Cell%Nb, Param%Cell%Nc)

  integer :: ia, ib, ic
  integer :: ika, ikb, ikc
  real(8) :: kk
  real(8) :: K(3)
  real(8) :: phi, c
  real(8) :: rhoKr, rhoKi, workr, worki
  real(8), allocatable :: rhoK(:,:,:)   

  allocate( rhoK(2*(Param%Cell%Na/2+1),Param%Cell%Nb,Param%Cell%Nc) )

  if( Param%Option%na ) then
     do ic=1, Param%Cell%Nc
        do ib=1, Param%Cell%Nb
           do ia=1, Param%Cell%Na
              rhoK(ia,ib,ic) = sum(rho(:,ia,ib,ic)) - rhoval(ia,ib,ic)
           end do
        end do
     end do
  else
     do ic=1, Param%Cell%Nc
        do ib=1, Param%Cell%Nb
           do ia=1, Param%Cell%Na
              rhoK(ia,ib,ic) = sum(rho(:,ia,ib,ic))
           end do
        end do
     end do
  end if

  call RFFT3D__forward( &
       Param%Cell%Na, Param%Cell%Nb, Param%Cell%Nc, &
       rhoK, rhoK )

  Ehar = 0.d0
  c = 1.d0/(Param%Cell%Na*Param%Cell%Nb*Param%Cell%Nc)

  do ikc=1, Param%Cell%Nc
     do ikb=1, Param%Cell%Nb
        do ika=1, Param%Cell%Na/2+1
           call Param__Cell__K(K,ika,ikb,ikc)
           kk = dot_product(K,K)

           if( Param%Option%cluster ) then
              call Hartree__PhiK(phi,kk)
              phi = c*(phi+Screening%PhiK(2*ika-1,ikb,ikc))
           else
              call Hartree__PhiK(phi,kk)
              phi = c*phi
           end if

           rhoKr = rhoK(2*ika-1,ikb,ikc)
           rhoKi = rhoK(2*ika-0,ikb,ikc)
           workr = rhoKr*phi
           worki = rhoKi*phi

           if( ika == 1 ) then
              Ehar = Ehar + (rhoKr*workr+rhoKi*worki)
           else
              Ehar = Ehar + (rhoKr*workr+rhoKi*worki)*2
           end if

           rhoK(2*ika-1,ikb,ikc) = workr
           rhoK(2*ika-0,ikb,ikc) = worki
        end do
     end do
  end do

  call RFFT3D__backward( &
       Param%Cell%Na, Param%Cell%Nb, Param%Cell%Nc, &
       rhoK, Vhar )

  Ehar = Ehar*0.5d0*Param%Cell%dV

  deallocate( rhoK )

  return
end subroutine Hartree__calcPotential

subroutine Hartree__calcEnergy1( Ehar, rhoval )
  use ac_parameter

  implicit none
  real(8), intent(out) :: Ehar
  real(8), intent(in)  :: rhoval(Param%Cell%Na, Param%Cell%Nb, Param%Cell%Nc)

  integer        :: ika, ikb, ikc
  real(8)  :: kk
  real(8) :: K(3)
  real(8)  :: phi, c
  real(8)  :: rhoKr, rhoKi, workr, worki
  integer :: ia, ib, ic

  real(8), allocatable :: rhoK(:,:,:)   

  allocate( rhoK(2*(Param%Cell%Na/2+1),Param%Cell%Nb,Param%Cell%Nc) )

  do ic=1, Param%Cell%Nc
     do ib=1, Param%Cell%Nb
        do ia=1, Param%Cell%Na
           rhoK(ia,ib,ic) = rhoval(ia,ib,ic)
        end do
     end do
  end do

  call RFFT3D__forward( &
       Param%Cell%Na, Param%Cell%Nb, Param%Cell%Nc, &
       rhoK, rhoK )

  Ehar = 0.d0
  c = 1.d0/(Param%Cell%Na*Param%Cell%Nb*Param%Cell%Nc)

  do ikc=1, Param%Cell%Nc
     do ikb=1, Param%Cell%Nb
        do ika=1, Param%Cell%Na/2+1
           call Param__Cell__K(K,ika,ikb,ikc)
           kk = dot_product(K,K)

           if( Param%Option%cluster ) then
              call Hartree__PhiK(phi,kk)
              phi = c*(phi+Screening%PhiK(2*ika-1,ikb,ikc))
           else
              call Hartree__PhiK(phi,kk)
              phi = c*phi
           end if

           rhoKr = rhoK(2*ika-1,ikb,ikc)
           rhoKi = rhoK(2*ika-0,ikb,ikc)
           workr = rhoKr*phi
           worki = rhoKi*phi

           if( ika == 1 ) then
              Ehar = Ehar + (rhoKr*workr+rhoKi*worki)
           else
              Ehar = Ehar + (rhoKr*workr+rhoKi*worki)*2
           end if
        end do
     end do
  end do

  Ehar = Ehar*0.5d0*Param%Cell%dV

  deallocate( rhoK )

  return
end subroutine Hartree__calcEnergy1

subroutine HartreeLS__calcEnergy2( Ehar, rhoLS )
  use ac_parameter

  implicit none
  real(8), intent(out) :: Ehar
  complex(8), intent(in)  :: rhoLS(Param%Option%nspin,Param%Cell%Na, Param%Cell%Nb, Param%Cell%Nc)

  integer :: ika, ikb, ikc
  real(8) :: kk
  real(8) :: K(3)
  real(8) :: phi, c
  real(8) :: rhoKr, rhoKi, workr, worki
  integer :: ia, ib, ic

  real(8), allocatable :: rhoK(:,:,:)   

  allocate( rhoK(2*(Param%Cell%Na/2+1),Param%Cell%Nb,Param%Cell%Nc) )

  do ic=1, Param%Cell%Nc
     do ib=1, Param%Cell%Nb
        do ia=1, Param%Cell%Na
           rhoK(ia,ib,ic) = dreal(rhoLS(1,ia,ib,ic)) + dreal(rhoLS(4,ia,ib,ic))
        end do
     end do
  end do

  call RFFT3D__forward( &
       Param%Cell%Na, Param%Cell%Nb, Param%Cell%Nc, &
       rhoK, rhoK )

  Ehar = 0.d0
  c = 1.d0/(Param%Cell%Na*Param%Cell%Nb*Param%Cell%Nc)

  do ikc=1, Param%Cell%Nc
     do ikb=1, Param%Cell%Nb
        do ika=1, Param%Cell%Na/2+1
           call Param__Cell__K(K,ika,ikb,ikc)
           kk = dot_product(K,K)

           if( Param%Option%cluster ) then
              call Hartree__PhiK(phi,kk)
              phi = c*(phi+Screening%PhiK(2*ika-1,ikb,ikc))
           else
              call Hartree__PhiK(phi,kk)
              phi = c*phi
           end if

           rhoKr = rhoK(2*ika-1,ikb,ikc)
           rhoKi = rhoK(2*ika-0,ikb,ikc)
           workr = rhoKr*phi
           worki = rhoKi*phi

           if( ika == 1 ) then
              Ehar = Ehar + (rhoKr*workr+rhoKi*worki)
           else
              Ehar = Ehar + (rhoKr*workr+rhoKi*worki)*2
           end if
        end do
     end do
  end do

  Ehar = Ehar*0.5d0*Param%Cell%dV

  deallocate( rhoK )

  return
end subroutine HartreeLS__calcEnergy2

subroutine Hartree__calcEnergy2( Ehar, rho )
  use ac_parameter

  implicit none
  real(8), intent(out) :: Ehar
  real(8), intent(in)  :: rho(Param%Option%nspin,Param%Cell%Na, Param%Cell%Nb, Param%Cell%Nc)

  integer :: ika, ikb, ikc
  real(8) :: kk
  real(8) :: K(3)
  real(8) :: phi, c
  real(8) :: rhoKr, rhoKi, workr, worki
  integer :: ia, ib, ic

  real(8), allocatable :: rhoK(:,:,:)   

  allocate( rhoK(2*(Param%Cell%Na/2+1),Param%Cell%Nb,Param%Cell%Nc) )

  if( Param%Option%spin_orbit ) then
     do ic=1, Param%Cell%Nc
        do ib=1, Param%Cell%Nb
           do ia=1, Param%Cell%Na
              rhoK(ia,ib,ic) = rho(1,ia,ib,ic) + rho(4,ia,ib,ic)
           end do
        end do
     end do
  else
     do ic=1, Param%Cell%Nc
        do ib=1, Param%Cell%Nb
           do ia=1, Param%Cell%Na
              rhoK(ia,ib,ic) = sum(rho(:,ia,ib,ic))
           end do
        end do
     end do
  end if

  call RFFT3D__forward( &
       Param%Cell%Na, Param%Cell%Nb, Param%Cell%Nc, &
       rhoK, rhoK )

  Ehar = 0.d0
  c = 1.d0/(Param%Cell%Na*Param%Cell%Nb*Param%Cell%Nc)

  do ikc=1, Param%Cell%Nc
     do ikb=1, Param%Cell%Nb
        do ika=1, Param%Cell%Na/2+1
           call Param__Cell__K(K,ika,ikb,ikc)
           kk = dot_product(K,K)

           if( Param%Option%cluster ) then
              call Hartree__PhiK(phi,kk)
              phi = c*(phi+Screening%PhiK(2*ika-1,ikb,ikc))
           else
              call Hartree__PhiK(phi,kk)
              phi = c*phi
           end if

           rhoKr = rhoK(2*ika-1,ikb,ikc)
           rhoKi = rhoK(2*ika-0,ikb,ikc)
           workr = rhoKr*phi
           worki = rhoKi*phi

           if( ika == 1 ) then
              Ehar = Ehar + (rhoKr*workr+rhoKi*worki)
           else
              Ehar = Ehar + (rhoKr*workr+rhoKi*worki)*2
           end if
        end do
     end do
  end do

  Ehar = Ehar*0.5d0*Param%Cell%dV

  deallocate( rhoK )

  return
end subroutine Hartree__calcEnergy2
