! @@@@@@@@@@@@@@@@@@@@@@@@@@@@@@@@@@@@@@@@@@@@@@@@@@@@@@@@@@@@@@@@@@@@ !
! @@                                                                @@ !
! @@       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 ExchangeLS__calcPotential( Exc, Vxc, rhoLS, rhopcc )
  use ac_parameter
  implicit none
  real(8), intent(out) :: Exc
  real(8), intent(out) :: Vxc(Param%Option%nspin,Param%Cell%Na,Param%Cell%Nb,Param%Cell%Nc)
  complex(8), intent(inout) :: rhoLS(Param%Option%nspin,Param%Cell%Na,Param%Cell%Nb,Param%Cell%Nc)
  real(8), intent(in)  :: rhopcc(Param%Cell%Na,Param%Cell%Nb,Param%Cell%Nc)

  type(SpinMatrix_type), pointer :: U(:,:,:)
  type(SpinMatrix_type) :: M
  complex(8), parameter :: CI = ( 0.0d0, 1.0d0 )
  integer :: ia, ib, ic

  if( Param%Option%spin_orbit ) then
     allocate( U   (Param%Cell%Na,Param%Cell%Nb,Param%Cell%Nc) )

     do ic=1, Param%Cell%Nc    
        do ib=1, Param%Cell%Nb
           do ia=1, Param%Cell%Na
              M%element(1,1) = dreal(rhoLS(1,ia,ib,ic))
              M%element(2,1) = (rhoLS(2,ia,ib,ic)+dconjg(rhoLS(3,ia,ib,ic)))*.5d0
              M%element(1,2) = dconjg(M%element(2,1))
              M%element(2,2) = dreal(rhoLS(4,ia,ib,ic))
              call ExchangeLS__diagonalize( M, U(ia,ib,ic) )
              rhoLS(1,ia,ib,ic) = dreal(M%element(1,1))
              rhoLS(2,ia,ib,ic) = 0.0d0
              rhoLS(3,ia,ib,ic) = 0.0d0
              rhoLS(4,ia,ib,ic) = dreal(M%element(2,2))
           end do
        end do
     end do
  end if

  Exc = 0.0    
  select case( Param%SCF%exc_type )
  case('PZ81')
     call ExchangeLS__calcPotentialPZ81(Exc,Vxc,rhoLS,rhopcc)
  case('PW91')
     call ExchangeLS__calcPotentialPW91(Exc,Vxc,rhoLS,rhopcc)
  case('PBE')
     call ExchangeLS__calcPotentialPBE (Exc,Vxc,rhoLS,rhopcc)
  end select

  if( Param%Option%spin_orbit ) then
     do ic=1, Param%Cell%Nc    
        do ib=1, Param%Cell%Nb
           do ia=1, Param%Cell%Na
              M%element(1,1) = rhoLS(1,ia,ib,ic)
              M%element(2,1) = 0.0d0
              M%element(1,2) = 0.0d0
              M%element(2,2) = rhoLS(4,ia,ib,ic)
              call ExchangeLS__undiagonalize( U(ia,ib,ic),  M )
              rhoLS(1,ia,ib,ic) = M%element(1,1)
              rhoLS(2,ia,ib,ic) = M%element(2,1)
              rhoLS(3,ia,ib,ic) = M%element(1,2)
              rhoLS(4,ia,ib,ic) = M%element(2,2)


              M%element(1,1) = Vxc(1,ia,ib,ic)
              M%element(2,1) = 0.0d0
              M%element(1,2) = 0.0d0
              M%element(2,2) = Vxc(4,ia,ib,ic)
              call ExchangeLS__undiagonalize( U(ia,ib,ic),  M )
              Vxc(1,ia,ib,ic) = dreal(M%element(1,1))
              Vxc(2,ia,ib,ic) = dreal(M%element(2,1))
              Vxc(3,ia,ib,ic) = dimag(M%element(2,1))
              Vxc(4,ia,ib,ic) = dreal(M%element(2,2))
           end do
        end do
     end do

     deallocate( U )
  end if

  return
end subroutine ExchangeLS__calcPotential

subroutine Exchange__calcPotential( Exc, Vxc, rho, rhopcc )
  use ac_parameter
  implicit none
  real(8), intent(out) :: Exc
  real(8), intent(out) :: Vxc(Param%Option%nspin,Param%Cell%Na,Param%Cell%Nb,Param%Cell%Nc)
  real(8), intent(inout) :: rho(Param%Option%nspin,Param%Cell%Na,Param%Cell%Nb,Param%Cell%Nc)
  real(8), intent(in)  :: rhopcc(Param%Cell%Na,Param%Cell%Nb,Param%Cell%Nc)
  integer :: ia, ib, ic

  Exc = 0.0    
  select case( Param%SCF%exc_type )
  case('PZ81')
     call Exchange__calcPotentialPZ81(Exc,Vxc,rho,rhopcc)
  case('PW91')
     call Exchange__calcPotentialPW91(Exc,Vxc,rho,rhopcc)
  case('PBE')
     call Exchange__calcPotentialPBE (Exc,Vxc,rho,rhopcc)
  end select

  return
end subroutine Exchange__calcPotential

subroutine ExchangeLS__calcPotentialPZ81( Exc, Vxc, rhoLS, rhopcc )
  use ac_parameter
  implicit none
  real(8), intent(out) :: Exc
  real(8), intent(out) :: Vxc(Param%Option%nspin,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)  :: rhopcc(Param%Cell%Na,Param%Cell%Nb,Param%Cell%Nc)

  integer :: ia, ib, ic
  real(8) :: rhoat(2), dExc(2), Vxcat(2)

  dExc  = 0.d0
  Vxcat = 0.d0
  rhoat = 0.d0

  Exc = 0.0
  do ic=1, Param%Cell%Nc    
     do ib=1, Param%Cell%Nb
        do ia=1, Param%Cell%Na
           if( Param%Option%pcc ) then
              rhoat(1) = dreal(rhoLS(1,ia,ib,ic)) + 0.5d0*rhopcc(ia,ib,ic)
              rhoat(2) = dreal(rhoLS(4,ia,ib,ic)) + 0.5d0*rhopcc(ia,ib,ic)
           else
              rhoat(1) = dreal(rhoLS(1,ia,ib,ic))
              rhoat(2) = dreal(rhoLS(4,ia,ib,ic))
           end if

           call Exchange__calcPotentialPZ81at2 &
                ( Vxcat(1), Vxcat(2), dExc(1), dExc(2), rhoat(1), rhoat(2) )

           Vxc(1,ia,ib,ic) = Vxcat(1)
           Vxc(4,ia,ib,ic) = Vxcat(2)
           Exc = Exc + dreal(rhoLS(1,ia,ib,ic))*dExc(1) + dreal(rhoLS(4,ia,ib,ic))*dExc(2)
        end do
     end do
  end do

  Exc = Exc*Param%Cell%dV

  return
end subroutine ExchangeLS__calcPotentialPZ81

