! @@@@@@@@@@@@@@@@@@@@@@@@@@@@@@@@@@@@@@@@@@@@@@@@@@@@@@@@@@@@@@@@@@@@ !
! @@                                                                @@ !
! @@       PROGRAM  ASCOT 2014.440 (ver.4.40)                       @@ !
! @@     "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 Energy__sort(nE,vE)
  use ac_misc_module
  implicit none
  integer, intent(in)  :: nE
  real(8), intent(out) :: vE(nE)

  integer :: spin
  integer :: k, n, m
  real(8) :: work

  if( Param%Option%spin_orbit ) then
     m=0
     do k=1, Param%SCF%nK
        do n=1, Base%npao*2
           m=m+1
           vE(m) = Hamiltonian%vBandMatrix(k)%E(n,1)
        end do
     end do
  else
     m=0
     do k=1, Param%SCF%nK
        do n=1, Base%npao
           do spin=1, Param%Option%nspin
              m=m+1
              vE(m) = Hamiltonian%vBandMatrix(k)%E(n,spin)
           end do
        end do
     end do
  end if

  do n=1, nE
     do m=n+1, nE
        if( vE(n) > vE(m) ) then
           work  = vE(n)
           vE(n) = vE(m)
           vE(m) = work
        end if
     end do
  end do

  return
end subroutine Energy__sort

subroutine Energy__fermifunc(f, E)
  use ac_misc_module

  implicit none
  real(8), intent(in) :: E
  real(8), intent(out) :: f

  real(8) :: cri,h

  if( Param%SCF%Te == 0.d0 ) then
     if( E <= Energy%Ef ) then
        f=1.d0
     else
        f=0.d0
     end if
     return
  end if

  cri=1.d+3
  h=0.5d0*(E-Energy%Ef)/Param%SCF%Te
  if( h > -cri .and. h < cri ) then
     f=0.5d0*(1.d0-tanh(h))
  else
     if( h < -cri ) then
        f=1.d0
     else
        f=0.d0
     end if
  end if

  return
end subroutine Energy__fermifunc

subroutine Energy__numberfunc(n,nE,vE)
  use ac_misc_module

  implicit none
  integer, intent(in)       :: nE
  real(8), intent(in) :: vE(nE)
  real(8), intent(out) :: n

  integer :: m
  real(8) :: eff

  n=0.d0
  do m=1, nE
     call Energy__fermifunc(eff, vE(m))
     n = n + Param%Data%g * eff
  end do
  n = n/Param%SCF%nK

  return
end subroutine Energy__numberfunc

subroutine Energy__findFermi(Ef,nE,vE)
  use ac_misc_module

  implicit none
  integer, intent(in)       :: nE
  real(8), intent(in) :: vE(nE)

  real(8), intent(out) :: Ef
  integer       :: i
  real(8) :: Ea, Eb
  real(8) :: Na, Nb, Nc, No

  integer       :: i_cou

  i = int((Param%SCF%nK*Param%Data%Ne-1.0)/Param%Data%g)+1

  Energy%Ef = vE(i)

  if( Param%SCF%Te == 0.d0 ) then
     Ef = Energy%Ef
     return
  end if

  No = Param%Data%Ne
  Ea = vE(1)
  Energy%Ef = Ea
  call Energy__numberfunc(Na,nE,vE)
  Eb = vE(nE)
  Energy%Ef = Eb
  call Energy__numberfunc(Nb,nE,vE)

  i_cou=0
  do while( .true. )
     if( Na == No ) then
        Energy%Ef = Ea
        exit
     end if
     if( Nb == No ) then
        Energy%Ef = Eb
        exit
     end if

     Energy%Ef = (Ea+Eb)*.5d0
     call Energy__numberfunc(Nc,nE,vE)

     if( Nc < No ) then
        Ea = Energy%Ef
        Na = Nc
     else
        Eb = Energy%Ef
        Nb = Nc
     end if

     i_cou=i_cou+1

     if( abs(Ea-Eb) < 1.0e-14 ) then
        exit
     end if
     if( i_cou > 50 ) then
        exit
     end if
  end do

  Ef = Energy%Ef

  return
end subroutine Energy__findFermi

subroutine Energy__calcOrbital(E,nE,vE)
  use ac_misc_module

  implicit none
  integer, intent(in)       :: nE
  real(8), intent(in) :: vE(nE)

  real(8),intent(out) :: E
  integer :: m

  real(8) :: eff

  E=0.d0
  do m=1, nE
     call Energy__fermifunc(eff,vE(m))
     E = E + Param%Data%g * eff * vE(m)
  end do
  E = E/Param%SCF%nK

  return
end subroutine Energy__calcOrbital

subroutine Energy__calcLattice(E)
  use ac_misc_module

  implicit none
  real(8), intent(out) :: E
  integer        :: l, i, j
  type(Element_type), pointer :: elemi
  type(Element_type), pointer :: elemj
  real(8) :: R(3)
  real(8)  :: dR
  type(PPcharge_type) :: rrhoval
  type(PPloc_type)    :: Vval
  real(8)  :: Ehar
  real(8)  :: ec_t,dbs_t

  E=0.d0
  if( Param%Option%na ) then
     do i=1, Param%Data%natom
        elemi => Param__Data__getElement( Param%Data%vatom(i)%name )
        call PPcharge__set( rrhoval, Param%Data%vatom(i)%Ro, elemi%rhoval )

        do j=1, Param%Data%natom
           elemj => Param__Data__getElement( Param%Data%vatom(j)%name )
           call PPloc__set(Vval, Param%Data%vatom(j)%Ro, elemj%Vval )

           do l=1-Param%Cell%nL, Param%Cell%nL-1 
              R = Param%Data%vatom(i)%Ro - Param%Data%vatom(j)%Ro &
                   - Param%Cell%vL(:,l)
              dR = sqrt(dot_product(R,R))

              if( dR > rrhoval%Rc + Vval%Rc ) cycle

              if( dabs(dR) > 1.d-14 ) then
                 E = E + 0.5d0*Param%Data%vatom(i)%Q * Param%Data%vatom(j)%Q / dR
              end if
              if( .not. Param%Option%cluster ) then
                 call Density__bracketS( dbs_t, rrhoval, Vval, Param%Cell%vL(:,l) )
                 E = E - 0.5d0*dbs_t
              end if
           end do
        end do
     end do

     if( .not. Param%Option%cluster ) then
        call Hartree__calcEnergy1( Ehar, Density%rhoval )
        E = E + Ehar
     end if
  else

     do i=1, Param%Data%natom 
        do j=i+1, Param%Data%natom
           R = Param%Data%vatom(i)%Ro - Param%Data%vatom(j)%Ro
           dR = sqrt(dot_product(R,R))
           E = E + Param%Data%vatom(i)%Q * Param%Data%vatom(j)%Q / dR
        end do
     end do

     if( .not. Param%Option%cluster ) then
        do i=1, Param%Data%natom
           do j=1, Param%Data%natom
              call Ewald__calc( ec_t, Param%Data%vatom(j)%Q, &
                   Param%Data%vatom(j)%Ro, Param%Data%vatom(i)%Ro )
              E = E + 0.5d0*Param%Data%vatom(i)%Q * ec_t
           end do
        end do
     end if

  end if

  return 
end subroutine Energy__calcLattice

subroutine Energy__calcInternal(E)
  use ac_misc_module

  implicit none
  real(8), intent(out) :: E
  real(8) :: Eexc, Ehar

  E=0.d0

  if( .not. Param%Option%nohar ) then
     if( Param%Option%spin_orbit ) then
        call HartreeLS__calcEnergy2( Ehar, Density%rhoLS )
     else
        call Hartree__calcEnergy2( Ehar, Density%rho )
     end if
     E = E + Ehar
  else
     Ehar = 0.0d0
  end if

  if( .not. Param%Option%noexc ) then
     if( Param%Option%spin_orbit ) then
        call ExchangeLS__calcPotential( Eexc, Potential%Vexc, Density%rhoLS, Density%rhopcc )
     else
        call Exchange__calcPotential( Eexc, Potential%Vexc, Density%rho, Density%rhopcc )
     end if
     E = E + Eexc
  else
     Eexc = 0.0d0
  end if

  return
end subroutine Energy__calcInternal