subroutine Exchange__calcPotentialPZ81( Exc, Vxc, rho, rhopcc )
  use ac_parameter
  implicit none
  real(8), intent(out) :: Exc
  real(8), intent(out) :: Vxc(Param%Option%nspin,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)  :: rhopcc(Param%Cell%Na,Param%Cell%Nb,Param%Cell%Nc)

  integer :: ia, ib, ic
  real(8), allocatable :: rhoat(:)
  real(8), allocatable :: dExc(:), Vxcat(:)

  allocate( rhoat(Param%Option%nspin) )
  allocate( dExc (Param%Option%nspin) )
  allocate( Vxcat(Param%Option%nspin) )

  dExc  = 0.d0
  Vxcat = 0.d0
  rhoat = 0.d0

  Exc = 0.0
  do ic=1, Param%Cell%Nc    
     do ib=1, Param%Cell%Nb
        do ia=1, Param%Cell%Na
           if( Param%Option%pcc ) then
              if( .not. Param%Option%spin_polar ) then
                 rhoat(:) = rho(:,ia,ib,ic) + rhopcc(ia,ib,ic)
              else
                 rhoat(:) = rho(:,ia,ib,ic) + 0.5d0*rhopcc(ia,ib,ic)
              end if
           else
              rhoat(:) = rho(:,ia,ib,ic)
           end if

           if( Param%Option%spin_polar ) then
              call Exchange__calcPotentialPZ81at2 &
                   ( Vxcat(1), Vxcat(2), dExc(1), dExc(2), rhoat(1), rhoat(2) )
           else
              call Exchange__calcPotentialPZ81at1 &
                   ( Vxcat(1), dExc(1), rhoat(1) )
           end if

           Vxc(:,ia,ib,ic) = Vxcat(:)
           Exc = Exc + sum(rho(:,ia,ib,ic)*dExc(:))

        end do
     end do
  end do

  deallocate( rhoat )
  deallocate( dExc  )
  deallocate( Vxcat )

  Exc = Exc*Param%Cell%dV

  return
end subroutine Exchange__calcPotentialPZ81

subroutine ExchangeLS__calcPotentialPW91( Exc, Vxc, rhoLS, rhopcc )
  use ac_parameter
  implicit none
  real(8), intent(out) :: Exc
  real(8), intent(out) :: Vxc(Param%Option%nspin,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)  :: rhopcc(Param%Cell%Na,Param%Cell%Nb,Param%Cell%Nc)

  integer :: ia, ib, ic
  real(8) :: rhoat(2), dExc(2), Vxcat(2)

  dExc  = 0.d0
  Vxcat = 0.d0
  rhoat = 0.d0

  Exc = 0.0
  do ic=1, Param%Cell%Nc    
     do ib=1, Param%Cell%Nb
        do ia=1, Param%Cell%Na
           if( Param%Option%pcc ) then
              rhoat(1) = dreal(rhoLS(1,ia,ib,ic)) + 0.5d0*rhopcc(ia,ib,ic)
              rhoat(2) = dreal(rhoLS(4,ia,ib,ic)) + 0.5d0*rhopcc(ia,ib,ic)
           else
              rhoat(1) = dreal(rhoLS(1,ia,ib,ic))
              rhoat(2) = dreal(rhoLS(4,ia,ib,ic))
           end if

           call Exchange__calcPotentialPW91at2 &
                ( Vxcat(1), Vxcat(2), dExc(1), dExc(2), rhoat(1), rhoat(2) )

           Vxc(1,ia,ib,ic) = Vxcat(1)
           Vxc(4,ia,ib,ic) = Vxcat(2)
           Exc = Exc + dreal(rhoLS(1,ia,ib,ic))*dExc(1) + dreal(rhoLS(4,ia,ib,ic))*dExc(2)
        end do
     end do
  end do

  Exc = Exc*Param%Cell%dV

  return
end subroutine ExchangeLS__calcPotentialPW91

subroutine Exchange__calcPotentialPW91( Exc, Vxc, rho, rhopcc )
  use ac_parameter
  implicit none
  real(8), intent(out) :: Exc
  real(8), intent(out) :: Vxc(Param%Option%nspin,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)  :: rhopcc(Param%Cell%Na,Param%Cell%Nb,Param%Cell%Nc)

  integer :: ia, ib, ic
  real(8), allocatable :: rhoat(:), dExc(:), Vxcat(:)

  allocate( rhoat(Param%Option%nspin) )
  allocate( dExc(Param%Option%nspin) )
  allocate( Vxcat(Param%Option%nspin) )

  dExc  = 0.d0
  Vxcat = 0.d0
  rhoat = 0.d0

  Exc = 0.0
  do ic=1, Param%Cell%Nc    
     do ib=1, Param%Cell%Nb
        do ia=1, Param%Cell%Na
           if( Param%Option%pcc ) then
              if( .not. Param%Option%spin_polar ) then
                 rhoat(:) = rho(:,ia,ib,ic) + rhopcc(ia,ib,ic)
              else
                 rhoat(:) = rho(:,ia,ib,ic) + 0.5d0*rhopcc(ia,ib,ic)
              end if
           else
              rhoat(:) = rho(:,ia,ib,ic)
           end if

           if( Param%Option%spin_polar ) then
              call Exchange__calcPotentialPW91at2 &
                   ( Vxcat(1), Vxcat(2), dExc(1), dExc(2), rhoat(1), rhoat(2) )
           else
              call Exchange__calcPotentialPW91at1 &
                   ( Vxcat(1), dExc(1), rhoat(1) )
           end if

           Vxc(:,ia,ib,ic) = Vxcat(:)
           Exc = Exc + sum(rho(:,ia,ib,ic)*dExc(:))
        end do
     end do
  end do

  Exc = Exc*Param%Cell%dV

  deallocate( rhoat )
  deallocate( dExc )
  deallocate( Vxcat )

  return
end subroutine Exchange__calcPotentialPW91

subroutine ExchangeLS__calcPotentialPBE( Exc, Vxc, rhoLS, rhopcc )
  use ac_parameter
  implicit none
  real(8), intent(out) :: Exc
  real(8), intent(out) :: Vxc(Param%Option%nspin,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)  :: rhopcc(Param%Cell%Na,Param%Cell%Nb,Param%Cell%Nc)

  real(8), allocatable :: rhoK(:,:,:,:) 
  real(8), allocatable :: grhoK(:,:,:,:,:) 
  real(8), allocatable :: gVxcK(:,:,:,:,:) 
  real(8), allocatable :: dgVxcK(:,:,:,:) 

  integer :: spin
  integer :: ia, ib, ic
  real(8) :: rhoat(2), dExc(2), Vxcat(2)
  real(8) :: gVxcKat(3,2), grhoKat(3,2)

  dExc  = 0.d0
  Vxcat = 0.d0
  rhoat = 0.d0
  gVxcKat = 0.d0
  grhoKat = 0.d0

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

  do ic=1, Param%Cell%Nc
     do ib=1, Param%Cell%Nb
        do ia=1, Param%Cell%Na
           if( Param%Option%pcc ) then
              rhoK(ia,ib,ic,1) = dreal(rhoLS(1,ia,ib,ic)) + 0.5d0*rhopcc(ia,ib,ic)
              rhoK(ia,ib,ic,2) = dreal(rhoLS(4,ia,ib,ic)) + 0.5d0*rhopcc(ia,ib,ic)
           else
              rhoK(ia,ib,ic,1) = dreal(rhoLS(1,ia,ib,ic))
              rhoK(ia,ib,ic,2) = dreal(rhoLS(4,ia,ib,ic))
           end if
        end do
     end do
  end do

  call Exchange__calcGradient( grhoK(:,:,:,:,1), rhoK(:,:,:,1) )
  call Exchange__calcGradient( grhoK(:,:,:,:,2), rhoK(:,:,:,2) )

  Exc = 0.0
  do ic=1, Param%Cell%Nc    
     do ib=1, Param%Cell%Nb
        do ia=1, Param%Cell%Na
           if( Param%Option%pcc ) then
              rhoat(1) = dreal(rhoLS(1,ia,ib,ic)) + 0.5d0*rhopcc(ia,ib,ic)
              rhoat(2) = dreal(rhoLS(4,ia,ib,ic)) + 0.5d0*rhopcc(ia,ib,ic)
           else
              rhoat(1) = dreal(rhoLS(1,ia,ib,ic))
              rhoat(2) = dreal(rhoLS(4,ia,ib,ic))
           end if

           grhoKat(:,:) = grhoK(:,ia,ib,ic,:)

           call Exchange__calcPotentialPBEat2 &
                ( Vxcat(1), Vxcat(2), &
                dExc(1), dExc(2), gVxcKat(:,1), gVxcKat(:,2), &
                rhoat(1), rhoat(2), grhoKat(:,1), grhoKat(:,2) )

           Vxc(:,ia,ib,ic) = Vxcat(:)
           Exc = Exc + dreal(rhoLS(1,ia,ib,ic))*dExc(1) + dreal(rhoLS(4,ia,ib,ic))*dExc(2)
           gVxcK(:,ia,ib,ic,:) = gVxcKat(:,:)
        end do
     end do
  end do

  call Exchange__calcDivergence( dgVxcK(:,:,:,1), gVxcK(:,:,:,:,1) )
  call Exchange__calcDivergence( dgVxcK(:,:,:,2), gVxcK(:,:,:,:,2) )


  do ic=1, Param%Cell%Nc    
     do ib=1, Param%Cell%Nb
        do ia=1, Param%Cell%Na
           if( Param%Option%pcc ) then
              rhoat(1) = dreal(rhoLS(1,ia,ib,ic)) + 0.5d0*rhopcc(ia,ib,ic)
              rhoat(2) = dreal(rhoLS(4,ia,ib,ic)) + 0.5d0*rhopcc(ia,ib,ic)
           else
              rhoat(1) = dreal(rhoLS(1,ia,ib,ic))
              rhoat(2) = dreal(rhoLS(4,ia,ib,ic))
           end if
           dExc(:)  = dgVxcK(ia,ib,ic,:)
           Vxc(:,ia,ib,ic) = Vxc(:,ia,ib,ic) + dExc(:)
           Exc = Exc + dreal(rhoLS(1,ia,ib,ic))*dExc(1) + dreal(rhoLS(4,ia,ib,ic))*dExc(2)
        end do
     end do
  end do

  Exc = Exc*Param%Cell%dV

  return
end subroutine ExchangeLS__calcPotentialPBE


subroutine Exchange__calcPotentialPBE( Exc, Vxc, rho, rhopcc )
  use ac_parameter
  implicit none
  real(8), intent(out) :: Exc
  real(8), intent(out) :: Vxc(Param%Option%nspin,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)  :: rhopcc(Param%Cell%Na,Param%Cell%Nb,Param%Cell%Nc)

  real(8), allocatable :: rhoK(:,:,:) 
  real(8), allocatable :: grhoK(:,:,:,:,:) 
  real(8), allocatable :: gVxcK(:,:,:,:,:) 
  real(8), allocatable :: dgVxcK(:,:,:,:) 

  integer :: spin
  integer :: ia, ib, ic

  real(8), allocatable :: rhoat(:), dExc(:), Vxcat(:)
  real(8), allocatable :: gVxcKat(:,:), grhoKat(:,:)

  allocate( rhoat(Param%Option%nspin) )
  allocate( dExc(Param%Option%nspin) )
  allocate( Vxcat(Param%Option%nspin) )
  allocate( gVxcKat(3,Param%Option%nspin) )
  allocate( grhoKat(3,Param%Option%nspin) )

  dExc  = 0.d0
  Vxcat = 0.d0
  rhoat = 0.d0
  gVxcKat = 0.d0
  grhoKat = 0.d0

  allocate( rhoK(2*(Param%Cell%Na/2+1),Param%Cell%Nb,Param%Cell%Nc) )
  allocate( grhoK(3,2*(Param%Cell%Na/2+1),Param%Cell%Nb,Param%Cell%Nc,Param%Option%nspin) )
  allocate( gVxcK(3,2*(Param%Cell%Na/2+1),Param%Cell%Nb,Param%Cell%Nc,Param%Option%nspin) )
  allocate( dgVxcK(2*(Param%Cell%Na/2+1),Param%Cell%Nb,Param%Cell%Nc,Param%Option%nspin) )

  do spin=1, Param%Option%nspin

     do ic=1, Param%Cell%Nc
        do ib=1, Param%Cell%Nb
           do ia=1, Param%Cell%Na
              if( Param%Option%pcc ) then
                 if( .not. Param%Option%spin_polar ) then
                    rhoK(ia,ib,ic) = rho(spin,ia,ib,ic) + rhopcc(ia,ib,ic)
                 else
                    rhoK(ia,ib,ic) = rho(spin,ia,ib,ic) + 0.5d0*rhopcc(ia,ib,ic)
                 end if
              else
                 rhoK(ia,ib,ic) = rho(spin,ia,ib,ic)
              end if
           end do
        end do
     end do

     call Exchange__calcGradient( grhoK(:,:,:,:,spin), rhoK )
  end do

  Exc = 0.0
  do ic=1, Param%Cell%Nc    
     do ib=1, Param%Cell%Nb
        do ia=1, Param%Cell%Na
           if( Param%Option%pcc ) then
              if( .not. Param%Option%spin_polar ) then
                 rhoat(:) = rho(:,ia,ib,ic) + rhopcc(ia,ib,ic)
              else
                 rhoat(:) = rho(:,ia,ib,ic) + 0.5d0*rhopcc(ia,ib,ic)
              end if
           else
              rhoat(:) = rho(:,ia,ib,ic)
           end if

           grhoKat(:,:) = grhoK(:,ia,ib,ic,:)

           if( Param%Option%spin_polar ) then
              call Exchange__calcPotentialPBEat2 &
                   ( Vxcat(1), Vxcat(2), &
                   dExc(1), dExc(2), gVxcKat(:,1), gVxcKat(:,2), &
                   rhoat(1), rhoat(2), grhoKat(:,1), grhoKat(:,2) )
           else
              call Exchange__calcPotentialPBEat1 &
                   ( Vxcat(1), &
                   dExc(1), gVxcKat(:,1), &
                   rhoat(1), grhoKat(:,1) )
           end if

           Vxc(:,ia,ib,ic) = Vxcat(:)
           Exc = Exc + sum(rho(:,ia,ib,ic)*dExc(:))
           gVxcK(:,ia,ib,ic,:) = gVxcKat(:,:)
        end do
     end do
  end do

  do spin=1, Param%Option%nspin
     call Exchange__calcDivergence( dgVxcK(:,:,:,spin), gVxcK(:,:,:,:,spin) )
  end do

  do ic=1, Param%Cell%Nc    
     do ib=1, Param%Cell%Nb
        do ia=1, Param%Cell%Na
           if( Param%Option%pcc ) then
              if( .not. Param%Option%spin_polar ) then
                 rhoat(:) = rho(:,ia,ib,ic) + rhopcc(ia,ib,ic)
              else
                 rhoat(:) = rho(:,ia,ib,ic) + 0.5d0*rhopcc(ia,ib,ic)
              end if
           else
              rhoat(:) = rho(:,ia,ib,ic)
           end if
           dExc(:)  = dgVxcK(ia,ib,ic,:)
           Vxc(:,ia,ib,ic) = Vxc(:,ia,ib,ic) + dExc(:)
           Exc = Exc + sum(rho(:,ia,ib,ic)*dExc(:))
        end do
     end do
  end do

  Exc = Exc*Param%Cell%dV

  deallocate( rhoK )
  deallocate( grhoK )
  deallocate( gVxcK )
  deallocate( dgVxcK )

  deallocate( rhoat )
  deallocate( dExc )
  deallocate( Vxcat )
  deallocate( gVxcKat )
  deallocate( grhoKat )

  return
end subroutine Exchange__calcPotentialPBE

subroutine Exchange__calcPotentialPZ81at1( Vxc, dExc, rho )
  use ac_parameter

  implicit none
  real(8), intent(out) :: Vxc, dExc
  real(8), intent(in)  :: rho

  real(8) :: rs

  real(8) :: Ex, dEx, Vx
  real(8) :: Ec, dEc, Vc

  real(8) :: f, df

  if( rho<1.0e-15 ) then
     Vxc = 0.d0
     dExc = 0.d0
     return
  end if

  rs  =  0.5d0*M_CBRT3*M_CBRT2/M_CBRTPI/cbrt(rho)
  Vx  = -cbrt(+3.0d0/M_PI*rho)
  Ex  = 0.75d0*Vx
  dEx =  Vx - Ex

  if( rs>=1.d0 ) then
     f   = 1.d0 + 1.0529d0*sqrt(rs) + 0.3334d0*rs
     df  = (1.0529d0/2.0d0*sqrt(rs) + 0.3334d0*rs)*(-1.d0/3.d0)
     Ec  = -0.1423d0/f
     dEc = -Ec/f*df
  else
     f   = log(rs)
     Ec  = 0.0311d0*f - 0.048d0 + 0.0020d0*rs*f - 0.0116d0*rs
     dEc = (0.0311d0 + 0.0020d0*rs*f + (0.0020d0-0.0116d0)*rs)*(-1.0d0/3.0d0)
  end if

  Vc  = Ec + dEc

  Vxc  = Vx  + Vc
  dExc = dEx + dEc

  return
end subroutine Exchange__calcPotentialPZ81at1

subroutine Exchange__calcPotentialPZ81at2 &
     ( Vxc_u, Vxc_d, dExc_u, dExc_d, rho_u, rho_d )
  use ac_parameter

  implicit none
  real(8), intent(out) :: Vxc_u, Vxc_d
  real(8), intent(out) :: dExc_u, dExc_d
  real(8), intent(in)  :: rho_u, rho_d

  real(8) :: rho_t, zeta, rs

  real(8) :: Ex, dEx(2), Vx(2)
  real(8) :: Ec, dEc(2), Vc(2)
  real(8) :: EcP, EcF, dEcP, dEcF
  real(8) :: fP, dfP, fF, dfF
  real(8) :: z(2), f, df

  if( rho_u+rho_d<1.0e-15 ) then
     Vxc_u = 0.0d0
     Vxc_d = 0.0d0
     dExc_u = 0.0d0
     dExc_d = 0.0d0
     return
  end if

  rho_t  = rho_u + rho_d
  zeta = (rho_u - rho_d)/rho_t
  rs  =  0.5d0*M_CBRT3*M_CBRT2/M_CBRTPI/cbrt(rho_t)

  Vx(1) = -cbrt(+6.0d0/M_PI*rho_u)
  Vx(2) = -cbrt(+6.0d0/M_PI*rho_d)
  Ex = 0.75d0*(Vx(1)*rho_u + Vx(2)*rho_d)/rho_t
  dEx(1) = Vx(1) - Ex
  dEx(2) = Vx(2) - Ex

  if( rs>=1.0d0 ) then
     fP   = 1.d0 + 1.0529d0*sqrt(rs) + 0.3334d0*rs
     dfP  = (1.0529d0/2.0d0*sqrt(rs) + 0.3334d0*rs)*(-1.d0/3.d0)
     EcP  = -0.1423d0/fP
     dEcP = -EcP/fP*dfP

     fF   = 1.d0 + 1.3981d0*sqrt(rs) + 0.2611d0*rs
     dfF  = (1.3981d0/2.0d0*sqrt(rs) + 0.2611d0*rs)*(-1.d0/3.d0)
     EcF  = -0.0843d0/fF
     dEcF = -EcF/fF*dfF
  else
     f    = log(rs)
     EcP  = 0.0311d0*f - 0.048d0 + 0.0020d0*rs*f - 0.0116d0*rs
     dEcP = (0.0311d0 + 0.0020d0*rs*f + (0.0020d0-0.0116d0)*rs)*(-1.0d0/3.0d0)

     EcF  = 0.01555d0*f - 0.0269d0 + 0.0007d0*rs*f - 0.0048d0*rs
     dEcF = (0.01555d0 + 0.0007d0*rs*f + (0.0007d0-0.0048d0)*rs)*(-1.d0/3.d0)
  end if

  z(1) = cbrt(1.d0+zeta)
  z(2) = cbrt(1.d0-zeta)
  f = 0.5d0/(M_CBRT2-1.0d0)*( (1.0d0+zeta)*z(1) + (1.0d0-zeta)*z(2) - 2.0d0)
  df = 2.0d0/3.0d0/(M_CBRT2-1.0d0)*(z(1) - z(2))
  Ec =  EcP + ( EcF- EcP)*f

  dEc(1) = dEcP + (dEcF-dEcP)*f + (EcF-EcP)*(+1.0d0-zeta)*df
  dEc(2) = dEcP + (dEcF-dEcP)*f + (EcF-EcP)*(-1.0d0-zeta)*df

  Vc(1)  = Ec + dEc(1)
  Vc(2)  = Ec + dEc(2)

  Vxc_u  = Vx(1) + Vc(1)
  Vxc_d  = Vx(2) + Vc(2)
  dExc_u = dEx(1) + dEc(1)
  dExc_d = dEx(2) + dEc(2)

  return
end subroutine Exchange__calcPotentialPZ81at2

subroutine Exchange__calcPotentialPW91at1( Vxc, dExc, rho )
  use ac_parameter

  implicit none
  real(8), intent(out) :: Vxc, dExc
  real(8), intent(in)  :: rho

  real(8) :: rs
  real(8) :: Ex, dEx, Vx
  real(8) :: b, db
  real(8) :: Ec, dEc, Vc

  if( rho<1.0e-15 ) then
     Vxc = 0.0d0
     dExc = 0.0d0
     return
  end if

  rs  =  0.5d0*M_CBRT3*M_CBRT2/M_CBRTPI/cbrt(rho)
  Vx  = -cbrt(+3.0d0/M_PI*rho)
  Ex  = 0.75d0*Vx
  dEx =  Vx - Ex

  b  = 2.0d0*0.0310910d0*(7.5957000d0*sqrt(rs)+3.5876000d0*rs+1.6382000d0*rs*sqrt(rs)+0.4929400d0*rs*rs)
  db  = 2.0d0*0.0310910d0*(7.5957000d0*0.5d0*sqrt(rs)+3.5876000d0*rs+1.6382000d0*1.5d0*rs*sqrt(rs)+0.4929400d0*2.0d0*rs*rs)
  Ec  = -2.0d0*0.0310910d0*(1.0d0+0.2137000d0*rs)*log(1.0d0+1.0d0/b)

  dEc = +2.0d0*0.0310910d0/3.0d0*(0.2137000d0*rs)*log(1.0d0+1.0d0/b) &
       - 2.0d0*0.0310910d0/3.0d0*(1.0d0+0.2137000d0*rs)*(db/(b*b+b))
  Vc  = Ec + dEc

  Vxc  = Vx  + Vc
  dExc = dEx + dEc

  return
end subroutine Exchange__calcPotentialPW91at1

subroutine Exchange__calcPotentialPW91at2 &
     ( Vxc_u, Vxc_d, dExc_u, dExc_d, rho_u, rho_d )
  use ac_parameter

  implicit none
  real(8), intent(out) :: Vxc_u, Vxc_d, dExc_u, dExc_d
  real(8), intent(in)  :: rho_u, rho_d

  real(8) :: rho_t, zeta, rs

  real(8) :: Vx(2), Ex, dEx(2)
  real(8) :: bP, dbP, EcP, dEcP
  real(8) :: bF, dbF, EcF, dEcF
  real(8) :: bA, dbA, EcA, dEcA
  real(8) :: zeta3, zeta4, z(2), f, df, ddf
  real(8) :: Ec, dEcdrs, dEcdz, dEc(2), Vc(2)

  if( rho_u+rho_d<1.0e-15 ) then
     Vxc_u  = 0.0d0
     Vxc_d  = 0.0d0
     dExc_u = 0.0d0
     dExc_d = 0.0d0
     return
  end if

  rho_t  = rho_u + rho_d
  zeta = (rho_u - rho_d)/rho_t
  rs  =  0.5d0*M_CBRT3*M_CBRT2/M_CBRTPI/cbrt(rho_t)

  Vx(1) = -cbrt(+6.0d0/M_PI*rho_u)
  Vx(2) = -cbrt(+6.0d0/M_PI*rho_d)
  Ex = 0.75d0*(Vx(1)*rho_u + Vx(2)*rho_d)/rho_t
  dEx(1) = Vx(1) - Ex
  dEx(2) = Vx(2) - Ex

  bP = 2.0d0*0.0310910d0*(7.5957000d0*sqrt(rs)+3.5876000d0*rs+1.6382000d0*rs*sqrt(rs)+0.4929400d0*rs*rs)
  dbP = 2.0d0*0.0310910d0*(7.5957000d0*0.5d0*sqrt(rs)+3.5876000d0*rs+1.6382000d0*1.5d0*rs*sqrt(rs)+0.4929400d0*2.0d0*rs*rs)

  EcP = -2.0d0*0.0310910d0*(1.0d0+0.2137000d0*rs)*log(1.0d0+1.0d0/bP)
  dEcP = -2.0d0*0.0310910d0*(0.2137000d0*rs)*log(1.0d0+1.0d0/bP) &
       + 2.0d0*0.0310910d0*(1.0d0+0.2137000d0*rs)*(dbP/(bP*bP+bP))

  bF = 2.0d0*0.0155450d0*(14.1189000d0*sqrt(rs)+6.1977000d0*rs+3.3662000d0*rs*sqrt(rs)+0.6251700d0*rs*rs)
  dbF = 2.0d0*0.0155450d0*(14.1189000d0*0.5d0*sqrt(rs)+6.1977000d0*rs+3.3662000d0*1.5d0*rs*sqrt(rs)+0.6251700d0*2.0d0*rs*rs)

  EcF = -2.0d0*0.0155450d0*(1.0d0+0.2054800d0*rs)*log(1.0d0+1.0d0/bF)
  dEcF = -2.0d0*0.0155450d0*(0.2054800d0*rs)*log(1.0d0+1.0d0/bF) &
       + 2.0d0*0.0155450d0*(1.0d0+0.2054800d0*rs)*(dbF/(bF*bF+bF))

  bA = 2.0d0*0.0168870d0*(10.3570000d0*sqrt(rs)+3.6231000d0*rs+0.8802600d0*rs*sqrt(rs)+0.4967100d0*rs*rs)
  dbA = 2.0d0*0.0168870d0*(10.3570000d0*0.5d0*sqrt(rs)+3.6231000d0*rs+0.8802600d0*1.5d0*rs*sqrt(rs)+0.4967100d0*2.0d0*rs*rs)

  EcA = -2.0d0*0.0168870d0*(1.0d0+0.1112500d0*rs)*log(1.0d0+1.0d0/bA)
  dEcA = -2.0d0*0.0168870d0*(0.1112500d0*rs)*log(1.0d0+1.0d0/bA) &
       + 2.0d0*0.0168870d0*(1.0d0+0.1112500d0*rs)*(dbA/(bA*bA+bA))

  zeta3  = zeta**3
  zeta4  = zeta**4
  z(1)   = cbrt(1.0d0+zeta)
  z(2)   = cbrt(1.0d0-zeta)
  f      = 0.5d0/(M_CBRT2-1.0)*( (1.0d0+zeta)*z(1) + (1.0d0-zeta)*z(2) - 2.0d0)
  df     = 2.0d0/3.0d0/(M_CBRT2-1.0d0)*(z(1) - z(2))
  ddf    = 4.0d0/9.0d0/(M_CBRT2-1.0d0)

  Ec     = EcP - EcA*f/ddf*(1.0d0-zeta4) + (EcF-EcP)*f*zeta4

  dEcdrs = dEcP - dEcA*f/ddf*(1.0d0-zeta4) + (dEcF-dEcP)*f*zeta4
  dEcdz  = - EcA/ddf*(df*(1.0d0 - zeta4) - f*4.0d0*zeta3) &
       + (EcF-EcP)*(df*zeta4 + f*4.0d0*zeta3)

  dEc(1)  = - dEcdrs/3.0d0 + dEcdz*(+1.0d0-zeta)
  dEc(2)  = - dEcdrs/3.0d0 + dEcdz*(-1.0d0-zeta)

  Vc(1)   = Ec + dEc(1)
  Vc(2)   = Ec + dEc(2)

  Vxc_u  = Vx(1) + Vc(1)
  Vxc_d  = Vx(2) + Vc(2)
  dExc_u = dEx(1) + dEc(1)
  dExc_d = dEx(2) + dEc(2)

  return
end subroutine Exchange__calcPotentialPW91at2

subroutine Exchange__calcPotentialPBEat1( Vxc, dExc, gVxc, rho, grho )
  use ac_parameter

  implicit none
  real(8), intent(out) :: Vxc, dExc
  real(8), intent(in)  :: rho
  real(8), intent(out) :: gVxc(3)
  real(8), intent(in)  :: grho(3)

  real(8)  :: rs

  real(8)  :: bP, dbP
  real(8)  :: EcP, dEcP
  real(8)  :: Ecunif, dEcunif, Vcunif

  real(8)  :: gamma, phi, gp3

  real(8)  :: f1, f2, f3, f4
  real(8)  :: A, ks2, t2, At2, H
  real(8)  :: df1drho, df2drho, df3drho, df4drho
  real(8)  :: dAdrho, dks2drho, dt2drho, dAt2drho, dHdrho
  real(8)  :: Vc, dEc
  real(8)  :: dt2dgrho(3), dAt2dgrho(3), df3dgrho(3), df4dgrho(3), dHdgrho(3)
  real(8)  :: gVc(3)


  real(8), parameter :: kappa = 0.804
  real(8), parameter :: mu = 0.0667250*M_PI*M_PI/3.0

  real(8)  :: kF, s2, Fx, dFxdrho
  real(8) :: dFxdgrho(3)
  real(8)  :: Vxunif, dExunif, Exunif, Vx, dEx
  real(8) :: gVx(3)

  if( rho<1.0e-15 ) then
     Vxc  = 0.0d0
     dExc = 0.0d0
     gVxc = 0.0d0
     return
  end if

  rs  =  0.5*M_CBRT3*M_CBRT2/M_CBRTPI/cbrt(rho)

  bP = 2*0.0310910*(7.5957000*sqrt(rs)+3.5876000*rs+1.6382000*rs*sqrt(rs)+0.4929400*rs*rs)
  dbP = 2*0.0310910*(7.5957000*0.5*sqrt(rs)+3.5876000*rs+1.6382000*1.5*rs*sqrt(rs)+0.4929400*2.0*rs*rs)

  EcP = -2.0*0.0310910*(1.0+0.2137000*rs)*log(1.0d0+1.0/bP)
  dEcP = -2.0*0.0310910*(0.2137000*rs)*log(1.0d0+1.0/bP) &
       + 2.0*0.0310910*(1.0+0.2137000*rs)*(dbP/(bP*bP+bP))

  Ecunif = EcP
  dEcunif = - dEcP/3
  Vcunif = Ecunif + dEcunif

  gamma = (1.0 - M_LN2)*M_1_PI*M_1_PI
  phi = 1.0
  gp3  = gamma*phi*phi*phi

  f1 = Ecunif/gp3
  f2 = exp(-f1) - 1.0d0
  A  = (0.0667250/gamma)/f2

  ks2  = 4.0/M_PI*cbrt(3.0*M_PI*M_PI*rho)

  t2  = dot_product(grho,grho)/(4.0*phi*phi*ks2*rho*rho)
  At2 = A*t2 
  f3  = 1.0 - 1.0/(1.0+At2+At2*At2)

  f4 = f2*f3
  H  = gp3 * log(1.0d0+f4)

  dks2drho   = ks2/(3.0*rho)
  df1drho = (dEcunif/(Ecunif*rho))*f1
  df2drho = -(f2 + 1.0)*df1drho
  dAdrho = -A/f2*df2drho
  dt2drho = t2*(-1.0*dks2drho/ks2-2.0/rho)
  dAt2drho = dAdrho*t2 + A*dt2drho
  df3drho = (1.0-f3)*(1.0-f3)*(1.0+2*At2)*dAt2drho
  df4drho = df2drho*f3 + f2*df3drho
  dHdrho = gp3/(1.0+f4)*df4drho
  dt2dgrho = 2.0*t2/dot_product(grho,grho)*grho
  dAt2dgrho = A*dt2dgrho
  df3dgrho = (1.0-f3)*(1.0-f3)*(1.0+2*At2)*dAt2dgrho
  df4dgrho = f2*df3dgrho
  dHdgrho = gp3/(1.0+f4)*df4dgrho

  Vc = Vcunif + H + rho*dHdrho
  dEc = dEcunif + rho*dHdrho
  gVc = rho*dHdgrho

  kF = cbrt(3.0*M_PI*M_PI*rho)
  s2 = dot_product(grho,grho)/(2.0*kF*rho)**2
  Fx = 1.0 + kappa - kappa/(1.0+mu/kappa*s2)
  dFxdrho = -8.0/3.0*mu/(1.0+mu/kappa*s2)**2 *s2/rho
  dFxdgrho = (2.0*mu/(1.0+mu/kappa*s2)**2 *s2/dot_product(grho,grho))*grho

  Vxunif = - cbrt(3.0/M_PI*rho)
  dExunif = 0.25*Vxunif
  Exunif = 0.75*Vxunif

  Vx  = Vxunif*Fx + rho*Exunif*dFxdrho
  dEx = dExunif*Fx + rho*Exunif*dFxdrho
  gVx = (Exunif*rho)*dFxdgrho

  Vxc = Vx + Vc
  dExc = dEx + dEc
  gVxc = gVx + gVc

  return
end subroutine Exchange__calcPotentialPBEat1

subroutine Exchange__calcPotentialPBEat2 &
     ( Vxc_u, Vxc_d, dExc_u, dExc_d, gVxc_u, gVxc_d, &
     rho_u, rho_d, grho_u, grho_d )
  use ac_parameter
  implicit none
  real(8), intent(out)  :: Vxc_u, Vxc_d, dExc_u, dExc_d
  real(8), intent(in)   :: rho_u, rho_d 
  real(8), intent(out) :: gVxc_u(3), gVxc_d(3)
  real(8), intent(in)  :: grho_u(3), grho_d(3)

  real(8) :: rho_t, zeta, rs
  real(8) :: bP, dbP, EcP, dEcP
  real(8) :: bF, dbF, EcF, dEcF
  real(8) :: bA, dbA, EcA, dEcA
  real(8) :: zeta3, zeta4, z(2), f, df, ddf
  real(8) :: Ecunif, dEcdrs, dEcdz
  real(8) :: dEcunif(2), Vcunif(2)

  real(8) :: grho_t(3)

  real(8) :: gamma, phi, gp3
  real(8) :: f1, f2, f3, f4
  real(8) :: A, ks2, t2, At2, H
  real(8) :: dphidrho(2), dks2drho_t
  real(8) :: df1drho(2), df2drho(2)
  real(8) :: df3drho(2), df4drho(2)
  real(8) :: dAdrho(2), dt2drho(2)
  real(8) :: dAt2drho(2), dHdrho(2)
  real(8) :: dt2dgrho_t(3), dAt2dgrho_t(3)
  real(8) :: df3dgrho_t(3), df4dgrho_t(3), dHdgrho_t(3)
  real(8) :: Vc(2), dEc(2)
  real(8) :: gVc(3,2)

  real(8), parameter :: kappa = 0.804
  real(8), parameter :: mu = 0.0667250d0*M_PI*M_PI/3.0d0

  real(8) :: kF(2), s2(2)
  real(8) :: Fx(2), dFxdrho(2)

  real(8) :: dFxdgrho(3,2)

  real(8) :: Vxunif(2), dExunif(2)
  real(8) :: Exunif(2)
  real(8) :: Vx(2), dEx(2)
  real(8) :: gVx(3,2)

  if( rho_u+rho_d<1.0e-15 ) then
     Vxc_u  = 0.0d0
     Vxc_d  = 0.0d0
     dExc_u = 0.0d0
     dExc_d = 0.0d0
     gVxc_u = 0.0d0
     gVxc_d = 0.0d0
     return
  end if

  rho_t  = rho_u + rho_d
  zeta = (rho_u - rho_d)/rho_t
  rs  =  0.5*M_CBRT3*M_CBRT2/M_CBRTPI/cbrt(rho_t)

  bP  = 2*0.0310910*(7.5957000*sqrt(rs)+3.5876000*rs+1.6382000*rs*sqrt(rs)+0.4929400*rs*rs)
  dbP = 2*0.0310910*(7.5957000*0.5*sqrt(rs)+3.5876000*rs+1.6382000*1.5*rs*sqrt(rs)+0.4929400*2.0*rs*rs)

  EcP  = -2.0*0.0310910*(1.0+0.2137000*rs)*log(1.0d0+1.0/bP)
  dEcP = -2.0*0.0310910*(0.2137000*rs)*log(1.0d0+1.0/bP) &
       + 2.0*0.0310910*(1.0+0.2137000*rs)*(dbP/(bP*bP+bP))

  bF  = 2*0.0155450*(14.1189000*sqrt(rs)+6.1977000*rs+3.3662000*rs*sqrt(rs)+0.6251700*rs*rs)
  dbF = 2*0.0155450*(14.1189000*0.5*sqrt(rs)+6.1977000*rs+3.3662000*1.5*rs*sqrt(rs)+0.6251700*2.0*rs*rs)

  EcF  = -2.0*0.0155450*(1.0+0.2054800*rs)*log(1.0d0+1.0/bF)
  dEcF = -2.0*0.0155450*(0.2054800*rs)*log(1.0d0+1.0/bF) &
       + 2.0*0.0155450*(1.0+0.2054800*rs)*(dbF/(bF*bF+bF))

  bA  = 2*0.0168870*(10.3570000*sqrt(rs)+3.6231000*rs+0.8802600*rs*sqrt(rs)+0.4967100*rs*rs)
  dbA = 2*0.0168870*(10.3570000*0.5*sqrt(rs)+3.6231000*rs+0.8802600*1.5*rs*sqrt(rs)+0.4967100*2.0*rs*rs)

  EcA  = -2.0*0.0168870*(1.0+0.1112500*rs)*log(1.0d0+1.0/bA)
  dEcA = -2.0*0.0168870*(0.1112500*rs)*log(1.0d0+1.0/bA) &
       + 2.0*0.0168870*(1.0+0.1112500*rs)*(dbA/(bA*bA+bA))

  zeta3  = zeta**3
  zeta4  = zeta**4
  z(1)   = cbrt(1.0+zeta)
  z(2)   = cbrt(1.0-zeta)

  f   = 0.5/(M_CBRT2-1.0)*( (1.0+zeta)*z(1) + (1.0-zeta)*z(2) - 2.0)
  df  = 2.0/3.0/(M_CBRT2-1.0)*(z(1) - z(2))
  ddf = 4.0/9.0/(M_CBRT2-1.0)

  Ecunif = EcP - EcA*f/ddf*(1.0-zeta4) + (EcF-EcP)*f*zeta4

  dEcdrs = dEcP - dEcA*f/ddf*(1.0-zeta4) + (dEcF-dEcP)*f*zeta4
  dEcdz  = - EcA/ddf*(df*(1.0-zeta4) - f*4.0*zeta3) &
       + (EcF-EcP)*(df*zeta4 + f*4.0*zeta3)

  dEcunif(1) = - dEcdrs/3 + dEcdz*(+1.0-zeta)
  dEcunif(2) = - dEcdrs/3 + dEcdz*(-1.0-zeta)

  Vcunif(1) = Ecunif + dEcunif(1)
  Vcunif(2) = Ecunif + dEcunif(2)

  grho_t = grho_u + grho_d

  gamma = (1.0 - M_LN2)*M_1_PI*M_1_PI
  phi   = 0.5*z(1)*z(1) + 0.5*z(2)*z(2)
  gp3   = gamma*phi*phi*phi

  f1 = Ecunif/gp3
  f2 = exp(-f1) - 1.0d0
  A  = (0.0667250/gamma)/f2

  ks2  = 4.0/M_PI*cbrt(3.0*M_PI*M_PI*rho_t)

  t2  = dot_product(grho_t,grho_t)/(4.0*phi*phi*ks2*rho_t*rho_t)
  At2 = A*t2 
  f3  = 1.0 - 1.0/(1.0+At2+At2*At2)

  f4 = f2*f3
  H  = gp3 * log(1.0d0+f4)

  dphidrho(1) = 1.0/3.0*(+1.0-zeta)/rho_t*(1.0/z(1)-1.0/z(2))
  dphidrho(2) = 1.0/3.0*(-1.0-zeta)/rho_t*(1.0/z(1)-1.0/z(2))
  dks2drho_t  = ks2/(3.0*rho_t)

  df1drho(1) = (dEcunif(1)/(Ecunif*rho_t)-3.0/phi*dphidrho(1))*f1
  df1drho(2) = (dEcunif(2)/(Ecunif*rho_t)-3.0/phi*dphidrho(2))*f1

  df2drho(1) = -(f2 + 1.0)*df1drho(1)
  df2drho(2) = -(f2 + 1.0)*df1drho(2)

  dAdrho(1) = -A/f2*df2drho(1)
  dAdrho(2) = -A/f2*df2drho(2)

  dt2drho(1) = t2*(-2.0*dphidrho(1)/phi-1.0*dks2drho_t/ks2-2.0/rho_t)
  dt2drho(2) = t2*(-2.0*dphidrho(2)/phi-1.0*dks2drho_t/ks2-2.0/rho_t)

  dAt2drho(1) = dAdrho(1)*t2 + A*dt2drho(1)
  dAt2drho(2) = dAdrho(2)*t2 + A*dt2drho(2)

  df3drho(1) = (1.0-f3)*(1.0-f3)*(1.0+2*At2)*dAt2drho(1)
  df3drho(2) = (1.0-f3)*(1.0-f3)*(1.0+2*At2)*dAt2drho(2)

  df4drho(1) = df2drho(1)*f3 + f2*df3drho(1)
  df4drho(2) = df2drho(2)*f3 + f2*df3drho(2)

  dHdrho(1) = 3.0*H/phi*dphidrho(1) + gp3/(1.0+f4)*df4drho(1)
  dHdrho(2) = 3.0*H/phi*dphidrho(2) + gp3/(1.0+f4)*df4drho(2)

  dt2dgrho_t = 2.0*t2/dot_product(grho_t,grho_t)*grho_t

  dAt2dgrho_t = A*dt2dgrho_t
  df3dgrho_t  = (1.0-f3)*(1.0-f3)*(1.0+2*At2)*dAt2dgrho_t
  df4dgrho_t  = f2*df3dgrho_t
  dHdgrho_t   = gp3/(1.0+f4)*df4dgrho_t

  Vc(1) = Vcunif(1) + H + rho_t*dHdrho(1)
  Vc(2) = Vcunif(2) + H + rho_t*dHdrho(2)

  dEc(1) = dEcunif(1) + rho_t*dHdrho(1)
  dEc(2) = dEcunif(2) + rho_t*dHdrho(2)

  gVc(:,1) = rho_t*dHdgrho_t
  gVc(:,2) = rho_t*dHdgrho_t

  kF(1) = cbrt(6.0*M_PI*M_PI*rho_u)
  kF(2) = cbrt(6.0*M_PI*M_PI*rho_d)
  s2(1) = dot_product(grho_u,grho_u)/(2.0*kF(1)*rho_u)**2
  s2(2) = dot_product(grho_d,grho_d)/(2.0*kF(2)*rho_d)**2

  Fx(1) = 1.0 + kappa - kappa/(1.0+mu/kappa*s2(1))
  Fx(2) = 1.0 + kappa - kappa/(1.0+mu/kappa*s2(2))
  dFxdrho(1)  = -8.0/3.0*mu/(1.0+mu/kappa*s2(1))**2 *s2(1)/rho_u
  dFxdrho(2)  = -8.0/3.0*mu/(1.0+mu/kappa*s2(2))**2 *s2(2)/rho_d
  dFxdgrho(:,1) = (2.0*mu/(1.0+mu/kappa*s2(1))**2 *s2(1)/dot_product(grho_u,grho_u))*grho_u
  dFxdgrho(:,2) = (2.0*mu/(1.0+mu/kappa*s2(2))**2 *s2(2)/dot_product(grho_d,grho_d))*grho_d

  Vxunif(1) = - cbrt(6.0/M_PI*rho_u)
  Vxunif(2) = - cbrt(6.0/M_PI*rho_d)

  dExunif(1) = 0.25*Vxunif(1)
  dExunif(2) = 0.25*Vxunif(2)
  Exunif(1)  = 0.75*Vxunif(1)
  Exunif(2)  = 0.75*Vxunif(2)

  Vx(1) = Vxunif(1)*Fx(1) + rho_u*Exunif(1)*dFxdrho(1)
  Vx(2) = Vxunif(2)*Fx(2) + rho_d*Exunif(2)*dFxdrho(2)

  dEx(1) = dExunif(1)*Fx(1) + rho_u*Exunif(1)*dFxdrho(1)
  dEx(2) = dExunif(2)*Fx(2) + rho_d*Exunif(2)*dFxdrho(2)

  gVx(:,1) = (Exunif(1)*rho_u)*dFxdgrho(:,1)
  gVx(:,2) = (Exunif(2)*rho_d)*dFxdgrho(:,2)

  Vxc_u  = Vx(1) + Vc(1)
  Vxc_d  = Vx(2) + Vc(2)
  dExc_u = dEx(1) + dEc(1)
  dExc_d = dEx(2) + dEc(2)
  gVxc_u = gVx(:,1) + gVc(:,1)
  gVxc_d = gVx(:,2) + gVc(:,2)

  return
end subroutine Exchange__calcPotentialPBEat2

subroutine Exchange__calcGradient( gradF, F )
  use ac_parameter

  implicit none
  real(8), intent(out) :: gradF(3,2*(Param%Cell%Na/2+1),Param%Cell%Nb,Param%Cell%Nc)
  real(8), intent(inout) ::     F(2*(Param%Cell%Na/2+1),Param%Cell%Nb,Param%Cell%Nc)

  integer        :: ia, ib, ic
  integer        :: ika, ikb, ikc
  real(8) :: K(3)
  real(8) :: c

  real(8), allocatable :: workK(:,:,:) 

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

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

  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
           F(2*ika-1,ikb,ikc) = F(2*ika-1,ikb,ikc)*c
           F(2*ika-0,ikb,ikc) = F(2*ika-0,ikb,ikc)*c
        end do
     end do
  end do

  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)
           workK(2*ika-1,ikb,ikc) = F(2*ika-0,ikb,ikc) * (-K(1))
           workK(2*ika-0,ikb,ikc) = F(2*ika-1,ikb,ikc) * (+K(1))
        end do
     end do
  end do

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

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

  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)
           workK(2*ika-1,ikb,ikc) = F(2*ika-0,ikb,ikc) * (-K(2))
           workK(2*ika-0,ikb,ikc) = F(2*ika-1,ikb,ikc) * (+K(2))
        end do
     end do
  end do

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

  do ic=1, Param%Cell%Nc
     do ib=1, Param%Cell%Nb
        do ia=1, Param%Cell%Na
           gradF(2,ia,ib,ic) = workK(ia,ib,ic)
        end do
     end do
  end do

  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)
           workK(2*ika-1,ikb,ikc) = F(2*ika-0,ikb,ikc) * (-K(3))
           workK(2*ika-0,ikb,ikc) = F(2*ika-1,ikb,ikc) * (+K(3))
        end do
     end do
  end do

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

  do ic=1, Param%Cell%Nc
     do ib=1, Param%Cell%Nb
        do ia=1, Param%Cell%Na
           gradF(3,ia,ib,ic) = workK(ia,ib,ic)
        end do
     end do
  end do

  deallocate( workK )

  return
end subroutine Exchange__calcGradient

subroutine Exchange__calcDivergence( divF, F )
  use ac_parameter

  implicit none
  real(8), intent(out) :: divF(2*(Param%Cell%Na/2+1),Param%Cell%Nb,Param%Cell%Nc)
  real(8), intent(in)  ::  F(3,2*(Param%Cell%Na/2+1),Param%Cell%Nb,Param%Cell%Nc)

  integer        :: ia, ib, ic
  integer        :: ika, ikb, ikc
  real(8) :: K(3)
  real(8) :: c

  real(8), allocatable :: workK(:,:,:) 

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

  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
           divF(2*ika-1,ikb,ikc) = 0.d0
           divF(2*ika-0,ikb,ikc) = 0.d0
        end do
     end do
  end do

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

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

  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)

           divF(2*ika-1,ikb,ikc) = &
                divF(2*ika-1,ikb,ikc) + workK(2*ika-0,ikb,ikc)*(-c*K(1))
           divF(2*ika-0,ikb,ikc) = &
                divF(2*ika-0,ikb,ikc) + workK(2*ika-1,ikb,ikc)*(+c*K(1))
        end do
     end do
  end do


  do ic=1, Param%Cell%Nc
     do ib=1, Param%Cell%Nb
        do ia=1, Param%Cell%Na
           workK(ia,ib,ic) = F(2,ia,ib,ic)
        end do
     end do
  end do

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

  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)

           divF(2*ika-1,ikb,ikc) = &
                divF(2*ika-1,ikb,ikc) + workK(2*ika-0,ikb,ikc)*(-c*K(2))
           divF(2*ika-0,ikb,ikc) = &
                divF(2*ika-0,ikb,ikc) + workK(2*ika-1,ikb,ikc)*(+c*K(2))
        end do
     end do
  end do

  do ic=1, Param%Cell%Nc
     do ib=1, Param%Cell%Nb
        do ia=1, Param%Cell%Na
           workK(ia,ib,ic) = F(3,ia,ib,ic)
        end do
     end do
  end do

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

  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)

           divF(2*ika-1,ikb,ikc) = &
                divF(2*ika-1,ikb,ikc) + workK(2*ika-0,ikb,ikc)*(-c*K(3))
           divF(2*ika-0,ikb,ikc) = &
                divF(2*ika-0,ikb,ikc) + workK(2*ika-1,ikb,ikc)*(+c*K(3))
        end do
     end do
  end do

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

  deallocate( workK )

  return
end subroutine Exchange__calcDivergence

subroutine ExchangeLS__diagonalize( M, U )
  use ac_parameter
  implicit none

  type(SpinMatrix_type), intent(inout) :: M
  type(SpinMatrix_type), intent(out)   :: U

  real(8) :: A, B, AB, CC
  real(8) :: factor


  if( M%element(1,2) == 0.d0 ) then
     U%element(1,1) = 1.0d0
     U%element(2,1) = 0.0d0
     U%element(1,2) = 0.0d0
     U%element(2,2) = 1.0d0
     return
  end if

  A = dreal(M%element(1,1))
  B = dreal(M%element(2,2))
  AB = 0.5d0*(A-B)
  CC = dreal(M%element(1,2))**2 + dimag(M%element(1,2))**2

  U%element(1,1) = AB + sqrt(AB*AB+CC)
  U%element(2,1) = M%element(2,1)
  U%element(1,2) = M%element(1,2)
  U%element(2,2) = (-1.0d0)*U%element(1,1)

  M%element(1,1) = B - U%element(2,2)
  M%element(2,1) = 0.d0
  M%element(1,2) = 0.d0
  M%element(2,2) = A - U%element(1,1)

  factor = 1.d0/sqrt( dreal(U%element(1,1))**2 + CC )
  U%element(1,1) = factor*U%element(1,1)
  U%element(2,1) = factor*U%element(2,1)
  U%element(1,2) = factor*U%element(1,2)
  U%element(2,2) = factor*U%element(2,2)
  return
end subroutine ExchangeLS__diagonalize

subroutine ExchangeLS__undiagonalize( U, M )
  use ac_parameter
  implicit none

  type(SpinMatrix_type), intent(inout) :: M
  type(SpinMatrix_type), intent(in)    :: U
  type(SpinMatrix_type) :: W

  W%element(1,1) = U%element(1,1) * M%element(1,1) + U%element(1,2) * M%element(2,1)
  W%element(2,1) = U%element(2,1) * M%element(1,1) + U%element(2,2) * M%element(2,1)
  W%element(1,2) = U%element(1,1) * M%element(1,2) + U%element(1,2) * M%element(2,2)
  W%element(2,2) = U%element(2,1) * M%element(1,2) + U%element(2,2) * M%element(2,2)

  M%element(1,1) = W%element(1,1) * dconjg(U%element(1,1)) + W%element(1,2) * dconjg(U%element(1,2))
  M%element(2,1) = W%element(2,1) * dconjg(U%element(1,1)) + W%element(2,2) * dconjg(U%element(1,2))
  M%element(1,2) = W%element(1,1) * dconjg(U%element(2,1)) + W%element(1,2) * dconjg(U%element(2,2))
  M%element(2,2) = W%element(2,1) * dconjg(U%element(2,1)) + W%element(2,2) * dconjg(U%element(2,2))

  return
end subroutine ExchangeLS__undiagonalize
