!
!  Software name : CIAO (Code for Investigating Atomic Orbitals)
!  Subroutine(s) : calc_xc_lda_pz81_sol, calc_xc_lda_pz81_ss
!                : calc_xc_lda_pw92_sol, calc_xc_lda_pw92_ss
!                : calc_xc_gga_pbe96_sol, calc_xc_gga_pbe96_ss
!                : calc_xc_gga_pw91_sol, calc_xc_gga_pw91_ss
!                : calc_x_lda_sol, calc_x_lda_ss, calc_x_gga_sol
!                : calc_x_gga_ss, calc_xc_none_sol, calc_xc_none_ss
!  Author(s)     : Masakuni Okamoto (August 25, 2003)
!
!
!  Contact address :  Phase System Consortium
!                     E-mail: phase_system@nims.go.jp URL https://azuma.nims.go.jp
!
!
!  The license of the code and contact address :
!  See the files, COPYRIGHT and LICENSE (or LICENSE_J.pdf)
!
!=====================================================================
   subroutine calc_xc_lda_pz81_sol(ier)
!=====================================================================
!
!  M. Okamoto
!
!---------------------------------------------------------------------
   use parameters
   implicit none
   integer,intent(out) :: ier
   integer :: ir
   real(8) :: rho1, rho2, rho1_tmp, &
              ex_tmp, ec_tmp, vx_tmp(2), vc_tmp(2), &
              rhomin = 1.d-35
   ier = 0
   do ir = 1,nmesh
      select case (is_pcc)
! ======================================- modified by K. T. ============= 4.0
!      case (NONE)
!         rho1_tmp = rho_sol(ir)
!      case (PCC)
!         rho1_tmp = rho_sol(ir) + rho_pcore(ir)
!      case (FCC)
!         rho1_tmp = rho_sol(ir) + rho_core(ir)
!      end select
!
      case (NONE)
         rho1_tmp = rho_sol(ir,1)
      case (PCC)
         rho1_tmp = rho_sol(ir,1) + rho_pcore(ir)
      case (FCC)
         rho1_tmp = rho_sol(ir,1) + rho_core(ir)
      end select
! ========================================================================= 4.0

      rho1 = rho1_tmp*0.5d0 ; rho2 = rho1
      call lda_pz81(rho1,rho2,ex_tmp,ec_tmp,vx_tmp,vc_tmp)
      ex_sol(ir) = ex_tmp
      ec_sol(ir) = ec_tmp

! ====================================== modified by K. T. =============== 4.0
!      vx_sol(ir) = vx_tmp(1)
!      vc_sol(ir) = vc_tmp(1)
      vx_sol(ir,1) = vx_tmp(1)
      vc_sol(ir,1) = vc_tmp(1)
! ======================================================================== 4.0
   end do
   do ir = 1,nmesh
      select case (is_pcc)
      case (NONE)
         rho1_tmp = 0.d0
      case (PCC)
         rho1_tmp = rho_pcore(ir)
      case (FCC)
         rho1_tmp = rho_core(ir)
      end select
      rho1 = rho1_tmp*0.5d0 ; rho2 = rho1
      select case (is_pcc)
      case (PCC,FCC)
         call lda_pz81(rho1,rho2,ex_tmp,ec_tmp,vx_tmp,vc_tmp)
      case (NONE)
         ex_tmp    = 0.d0
         ec_tmp    = 0.d0
         vx_tmp(:) = 0.d0
         vc_tmp(:) = 0.d0
      end select
      expc_sol(ir) = ex_tmp
      ecpc_sol(ir) = ec_tmp
      vxpc_sol(ir) = vx_tmp(1)
      vcpc_sol(ir) = vc_tmp(1)
   end do
   end subroutine calc_xc_lda_pz81_sol

! ========================================= added by K. T. =================== 4.0
subroutine calc_xc_lda_pz81_sol_kt(ier)
  use parameters
  implicit none

  integer,intent(out) :: ier
  integer :: ir, ispin
  real(8) :: rho1, rho2, &
       ex_tmp, ec_tmp, vx_tmp(2), vc_tmp(2), &
       rhomin = 1.d-35
  real(8) :: rho_tmp(2)

  ier = 0

  do ir = 1,nmesh

     Do ispin=1, nspin

        select case (is_pcc)
        case (NONE)
           rho_tmp(ispin) = rho_sol(ir,ispin)
        case (PCC)
           rho_tmp(ispin) = rho_sol(ir,ispin) + rho_pcore(ir)/dble(nspin)
        case (FCC)
           rho_tmp(ispin) = rho_sol(ir,ispin) + rho_core(ir)/dble(nspin)
        end select

     End do

     if ( nspin == 1 ) then
        rho1 = rho_tmp(1) *0.5d0 ; rho2 = rho1
     else if ( nspin == 2 ) then
        rho1 = rho_tmp(1); rho2 = rho_tmp(2)
     endif

     call lda_pz81(rho1,rho2,ex_tmp,ec_tmp,vx_tmp,vc_tmp)

     ex_sol(ir) = ex_tmp
     ec_sol(ir) = ec_tmp

     Do ispin=1, nspin
        vx_sol(ir,ispin) = vx_tmp(ispin)
        vc_sol(ir,ispin) = vc_tmp(ispin)
     End do

  end do

  do ir = 1,nmesh

     select case (is_pcc)
     case (NONE)
        rho_tmp(1) = 0.d0
     case (PCC)
        rho_tmp(1) = rho_pcore(ir)
     case (FCC)
        rho_tmp(1) = rho_core(ir)
     end select
     
     rho1 = rho_tmp(1)*0.5d0 ; rho2 = rho1
     
     select case (is_pcc)
        
     case (PCC,FCC)
        call lda_pz81(rho1,rho2,ex_tmp,ec_tmp,vx_tmp,vc_tmp)
     case (NONE)
        ex_tmp    = 0.d0
        ec_tmp    = 0.d0
        vx_tmp(:) = 0.d0
        vc_tmp(:) = 0.d0
     end select

     expc_sol(ir) = ex_tmp
     ecpc_sol(ir) = ec_tmp
     vxpc_sol(ir) = vx_tmp(1)
     vcpc_sol(ir) = vc_tmp(1)
     
  end do
  
end subroutine calc_xc_lda_pz81_sol_kt
! ============================================================================ 4.0

!=====================================================================
   subroutine calc_xc_lda_pz81_ss(ier)
!=====================================================================
!
!  M. Okamoto
!
!---------------------------------------------------------------------
   use parameters
   implicit none
   integer,intent(out) :: ier
   integer :: ir, ispin
   real(8) :: rho1, rho2, rho1_tmp, &
              ex_tmp, ec_tmp, vx_tmp(2), vc_tmp(2), &
              rhomin = 1.d-35
   ier = 0
   do ir = 1,nmesh
      select case (is_spin_ss)
      case (RESTRICTED)
         select case (is_pcc)
         case (NONE)
            rho1_tmp = rho_ss(ir,1)
         case (PCC)
            rho1_tmp = rho_ss(ir,1) + rho_pcore(ir)
         case (FCC)
            rho1_tmp = rho_ss(ir,1) + rho_core(ir)
         end select
         rho1 = rho1_tmp*0.5d0 ; rho2 = rho1
      case (POLARIZED)
         select case (is_pcc)
         case (NONE)
            rho1 = rho_ss(ir,1)
            rho2 = rho_ss(ir,2)
         case (PCC)
            rho1 = rho_ss(ir,1) + rho_pcore(ir)*0.5d0
            rho2 = rho_ss(ir,2) + rho_pcore(ir)*0.5d0
         case (FCC)
            rho1 = rho_ss(ir,1) + rho_core(ir)*0.5d0
            rho2 = rho_ss(ir,2) + rho_core(ir)*0.5d0
         end select
       end select
      call lda_pz81(rho1,rho2,ex_tmp,ec_tmp,vx_tmp,vc_tmp)
      ex_ss(ir) = ex_tmp
      ec_ss(ir) = ec_tmp
      do ispin = 1,nspin_ss
         vx_ss(ir,ispin) = vx_tmp(ispin)
         vc_ss(ir,ispin) = vc_tmp(ispin)
      end do
   end do
   do ir = 1,nmesh
      select case (is_pcc)
      case (NONE)
         rho1_tmp = 0.d0
      case (PCC)
         rho1_tmp = rho_pcore(ir)
      case (FCC)
         rho1_tmp = rho_core(ir)
      end select
      rho1 = rho1_tmp*0.5d0 ; rho2 = rho1
      select case (is_pcc)
      case (PCC,FCC)
         call lda_pz81(rho1,rho2,ex_tmp,ec_tmp,vx_tmp,vc_tmp)
      case (NONE)
         ex_tmp    = 0.d0
         ec_tmp    = 0.d0
         vx_tmp(:) = 0.d0
         vc_tmp(:) = 0.d0
      end select
      expc_ss(ir) = ex_tmp
      ecpc_ss(ir) = ec_tmp
      do ispin = 1,nspin_ss
         vxpc_ss(ir,ispin) = vx_tmp(ispin)
         vcpc_ss(ir,ispin) = vc_tmp(ispin)
      end do
   end do
   end subroutine calc_xc_lda_pz81_ss

!=====================================================================
   subroutine calc_xc_lda_pw92_sol(ier)
!=====================================================================
!
!  M. Okamoto
!
!---------------------------------------------------------------------
   use parameters
   implicit none
   integer,intent(out) :: ier
   integer :: ir
   real(8) :: rho1, rho2, rho1_tmp, &
              ex_tmp, ec_tmp, vx_tmp(2), vc_tmp(2), &
              decdrs, decdzeta, &
              rhomin = 1.d-35
   ier = 0
   do ir = 1,nmesh
      select case (is_pcc)

! =================================== modified by K. T. ================== 4.0
!      case (NONE)
!         rho1_tmp = rho_sol(ir)
!      case (PCC)
!         rho1_tmp = rho_sol(ir) + rho_pcore(ir)
!      case (FCC)
!         rho1_tmp = rho_sol(ir) + rho_core(ir)
!      end select
!
      case (NONE)
         rho1_tmp = rho_sol(ir,1)
      case (PCC)
         rho1_tmp = rho_sol(ir,1) + rho_pcore(ir)
      case (FCC)
         rho1_tmp = rho_sol(ir,1) + rho_core(ir)
      end select
! ========================================================================= 4.0

      rho1 = rho1_tmp*0.5d0 ; rho2 = rho1
      call lda_pw92(rho1,rho2,ex_tmp,ec_tmp,vx_tmp,vc_tmp, &
                    decdrs,decdzeta)
      ex_sol(ir) = ex_tmp
      ec_sol(ir) = ec_tmp

! ==================================== modified by K. T. =================== 4.0
!      vx_sol(ir) = vx_tmp(1)
!      vc_sol(ir) = vc_tmp(1)
      vx_sol(ir,1) = vx_tmp(1)
      vc_sol(ir,1) = vc_tmp(1)
! ============================================================================ 4.0

   end do
   do ir = 1,nmesh
      select case (is_pcc)
      case (NONE)
         rho1_tmp = 0.d0
      case (PCC)
         rho1_tmp = rho_pcore(ir)
      case (FCC)
         rho1_tmp = rho_core(ir)
      end select
      rho1 = rho1_tmp*0.5d0 ; rho2 = rho1
      select case (is_pcc)
      case (PCC,FCC)
         call lda_pw92(rho1,rho2,ex_tmp,ec_tmp,vx_tmp,vc_tmp, &
                       decdrs,decdzeta)
      case (NONE)
         ex_tmp    = 0.d0
         ec_tmp    = 0.d0
         vx_tmp(:) = 0.d0
         vc_tmp(:) = 0.d0
      end select
      expc_sol(ir) = ex_tmp
      ecpc_sol(ir) = ec_tmp
      vxpc_sol(ir) = vx_tmp(1)
      vcpc_sol(ir) = vc_tmp(1)
   end do
   end subroutine calc_xc_lda_pw92_sol

! ======================================== added by K. T. ====================== 4.0
subroutine calc_xc_lda_pw92_sol_kt(ier)
  use parameters
  implicit none

  integer,intent(out) :: ier
  integer :: ir, ispin
  real(8) :: rho1, rho2, &
       ex_tmp, ec_tmp, vx_tmp(2), vc_tmp(2), &
       decdrs, decdzeta, &
       rhomin = 1.d-35
  real(8) :: rho_tmp(2)

  ier = 0

  do ir = 1,nmesh

     Do ispin=1, nspin

        select case (is_pcc)
        case (NONE)
           rho_tmp(ispin) = rho_sol(ir,ispin)
        case (PCC)
           rho_tmp(ispin) = rho_sol(ir,ispin) + rho_pcore(ir) /dble(nspin)
        case (FCC)
           rho_tmp(ispin) = rho_sol(ir,ispin) + rho_core(ir) /dble(nspin)
        end select

     End do

     if ( nspin == 1 ) then
        rho1 = rho_tmp(1) *0.5d0 ; rho2 = rho1
     else if ( nspin == 2 ) then
        rho1 = rho_tmp(1);  rho2 = rho_tmp(2)
     endif

     call lda_pw92(rho1,rho2,ex_tmp,ec_tmp,vx_tmp,vc_tmp, &
          decdrs,decdzeta)

     ex_sol(ir) = ex_tmp
     ec_sol(ir) = ec_tmp

     Do ispin=1, nspin
        vx_sol(ir,ispin) = vx_tmp(ispin)
        vc_sol(ir,ispin) = vc_tmp(ispin)
     End do

  end do

  do ir = 1,nmesh

     select case (is_pcc)
     case (NONE)
        rho_tmp(1) = 0.d0
     case (PCC)
        rho_tmp(1) = rho_pcore(ir)
     case (FCC)
        rho_tmp(1) = rho_core(ir)
     end select

     rho1 = rho_tmp(1) *0.5d0 ; rho2 = rho1

     select case (is_pcc)
     case (PCC,FCC)
        call lda_pw92(rho1,rho2,ex_tmp,ec_tmp,vx_tmp,vc_tmp, &
             decdrs,decdzeta)

     case (NONE)
        ex_tmp    = 0.d0
        ec_tmp    = 0.d0
        vx_tmp(:) = 0.d0
        vc_tmp(:) = 0.d0
     end select

     expc_sol(ir) = ex_tmp
     ecpc_sol(ir) = ec_tmp
     vxpc_sol(ir) = vx_tmp(1)
     vcpc_sol(ir) = vc_tmp(1)

  end do

end subroutine calc_xc_lda_pw92_sol_kt
! ============================================================================= 4.0

!=====================================================================
   subroutine calc_xc_lda_pw92_ss(ier)
!=====================================================================
!
!  M. Okamoto
!
!---------------------------------------------------------------------
   use parameters
   implicit none
   integer,intent(out) :: ier
   integer :: ir, ispin
   real(8) :: rho1, rho2, rho1_tmp, &
              ex_tmp, ec_tmp, vx_tmp(2), vc_tmp(2), &
              decdrs, decdzeta, &
              rhomin = 1.d-35
   ier = 0
   do ir = 1,nmesh
      select case (is_spin_ss)
      case (RESTRICTED)
         select case (is_pcc)
         case (NONE)
            rho1_tmp = rho_ss(ir,1)
         case (PCC)
            rho1_tmp = rho_ss(ir,1) + rho_pcore(ir)
         case (FCC)
            rho1_tmp = rho_ss(ir,1) + rho_core(ir)
         end select
         rho1 = rho1_tmp*0.5d0 ; rho2 = rho1
      case (POLARIZED)
         select case (is_pcc)
         case (NONE)
            rho1 = rho_ss(ir,1) ; rho2 = rho_ss(ir,2)
         case (PCC)
            rho1 = rho_ss(ir,1) + rho_pcore(ir)*0.5d0
            rho2 = rho_ss(ir,2) + rho_pcore(ir)*0.5d0
         case (FCC)
            rho1 = rho_ss(ir,1) + rho_core(ir)*0.5d0
            rho2 = rho_ss(ir,2) + rho_core(ir)*0.5d0
         end select
      end select
      call lda_pw92(rho1,rho2,ex_tmp,ec_tmp,vx_tmp,vc_tmp, &
                    decdrs,decdzeta)
      ex_ss(ir) = ex_tmp
      ec_ss(ir) = ec_tmp
      do ispin = 1,nspin_ss
         vx_ss(ir,ispin) = vx_tmp(ispin)
         vc_ss(ir,ispin) = vc_tmp(ispin)
      end do
   end do
   do ir = 1,nmesh
      select case (is_pcc)
      case (NONE)
         rho1_tmp = 0.d0
      case (PCC)
         rho1_tmp = rho_pcore(ir)
      case (FCC)
         rho1_tmp = rho_core(ir)
      end select
      rho1 = rho1_tmp*0.5d0 ; rho2 = rho1
      select case (is_pcc)
      case (PCC,FCC)
         call lda_pw92(rho1,rho2,ex_tmp,ec_tmp,vx_tmp,vc_tmp, &
                       decdrs,decdzeta)
      case (NONE)
         ex_tmp    = 0.d0
         ec_tmp    = 0.d0
         vx_tmp(:) = 0.d0
         vc_tmp(:) = 0.d0
      end select
      expc_ss(ir) = ex_tmp
      ecpc_ss(ir) = ec_tmp
      do ispin = 1,nspin_ss
         vxpc_ss(ir,ispin) = vx_tmp(ispin)
         vcpc_ss(ir,ispin) = vc_tmp(ispin)
      end do
   end do
   end subroutine calc_xc_lda_pw92_ss

!=====================================================================
   subroutine calc_xc_gga_pbe96_sol(ier,imode)
!=====================================================================
!
!  M. Okamoto
!
!---------------------------------------------------------------------
   use parameters
   implicit none
   integer,intent(in)  :: imode
   integer,intent(out) :: ier
   integer :: ir
   real(8) :: r, rho1, rho2, drho1, drho2, ddrho1, ddrho2, &
              rho1_tmp, drho1_tmp, ddrho1_tmp, &
              ex_tmp, ec_tmp, vx_tmp(2), vc_tmp(2), &
              rhomin = 1.d-35, eps_chg = 1.d-25
   ier = 0
   do ir = 1,nmesh
      select case (is_pcc)

! ====================================== modified by K. T. ============== 4.0
!      case (NONE)
!           rho1_tmp =   rho_sol(ir)
!          drho1_tmp =  drho_sol(ir)
!         ddrho1_tmp = ddrho_sol(ir)
!      case (PCC)
!           rho1_tmp =   rho_sol(ir) +   rho_pcore(ir)
!          drho1_tmp =  drho_sol(ir) +  drho_pcore(ir)
!         ddrho1_tmp = ddrho_sol(ir) + ddrho_pcore(ir)
!      case (FCC)
!           rho1_tmp =   rho_sol(ir) +   rho_core(ir)
!          drho1_tmp =  drho_sol(ir) +  drho_core(ir)
!         ddrho1_tmp = ddrho_sol(ir) + ddrho_core(ir)
!      end select
!
      case (NONE)
           rho1_tmp =   rho_sol(ir,1)
          drho1_tmp =  drho_sol(ir,1)
         ddrho1_tmp = ddrho_sol(ir,1)
      case (PCC)
           rho1_tmp =   rho_sol(ir,1) +   rho_pcore(ir)
          drho1_tmp =  drho_sol(ir,1) +  drho_pcore(ir)
         ddrho1_tmp = ddrho_sol(ir,1) + ddrho_pcore(ir)
      case (FCC)
           rho1_tmp =   rho_sol(ir,1) +   rho_core(ir)
          drho1_tmp =  drho_sol(ir,1) +  drho_core(ir)
         ddrho1_tmp = ddrho_sol(ir,1) + ddrho_core(ir)
      end select
! ======================================================================= 4.0

        rho1 =    rho1_tmp*0.5d0 ;    rho2 =    rho1
       drho1 =   drho1_tmp*0.5d0 ;   drho2 =   drho1
      ddrho1 =  ddrho1_tmp*0.5d0 ;  ddrho2 =  ddrho1
      if (rho1 < rhomin) then
           rho1 = rhomin ;   rho2 = rho1
          drho1 =   0.d0 ;  drho2 = 0.d0
         ddrho1 =   0.d0 ; ddrho2 = 0.d0
      end if
      r = rpos(ir)
      call gga_pbe96_spherical(imode, &
                 r,rho1,rho2,drho1,drho2,ddrho1,ddrho2, &
                 ex_tmp,ec_tmp,vx_tmp,vc_tmp)
      ex_sol(ir) = ex_tmp
      ec_sol(ir) = ec_tmp
      if (rho1 < eps_chg) then
         ec_sol(ir) = 0.d0    
      end if

! =================================== modified by K. T. ============ 4.0
!      vx_sol(ir) = vx_tmp(1)
!      vc_sol(ir) = vc_tmp(1)
!      if (rho1 < eps_chg) then
!         vc_sol(ir) = 0.d0
!      end if
!
      vx_sol(ir,1) = vx_tmp(1)
      vc_sol(ir,1) = vc_tmp(1)
      if (rho1 < eps_chg) then
         vc_sol(ir,1) = 0.d0
      end if
! =================================================================== 4.0

   end do
   do ir = 1,nmesh
      select case (is_pcc)
      case (NONE)
           rho1_tmp = 0.d0
          drho1_tmp = 0.d0
         ddrho1_tmp = 0.d0
      case (PCC)
           rho1_tmp =   rho_pcore(ir)
          drho1_tmp =  drho_pcore(ir)
         ddrho1_tmp = ddrho_pcore(ir)
      case (FCC)
           rho1_tmp =   rho_core(ir)
          drho1_tmp =  drho_core(ir)
         ddrho1_tmp = ddrho_core(ir)
      end select
        rho1 =    rho1_tmp*0.5d0 ;    rho2 =    rho1
       drho1 =   drho1_tmp*0.5d0 ;   drho2 =   drho1
      ddrho1 =  ddrho1_tmp*0.5d0 ;  ddrho2 =  ddrho1
      if (rho1 < rhomin) then
           rho1 = rhomin ;   rho2 = rho1
          drho1 =   0.d0 ;  drho2 = 0.d0
         ddrho1 =   0.d0 ; ddrho2 = 0.d0
      end if
      r = rpos(ir)
      select case (is_pcc)
      case (PCC,FCC)
         call gga_pbe96_spherical(imode, &
                 r,rho1,rho2,drho1,drho2,ddrho1,ddrho2, &
                 ex_tmp,ec_tmp,vx_tmp,vc_tmp)
      case (NONE)
         ex_tmp = 0.d0
         ec_tmp = 0.d0
         vx_tmp(:) = 0.d0
         vc_tmp(:) = 0.d0
      end select
      expc_sol(ir) = ex_tmp
      ecpc_sol(ir) = ec_tmp
      if (rho1 < eps_chg) then
         ecpc_sol(ir) = 0.d0    
      end if
      vxpc_sol(ir) = vx_tmp(1)
      vcpc_sol(ir) = vc_tmp(1)
      if (rho1 < eps_chg) then
         vcpc_sol(ir) = 0.d0
      end if
   end do
   end subroutine calc_xc_gga_pbe96_sol

!================================== added by K. T. ======================= 4.0
subroutine calc_xc_gga_pbe96_sol_kt(ier,imode)
  use parameters
  implicit none

  integer,intent(in)  :: imode
  integer,intent(out) :: ier
  integer :: ir, ispin

  real(8) :: r, rho1, rho2, drho1, drho2, ddrho1, ddrho2, &
       rho_tmp(2), drho_tmp(2), ddrho_tmp(2), &
       ex_tmp, ec_tmp, vx_tmp(2), vc_tmp(2), &
       rhomin = 1.d-35, eps_chg = 1.d-25

  ier = 0

  do ir = 1,nmesh

     Do ispin=1, nspin
        
        select case (is_pcc)
        case (NONE)
             rho_tmp(ispin) =   rho_sol(ir,ispin)
            drho_tmp(ispin) =  drho_sol(ir,ispin)
           ddrho_tmp(ispin) = ddrho_sol(ir,ispin)
        case (PCC)
             rho_tmp(ispin) =   rho_sol(ir,ispin) +   rho_pcore(ir)/dble(nspin)
            drho_tmp(ispin) =  drho_sol(ir,ispin) +  drho_pcore(ir)/dble(nspin)
           ddrho_tmp(ispin) = ddrho_sol(ir,ispin) + ddrho_pcore(ir)/dble(nspin)
        case (FCC)
             rho_tmp(ispin) =   rho_sol(ir,ispin) +   rho_core(ir)/dble(nspin)
            drho_tmp(ispin) =  drho_sol(ir,ispin) +  drho_core(ir)/dble(nspin)
           ddrho_tmp(ispin) = ddrho_sol(ir,ispin) + ddrho_core(ir)/dble(nspin)
        end select
     End do

     if ( nspin == 1 ) then
          rho1 =    rho_tmp(1)*0.5d0 ;    rho2 =    rho1
         drho1 =   drho_tmp(1)*0.5d0 ;   drho2 =   drho1
        ddrho1 =  ddrho_tmp(1)*0.5d0 ;  ddrho2 =  ddrho1

        if (rho1 < rhomin) then
             rho1 = rhomin ;   rho2 = rho1
            drho1 =   0.d0 ;  drho2 = 0.d0
           ddrho1 =   0.d0 ; ddrho2 = 0.d0
        endif

     else if ( nspin == 2 ) then
          rho1 =    rho_tmp(1);    rho2 =    rho_tmp(2)
         drho1 =   drho_tmp(1);   drho2 =   drho_tmp(2)
        ddrho1 =  ddrho_tmp(1);  ddrho2 =  ddrho_tmp(2)

        if (rho1 < rhomin) then
             rho1 = rhomin;      drho1 = 0.d0;     ddrho1 = 0.d0
        endif
        if (rho2 < rhomin) then
             rho2 = rhomin;      drho2 = 0.d0;     ddrho2 = 0.d0
        endif

     end if

     r = rpos(ir)
     call gga_pbe96_spherical(imode, &
          r,rho1,rho2,drho1,drho2,ddrho1,ddrho2, &
          ex_tmp,ec_tmp,vx_tmp,vc_tmp)
     ex_sol(ir) = ex_tmp
     ec_sol(ir) = ec_tmp

     if ( nspin == 1 ) then
        if (rho1 < eps_chg) then
           ec_sol(ir) = 0.d0    
        end if
     else if ( nspin ==2 ) then
        if (rho1 +rho2 < eps_chg) then
           ec_sol(ir) = 0.d0    
        end if
     endif

     Do ispin=1, nspin
        vx_sol(ir,ispin) = vx_tmp(ispin)
        vc_sol(ir,ispin) = vc_tmp(ispin)
     End do

     if ( nspin == 1 ) then
        if (rho1 < eps_chg) then
           vc_sol(ir,1) = 0.d0
        end if
     else if ( nspin == 2 ) then
        if (rho1 < eps_chg) then
           vc_sol(ir,1) = 0.d0
        end if
        if (rho2 < eps_chg) then
           vc_sol(ir,2) = 0.d0
        end if
     endif

  end do

  do ir = 1,nmesh

     select case (is_pcc)
     case (NONE)
          rho_tmp(1) = 0.d0
         drho_tmp(1) = 0.d0
        ddrho_tmp(1) = 0.d0
     case (PCC)
          rho_tmp(1) =   rho_pcore(ir)
         drho_tmp(1) =  drho_pcore(ir)
        ddrho_tmp(1) = ddrho_pcore(ir)
     case (FCC)
          rho_tmp(1) =   rho_core(ir)
         drho_tmp(1) =  drho_core(ir)
        ddrho_tmp(1) = ddrho_core(ir)
     end select

       rho1 =    rho_tmp(1)*0.5d0 ;    rho2 =    rho1
      drho1 =   drho_tmp(1)*0.5d0 ;   drho2 =   drho1
     ddrho1 =  ddrho_tmp(1)*0.5d0 ;  ddrho2 =  ddrho1

     
     if (rho1 < rhomin) then
          rho1 = rhomin ;   rho2 = rho1
         drho1 =   0.d0 ;  drho2 = 0.d0
        ddrho1 =   0.d0 ; ddrho2 = 0.d0
     end if

     r = rpos(ir)

     select case (is_pcc)

     case (PCC,FCC)
        call gga_pbe96_spherical(imode, &
             r,rho1,rho2,drho1,drho2,ddrho1,ddrho2, &
             ex_tmp,ec_tmp,vx_tmp,vc_tmp)

     case (NONE)
        ex_tmp = 0.d0
        ec_tmp = 0.d0
        vx_tmp(:) = 0.d0
        vc_tmp(:) = 0.d0
     end select

     expc_sol(ir) = ex_tmp
     ecpc_sol(ir) = ec_tmp

     if (rho1 < eps_chg) then
        ecpc_sol(ir) = 0.d0    
     end if

     vxpc_sol(ir) = vx_tmp(1)
     vcpc_sol(ir) = vc_tmp(1)
     if (rho1 < eps_chg) then
        vcpc_sol(ir) = 0.d0
     end if

  end do

end subroutine calc_xc_gga_pbe96_sol_kt
! ========================================================================= 4.0

!=====================================================================
   subroutine calc_xc_gga_pbe96_ss(ier,imode)
!=====================================================================
!
!  M. Okamoto
!
!---------------------------------------------------------------------
   use parameters
   implicit none
   integer,intent(in)  :: imode
   integer,intent(out) :: ier
   integer :: ir, ispin
   real(8) :: r, rho1, rho2, drho1, drho2, ddrho1, ddrho2, &
              rho1_tmp, drho1_tmp, ddrho1_tmp, &
              ex_tmp, ec_tmp, vx_tmp(2), vc_tmp(2), &
              rhomin = 1.d-35, eps_chg = 1.d-25
   ier = 0
   do ir = 1,nmesh
      select case (is_spin_ss)
      case (RESTRICTED)
         select case (is_pcc)
         case (NONE)
              rho1_tmp =   rho_ss(ir,1)
             drho1_tmp =  drho_ss(ir,1)
            ddrho1_tmp = ddrho_ss(ir,1)
         case (PCC)
              rho1_tmp =   rho_ss(ir,1) +   rho_pcore(ir)
             drho1_tmp =  drho_ss(ir,1) +  drho_pcore(ir)
            ddrho1_tmp = ddrho_ss(ir,1) + ddrho_pcore(ir)
         case (FCC)
              rho1_tmp =   rho_ss(ir,1) +   rho_core(ir)
             drho1_tmp =  drho_ss(ir,1) +  drho_core(ir)
            ddrho1_tmp = ddrho_ss(ir,1) + ddrho_core(ir)
         end select
           rho1 =    rho1_tmp*0.5d0 ;    rho2 =    rho1
          drho1 =   drho1_tmp*0.5d0 ;   drho2 =   drho1
         ddrho1 =  ddrho1_tmp*0.5d0 ;  ddrho2 =  ddrho1
         if (rho1 < rhomin) then
              rho1 = rhomin ;   rho2 = rho1
             drho1 =   0.d0 ;  drho2 = 0.d0
            ddrho1 =   0.d0 ; ddrho2 = 0.d0
         end if
      case (POLARIZED)
         select case (is_pcc)
         case (NONE)
              rho1 =   rho_ss(ir,1) ;   rho2 =   rho_ss(ir,2)
             drho1 =  drho_ss(ir,1) ;  drho2 =  drho_ss(ir,2)
            ddrho1 = ddrho_ss(ir,1) ; ddrho2 = ddrho_ss(ir,2)
         case (PCC)
              rho1 =   rho_ss(ir,1) +   rho_pcore(ir)*0.5d0
             drho1 =  drho_ss(ir,1) +  drho_pcore(ir)*0.5d0
            ddrho1 = ddrho_ss(ir,1) + ddrho_pcore(ir)*0.5d0
              rho2 =   rho_ss(ir,2) +   rho_pcore(ir)*0.5d0
             drho2 =  drho_ss(ir,2) +  drho_pcore(ir)*0.5d0
            ddrho2 = ddrho_ss(ir,2) + ddrho_pcore(ir)*0.5d0
         case (FCC)
              rho1 =   rho_ss(ir,1) +   rho_core(ir)*0.5d0
             drho1 =  drho_ss(ir,1) +  drho_core(ir)*0.5d0
            ddrho1 = ddrho_ss(ir,1) + ddrho_core(ir)*0.5d0
              rho2 =   rho_ss(ir,2) +   rho_core(ir)*0.5d0
             drho2 =  drho_ss(ir,2) +  drho_core(ir)*0.5d0
            ddrho2 = ddrho_ss(ir,2) + ddrho_core(ir)*0.5d0
         end select
         if (rho1 < rhomin) then
              rho1 = rhomin
             drho1 =   0.d0
            ddrho1 =   0.d0
         end if
         if (rho2 < rhomin) then
              rho2 = rhomin
             drho2 =   0.d0
            ddrho2 =   0.d0
         end if
      end select
      r = rpos(ir)
      call gga_pbe96_spherical(imode, &
                 r,rho1,rho2,drho1,drho2,ddrho1,ddrho2, &
                 ex_tmp,ec_tmp,vx_tmp,vc_tmp)
      ex_ss(ir) = ex_tmp
      ec_ss(ir) = ec_tmp
      if (max(rho1,rho2) < eps_chg) then
         ec_ss(ir) = 0.d0    
      end if
      do ispin = 1,nspin_ss
         vx_ss(ir,ispin) = vx_tmp(ispin)
         vc_ss(ir,ispin) = vc_tmp(ispin)
      end do
      if (rho1 < eps_chg) then
         vc_ss(ir,1) = 0.d0
      end if
      if ((rho2 < eps_chg).and.(nspin_ss == 2)) then
         vc_ss(ir,2) = 0.d0
      end if
   end do
   do ir = 1,nmesh
      select case (is_pcc)
      case (NONE)
           rho1_tmp = 0.d0
          drho1_tmp = 0.d0
         ddrho1_tmp = 0.d0
      case (PCC)
           rho1_tmp =   rho_pcore(ir)
          drho1_tmp =  drho_pcore(ir)
         ddrho1_tmp = ddrho_pcore(ir)
      case (FCC)
           rho1_tmp =   rho_core(ir)
          drho1_tmp =  drho_core(ir)
         ddrho1_tmp = ddrho_core(ir)
      end select
        rho1 =    rho1_tmp*0.5d0 ;    rho2 =    rho1
       drho1 =   drho1_tmp*0.5d0 ;   drho2 =   drho1
      ddrho1 =  ddrho1_tmp*0.5d0 ;  ddrho2 =  ddrho1
      if (rho1 < rhomin) then
           rho1 = rhomin ;   rho2 = rho1
          drho1 =   0.d0 ;  drho2 = 0.d0
         ddrho1 =   0.d0 ; ddrho2 = 0.d0
      end if
      r = rpos(ir)
      select case (is_pcc)
      case (PCC,FCC)
         call gga_pbe96_spherical(imode, &
                 r,rho1,rho2,drho1,drho2,ddrho1,ddrho2, &
                 ex_tmp,ec_tmp,vx_tmp,vc_tmp)
      case (NONE)
         ex_tmp = 0.d0
         ec_tmp = 0.d0
         vx_tmp(:) = 0.d0
         vc_tmp(:) = 0.d0
      end select
      expc_ss(ir) = ex_tmp
      ecpc_ss(ir) = ec_tmp
      if (max(rho1,rho2) < eps_chg) then
         ecpc_ss(ir) = 0.d0
      end if
      do ispin = 1,nspin_ss
         vxpc_ss(ir,ispin) = vx_tmp(ispin)
         vcpc_ss(ir,ispin) = vc_tmp(ispin)
      end do
      if (rho1 < eps_chg) then
         vcpc_ss(ir,1) = 0.d0
      end if
      if ((rho2 < eps_chg).and.(nspin_ss == 2)) then
         vcpc_ss(ir,2) = 0.d0
      end if
   end do
   end subroutine calc_xc_gga_pbe96_ss

!=====================================================================
   subroutine calc_xc_gga_pbe96_rad_sol(ier,imode)
!=====================================================================
!
!  M. Okamoto
!
!---------------------------------------------------------------------
   use parameters
   implicit none
   integer,intent(in)  :: imode
   integer,intent(out) :: ier
   ier = 0
   select case (is_pcc)

! ====================================== modified by K. T. ============= 4.0
!   case (NONE)
!       rho1_rad(:) =  rho_sol(:) * 0.5d0
!      drho1_rad(:) = drho_sol(:) * 0.5d0
!   case (PCC)
!       rho1_rad(:) = ( rho_sol(:) +  rho_pcore(:)) * 0.5d0
!      drho1_rad(:) = (drho_sol(:) + drho_pcore(:)) * 0.5d0
!   case (FCC)
!       rho1_rad(:) = ( rho_sol(:) +  rho_core(:)) * 0.5d0
!      drho1_rad(:) = (drho_sol(:) + drho_core(:)) * 0.5d0
!   end select
!
   case (NONE)
       rho1_rad(:) =  rho_sol(:,1) * 0.5d0
      drho1_rad(:) = drho_sol(:,1) * 0.5d0
   case (PCC)
       rho1_rad(:) = ( rho_sol(:,1) +  rho_pcore(:)) * 0.5d0
      drho1_rad(:) = (drho_sol(:,1) + drho_pcore(:)) * 0.5d0
   case (FCC)
       rho1_rad(:) = ( rho_sol(:,1) +  rho_core(:)) * 0.5d0
      drho1_rad(:) = (drho_sol(:,1) + drho_core(:)) * 0.5d0
   end select
! ================================================================== 4.0

    rho2_rad(:) =  rho1_rad(:)
   drho2_rad(:) = drho1_rad(:)
   call gga_fxc_rmesh( &
      ier,IFLOG,imode+1,iord_diff,nmesh,1,               &
      rpos,wr,rho1_rad,rho2_rad,drho1_rad,drho2_rad,     &
      fx_rad,fc_rad,dfx_rad,dfc_rad,dfxda_rad,dfcda_rad, &
      vx_sol,vc_sol,ex_sol,ec_sol,ex_sum_sol,ec_sum_sol)
   if (ier /= 0) then
      write(IFLOG,*) '### ERROR ### in gga_fxc_rmesh' ; go to 99
   end if
   select case (is_pcc)
   case (NONE)
       rho1_rad(:) = 0.d0
      drho1_rad(:) = 0.d0
   case (PCC)
       rho1_rad(:) =  rho_pcore(:) * 0.5d0
      drho1_rad(:) = drho_pcore(:) * 0.5d0
   case (FCC)
       rho1_rad(:) =  rho_core(:) * 0.5d0
      drho1_rad(:) = drho_core(:) * 0.5d0
   end select
    rho2_rad(:) =  rho1_rad(:)
   drho2_rad(:) = drho1_rad(:)
   if (is_pcc == NONE) then
      vxpc_sol(:)  = 0.d0 ; vcpc_sol(:)  = 0.d0
      expc_sol(:)  = 0.d0 ; ecpc_sol(:)  = 0.d0
      expc_sum_sol = 0.d0 ; ecpc_sum_sol = 0.d0
   else
      call gga_fxc_rmesh( &
         ier,IFLOG,imode+1,iord_diff,nmesh,1,               &
         rpos,wr,rho1_rad,rho2_rad,drho1_rad,drho2_rad,     &
         fx_rad,fc_rad,dfx_rad,dfc_rad,dfxda_rad,dfcda_rad, &
         vxpc_sol,vcpc_sol,expc_sol,ecpc_sol,               &
         expc_sum_sol,ecpc_sum_sol)
      expc_sum_sol = - expc_sum_sol
      ecpc_sum_sol = - ecpc_sum_sol
      if (ier /= 0) then
         write(IFLOG,*) '### ERROR ### in gga_fxc_rmesh' ; go to 99
      end if
   end if
99 continue
   end subroutine calc_xc_gga_pbe96_rad_sol

!======================================= added by K. T. ================== 4.0
subroutine calc_xc_gga_pbe96_rad_sol_kt(ier,imode)
  use parameters
  implicit none
  integer,intent(in)  :: imode
  integer,intent(out) :: ier

  ier = 0

  if ( nspin == 1 ) then

     select case (is_pcc)
     case (NONE)
         rho1_rad(:) =  rho_sol(:,1) * 0.5d0
        drho1_rad(:) = drho_sol(:,1) * 0.5d0
     case (PCC)
         rho1_rad(:) = ( rho_sol(:,1) +  rho_pcore(:)) * 0.5d0
        drho1_rad(:) = (drho_sol(:,1) + drho_pcore(:)) * 0.5d0
     case (FCC)
         rho1_rad(:) = ( rho_sol(:,1) +  rho_core(:)) * 0.5d0
        drho1_rad(:) = (drho_sol(:,1) + drho_core(:)) * 0.5d0
     end select

      rho2_rad(:) =  rho1_rad(:)
     drho2_rad(:) = drho1_rad(:)

  else if ( nspin == 2 ) then

     select case (is_pcc)
     case (NONE)
         rho1_rad(:) =  rho_sol(:,1)
        drho1_rad(:) = drho_sol(:,1)
         rho2_rad(:) =  rho_sol(:,2)
        drho2_rad(:) = drho_sol(:,2)
     case (PCC)
         rho1_rad(:) =  rho_sol(:,1) +  rho_pcore(:)*0.5d0
        drho1_rad(:) = drho_sol(:,1) + drho_pcore(:)*0.5d0
         rho2_rad(:) =  rho_sol(:,2) +  rho_pcore(:)*0.5d0
        drho2_rad(:) = drho_sol(:,2) + drho_pcore(:)*0.5d0
     case (FCC)
         rho1_rad(:) =  rho_sol(:,1) +  rho_core(:)*0.5d0 
        drho1_rad(:) = drho_sol(:,1) + drho_core(:)*0.5d0
         rho2_rad(:) =  rho_sol(:,2) +  rho_core(:)*0.5d0 
        drho2_rad(:) = drho_sol(:,2) + drho_core(:)*0.5d0
     end select

  endif

  call gga_fxc_rmesh( &
       ier,IFLOG,imode+1,iord_diff,nmesh, nspin,               &
       rpos,wr,rho1_rad,rho2_rad,drho1_rad,drho2_rad,     &
       fx_rad,fc_rad,dfx_rad,dfc_rad,dfxda_rad,dfcda_rad, &
       vx_sol,vc_sol,ex_sol,ec_sol,ex_sum_sol,ec_sum_sol)

  if (ier /= 0) then
     write(IFLOG,*) '### ERROR ### in gga_fxc_rmesh' ; go to 99
  end if

  select case (is_pcc)
  case (NONE)
      rho1_rad(:) = 0.d0
     drho1_rad(:) = 0.d0
  case (PCC)
      rho1_rad(:) =  rho_pcore(:) * 0.5d0
     drho1_rad(:) = drho_pcore(:) * 0.5d0
  case (FCC)
      rho1_rad(:) =  rho_core(:) * 0.5d0
     drho1_rad(:) = drho_core(:) * 0.5d0
  end select
  rho2_rad(:) =  rho1_rad(:)
  drho2_rad(:) = drho1_rad(:)

  if (is_pcc == NONE) then
     vxpc_sol(:)  = 0.d0 ; vcpc_sol(:)  = 0.d0
     expc_sol(:)  = 0.d0 ; ecpc_sol(:)  = 0.d0
     expc_sum_sol = 0.d0 ; ecpc_sum_sol = 0.d0

  else
     call gga_fxc_rmesh( &
          ier,IFLOG,imode+1,iord_diff,nmesh,1,               &
          rpos,wr,rho1_rad,rho2_rad,drho1_rad,drho2_rad,     &
          fx_rad,fc_rad,dfx_rad,dfc_rad,dfxda_rad,dfcda_rad, &
          vxpc_sol,vcpc_sol,expc_sol,ecpc_sol,               &
          expc_sum_sol,ecpc_sum_sol)
     expc_sum_sol = - expc_sum_sol
     ecpc_sum_sol = - ecpc_sum_sol
     
     if (ier /= 0) then
        write(IFLOG,*) '### ERROR ### in gga_fxc_rmesh' ; go to 99
     end if
  end if

99 continue

end subroutine calc_xc_gga_pbe96_rad_sol_kt
! =========================================================================== 4.0

!=====================================================================
   subroutine calc_xc_gga_pbe96_rad_ss(ier,imode)
!=====================================================================
!
!  M. Okamoto
!
!---------------------------------------------------------------------
   use parameters
   implicit none
   integer,intent(in)  :: imode
   integer,intent(out) :: ier
   ier = 0
   if (is_spin_ss == POLARIZED) then
      select case (is_pcc)
      case (NONE)
          rho1_rad(:) =  rho_ss(:,1)
         drho1_rad(:) = drho_ss(:,1)
          rho2_rad(:) =  rho_ss(:,2)
         drho2_rad(:) = drho_ss(:,2)
      case (PCC)
          rho1_rad(:) =  rho_ss(:,1) +  rho_pcore(:) * 0.5d0
         drho1_rad(:) = drho_ss(:,1) + drho_pcore(:) * 0.5d0
          rho2_rad(:) =  rho_ss(:,2) +  rho_pcore(:) * 0.5d0
         drho2_rad(:) = drho_ss(:,2) + drho_pcore(:) * 0.5d0
      case (FCC)
          rho1_rad(:) =  rho_ss(:,1) +  rho_core(:) * 0.5d0
         drho1_rad(:) = drho_ss(:,1) + drho_core(:) * 0.5d0
          rho2_rad(:) =  rho_ss(:,2) +  rho_core(:) * 0.5d0
         drho2_rad(:) = drho_ss(:,2) + drho_core(:) * 0.5d0
      end select
   else
      select case (is_pcc)
      case (NONE)
          rho1_rad(:) =  rho_ss(:,1) * 0.5d0
         drho1_rad(:) = drho_ss(:,1) * 0.5d0
      case (PCC)
          rho1_rad(:) = ( rho_ss(:,1) +  rho_pcore(:)) * 0.5d0
         drho1_rad(:) = (drho_ss(:,1) + drho_pcore(:)) * 0.5d0
      case (FCC)
          rho1_rad(:) = ( rho_ss(:,1) +  rho_core(:)) * 0.5d0
         drho1_rad(:) = (drho_ss(:,1) + drho_core(:)) * 0.5d0
      end select
       rho2_rad(:) =  rho1_rad(:)
      drho2_rad(:) = drho1_rad(:)
   end if
   call gga_fxc_rmesh( &
      ier,IFLOG,imode+1,iord_diff,nmesh,nspin_ss,        &
      rpos,wr,rho1_rad,rho2_rad,drho1_rad,drho2_rad,     &
      fx_rad,fc_rad,dfx_rad,dfc_rad,dfxda_rad,dfcda_rad, &
      vx_ss,vc_ss,ex_ss,ec_ss,ex_sum_ss,ec_sum_ss)
   if (ier /= 0) then
      write(IFLOG,*) '### ERROR ### in gga_fxc_rmesh' ; go to 99
   end if
   select case (is_pcc)
   case (NONE)
       rho1_rad(:) = 0.d0
      drho1_rad(:) = 0.d0
   case (PCC)
       rho1_rad(:) =  rho_pcore(:) * 0.5d0
      drho1_rad(:) = drho_pcore(:) * 0.5d0
   case (FCC)
       rho1_rad(:) =  rho_core(:) * 0.5d0
      drho1_rad(:) = drho_core(:) * 0.5d0
   end select
    rho2_rad(:) =  rho1_rad(:)
   drho2_rad(:) = drho1_rad(:)
   if (is_pcc == NONE) then
      vxpc_ss(:,:) = 0.d0 ; vcpc_ss(:,:) = 0.d0
      expc_ss(:)   = 0.d0 ; ecpc_ss(:)   = 0.d0
      expc_sum_ss  = 0.d0 ; ecpc_sum_ss  = 0.d0      
   else
      call gga_fxc_rmesh( &
         ier,IFLOG,imode+1,iord_diff,nmesh,nspin_ss,        &
         rpos,wr,rho1_rad,rho2_rad,drho1_rad,drho2_rad,     &
         fx_rad,fc_rad,dfx_rad,dfc_rad,dfxda_rad,dfcda_rad, &
         vxpc_ss,vcpc_ss,expc_ss,ecpc_ss,                   &
         expc_sum_ss,ecpc_sum_ss)
      expc_sum_ss = - expc_sum_ss
      ecpc_sum_ss = - ecpc_sum_ss
      if (ier /= 0) then
         write(IFLOG,*) '### ERROR ### in gga_fxc_rmesh' ; go to 99
      end if
   end if
99 continue
   end subroutine calc_xc_gga_pbe96_rad_ss

!=====================================================================
   subroutine calc_xc_gga_pw91_rad_sol(ier)
!=====================================================================
!
!  M. Okamoto
!
!---------------------------------------------------------------------
   use parameters
   implicit none
   integer,intent(out) :: ier
   ier = 0
   select case (is_pcc)

! ===================================== modified by K. T. ================ 4.0
!   case (NONE)
!       rho1_rad(:) =  rho_sol(:) * 0.5d0
!      drho1_rad(:) = drho_sol(:) * 0.5d0
!   case (PCC)
!       rho1_rad(:) = ( rho_sol(:) +  rho_pcore(:)) * 0.5d0
!      drho1_rad(:) = (drho_sol(:) + drho_pcore(:)) * 0.5d0
!   case (FCC)
!       rho1_rad(:) = ( rho_sol(:) +  rho_core(:)) * 0.5d0
!      drho1_rad(:) = (drho_sol(:) + drho_core(:)) * 0.5d0
!   end select
!
   case (NONE)
       rho1_rad(:) =  rho_sol(:,1) * 0.5d0
      drho1_rad(:) = drho_sol(:,1) * 0.5d0
   case (PCC)
       rho1_rad(:) = ( rho_sol(:,1) +  rho_pcore(:)) * 0.5d0
      drho1_rad(:) = (drho_sol(:,1) + drho_pcore(:)) * 0.5d0
   case (FCC)
       rho1_rad(:) = ( rho_sol(:,1) +  rho_core(:)) * 0.5d0
      drho1_rad(:) = (drho_sol(:,1) + drho_core(:)) * 0.5d0
   end select
! ===================================================================== 4.0


    rho2_rad(:) =  rho1_rad(:)
   drho2_rad(:) = drho1_rad(:)
   call gga_fxc_rmesh( &
      ier,IFLOG,3,iord_diff,nmesh,1,                     &
      rpos,wr,rho1_rad,rho2_rad,drho1_rad,drho2_rad,     &
      fx_rad,fc_rad,dfx_rad,dfc_rad,dfxda_rad,dfcda_rad, &
      vx_sol,vc_sol,ex_sol,ec_sol,ex_sum_sol,ec_sum_sol)
   if (ier /= 0) then
      write(IFLOG,*) '### ERROR ### in gga_fxc_rmesh' ; go to 99
   end if
   select case (is_pcc)
   case (NONE)
       rho1_rad(:) = 0.d0
      drho1_rad(:) = 0.d0
   case (PCC)
       rho1_rad(:) =  rho_pcore(:) * 0.5d0
      drho1_rad(:) = drho_pcore(:) * 0.5d0
   case (FCC)
       rho1_rad(:) =  rho_core(:) * 0.5d0
      drho1_rad(:) = drho_core(:) * 0.5d0
   end select
    rho2_rad(:) =  rho1_rad(:)
   drho2_rad(:) = drho1_rad(:)
   if (is_pcc == NONE) then
      vxpc_sol(:)  = 0.d0 ; vcpc_sol(:)  = 0.d0
      expc_sol(:)  = 0.d0 ; ecpc_sol(:)  = 0.d0
      expc_sum_sol = 0.d0 ; ecpc_sum_sol = 0.d0
   else
      call gga_fxc_rmesh( &
         ier,IFLOG,3,iord_diff,nmesh,1,                     &
         rpos,wr,rho1_rad,rho2_rad,drho1_rad,drho2_rad,     &
         fx_rad,fc_rad,dfx_rad,dfc_rad,dfxda_rad,dfcda_rad, &
         vxpc_sol,vcpc_sol,expc_sol,ecpc_sol,               &
         expc_sum_sol,ecpc_sum_sol)
         expc_sum_sol = - expc_sum_sol
         ecpc_sum_sol = - ecpc_sum_sol
      if (ier /= 0) then
         write(IFLOG,*) '### ERROR ### in gga_fxc_rmesh' ; go to 99
      end if
   end if
99 continue
   end subroutine calc_xc_gga_pw91_rad_sol

! ================================================== added by K. T. ============= 4.0
subroutine calc_xc_gga_pw91_rad_sol_kt(ier)
  use parameters
  implicit none

  integer,intent(out) :: ier
  integer :: ispin

  ier = 0

  if ( nspin == 1 ) then

     select case (is_pcc)

     case (NONE)
         rho1_rad(:) =  rho_sol(:,1) * 0.5d0
        drho1_rad(:) = drho_sol(:,1) * 0.5d0
     case (PCC)
         rho1_rad(:) = ( rho_sol(:,1) +  rho_pcore(:)) * 0.5d0
        drho1_rad(:) = (drho_sol(:,1) + drho_pcore(:)) * 0.5d0
     case (FCC)
         rho1_rad(:) = ( rho_sol(:,1) +  rho_core(:)) * 0.5d0
        drho1_rad(:) = (drho_sol(:,1) + drho_core(:)) * 0.5d0
     end select

      rho2_rad(:) =  rho1_rad(:)
     drho2_rad(:) = drho1_rad(:)
 
  else if ( nspin == 2 ) then

     select case (is_pcc)

     case (NONE)
         rho1_rad(:) =  rho_sol(:,1)
        drho1_rad(:) = drho_sol(:,1)
         rho2_rad(:) =  rho_sol(:,2)
        drho2_rad(:) = drho_sol(:,2)
     case (PCC)
         rho1_rad(:) =   rho_sol(:,1) +  rho_pcore(:)*0.5d0
        drho1_rad(:) =  drho_sol(:,1) + drho_pcore(:)*0.5d0
         rho2_rad(:) =   rho_sol(:,2) +  rho_pcore(:)*0.5d0
        drho2_rad(:) =  drho_sol(:,2) + drho_pcore(:)*0.5d0
     case (FCC)
         rho1_rad(:) =   rho_sol(:,1) +  rho_core(:)*0.5d0
        drho1_rad(:) =  drho_sol(:,1) + drho_core(:)*0.5d0
         rho2_rad(:) =   rho_sol(:,2) +  rho_core(:)*0.5d0
        drho2_rad(:) =  drho_sol(:,2) + drho_core(:)*0.5d0
     end select

  endif

  call gga_fxc_rmesh( &
       ier,IFLOG,3,iord_diff,nmesh, nspin,                     &
       rpos,wr,rho1_rad,rho2_rad,drho1_rad,drho2_rad,     &
       fx_rad,fc_rad,dfx_rad,dfc_rad,dfxda_rad,dfcda_rad, &
       vx_sol,vc_sol,ex_sol,ec_sol,ex_sum_sol,ec_sum_sol)

  if (ier /= 0) then
     write(IFLOG,*) '### ERROR ### in gga_fxc_rmesh' ; go to 99
  end if

  select case (is_pcc)
  case (NONE)
      rho1_rad(:) = 0.d0
     drho1_rad(:) = 0.d0
  case (PCC)
      rho1_rad(:) =  rho_pcore(:) * 0.5d0
     drho1_rad(:) = drho_pcore(:) * 0.5d0
  case (FCC)
      rho1_rad(:) =  rho_core(:) * 0.5d0
     drho1_rad(:) = drho_core(:) * 0.5d0
  end select

   rho2_rad(:) =  rho1_rad(:)
  drho2_rad(:) = drho1_rad(:)

  if (is_pcc == NONE) then
     vxpc_sol(:)  = 0.d0 ; vcpc_sol(:)  = 0.d0
     expc_sol(:)  = 0.d0 ; ecpc_sol(:)  = 0.d0
     expc_sum_sol = 0.d0 ; ecpc_sum_sol = 0.d0
  else
     call gga_fxc_rmesh( &
          ier,IFLOG,3,iord_diff,nmesh,1,                     &
          rpos,wr,rho1_rad,rho2_rad,drho1_rad,drho2_rad,     &
          fx_rad,fc_rad,dfx_rad,dfc_rad,dfxda_rad,dfcda_rad, &
          vxpc_sol,vcpc_sol,expc_sol,ecpc_sol,               &
          expc_sum_sol,ecpc_sum_sol)
     expc_sum_sol = - expc_sum_sol
     ecpc_sum_sol = - ecpc_sum_sol

     if (ier /= 0) then
        write(IFLOG,*) '### ERROR ### in gga_fxc_rmesh' ; go to 99
     end if
  end if

99 continue

end subroutine calc_xc_gga_pw91_rad_sol_kt
! ========================================================================== 4.0

!=====================================================================
   subroutine calc_xc_gga_pw91_rad_ss(ier)
!=====================================================================
!
!  M. Okamoto
!
!---------------------------------------------------------------------
   use parameters
   implicit none
   integer,intent(out) :: ier
   ier = 0
   if (is_spin_ss == POLARIZED) then
      select case (is_pcc)
      case (NONE)
          rho1_rad(:) =  rho_ss(:,1)
         drho1_rad(:) = drho_ss(:,1)
          rho2_rad(:) =  rho_ss(:,2)
         drho2_rad(:) = drho_ss(:,2)
      case (PCC)
          rho1_rad(:) =  rho_ss(:,1) +  rho_pcore(:) * 0.5d0
         drho1_rad(:) = drho_ss(:,1) + drho_pcore(:) * 0.5d0
          rho2_rad(:) =  rho_ss(:,2) +  rho_pcore(:) * 0.5d0
         drho2_rad(:) = drho_ss(:,2) + drho_pcore(:) * 0.5d0
      case (FCC)
          rho1_rad(:) =  rho_ss(:,1) +  rho_core(:) * 0.5d0
         drho1_rad(:) = drho_ss(:,1) + drho_core(:) * 0.5d0
          rho2_rad(:) =  rho_ss(:,2) +  rho_core(:) * 0.5d0
         drho2_rad(:) = drho_ss(:,2) + drho_core(:) * 0.5d0
      end select
   else
      select case (is_pcc)
      case (NONE)
          rho1_rad(:) =  rho_ss(:,1) * 0.5d0
         drho1_rad(:) = drho_ss(:,1) * 0.5d0
      case (PCC)
          rho1_rad(:) = ( rho_ss(:,1) +  rho_pcore(:)) * 0.5d0
         drho1_rad(:) = (drho_ss(:,1) + drho_pcore(:)) * 0.5d0
      case (FCC)
          rho1_rad(:) = ( rho_ss(:,1) +  rho_core(:)) * 0.5d0
         drho1_rad(:) = (drho_ss(:,1) + drho_core(:)) * 0.5d0
      end select
       rho2_rad(:) =  rho1_rad(:)
      drho2_rad(:) = drho1_rad(:)
   end if
   call gga_fxc_rmesh( &
      ier,IFLOG,3,iord_diff,nmesh,nspin_ss,              &
      rpos,wr,rho1_rad,rho2_rad,drho1_rad,drho2_rad,     &
      fx_rad,fc_rad,dfx_rad,dfc_rad,dfxda_rad,dfcda_rad, &
      vx_ss,vc_ss,ex_ss,ec_ss,ex_sum_ss,ec_sum_ss)
   if (ier /= 0) then
      write(IFLOG,*) '### ERROR ### in gga_fxc_rmesh' ; go to 99
   end if
   select case (is_pcc)
   case (NONE)
       rho1_rad(:) = 0.d0
      drho1_rad(:) = 0.d0
   case (PCC)
       rho1_rad(:) =  rho_pcore(:) * 0.5d0
      drho1_rad(:) = drho_pcore(:) * 0.5d0
   case (FCC)
       rho1_rad(:) =  rho_core(:) * 0.5d0
      drho1_rad(:) = drho_core(:) * 0.5d0
   end select
    rho2_rad(:) =  rho1_rad(:)
   drho2_rad(:) = drho1_rad(:)
   if (is_pcc == NONE) then
      vxpc_ss(:,:) = 0.d0 ; vcpc_ss(:,:) = 0.d0
      expc_ss(:)   = 0.d0 ; ecpc_ss(:)   = 0.d0
      expc_sum_ss  = 0.d0 ; ecpc_sum_ss  = 0.d0      
   else
      call gga_fxc_rmesh( &
         ier,IFLOG,3,iord_diff,nmesh,nspin_ss,              &
         rpos,wr,rho1_rad,rho2_rad,drho1_rad,drho2_rad,     &
         fx_rad,fc_rad,dfx_rad,dfc_rad,dfxda_rad,dfcda_rad, &
         vxpc_ss,vcpc_ss,expc_ss,ecpc_ss,                   &
         expc_sum_ss,ecpc_sum_ss)
      expc_sum_ss = - expc_sum_ss
      ecpc_sum_ss = - ecpc_sum_ss
      if (ier /= 0) then
         write(IFLOG,*) '### ERROR ### in gga_fxc_rmesh' ; go to 99
      end if
   end if
99 continue
   end subroutine calc_xc_gga_pw91_rad_ss

!=====================================================================
   subroutine calc_x_lda_sol(ier)
!=====================================================================
!
!  M. Okamoto
!
!---------------------------------------------------------------------
   use parameters
   implicit none
   integer,intent(out) :: ier
   integer :: ir
   real(8) :: rho1, rho2, rho1_tmp, &
              ex_tmp, ec_tmp, vx_tmp(2), vc_tmp(2)
   ier = 0
   do ir = 1,nmesh
      select case (is_pcc)

! ========================================== modified by K. T. ============ 4.0
!      case (NONE)
!         rho1_tmp = rho_sol(ir)
!      case (PCC)
!         rho1_tmp = rho_sol(ir) + rho_pcore(ir)
!      case (FCC)
!         rho1_tmp = rho_sol(ir) + rho_core(ir)
!      end select
!
      case (NONE)
         rho1_tmp = rho_sol(ir,1)
      case (PCC)
         rho1_tmp = rho_sol(ir,1) + rho_pcore(ir)
      case (FCC)
         rho1_tmp = rho_sol(ir,1) + rho_core(ir)
      end select
! ======================================================================== 4.0

      rho1 = rho1_tmp*0.5d0 ; rho2 = rho1
      call lda_x(rho1,rho2,ex_tmp,ec_tmp,vx_tmp,vc_tmp)
      ex_sol(ir) = ex_tmp
      ec_sol(ir) = ec_tmp

! ========================================== modified by K. T. ============= 4.0
!      vx_sol(ir) = vx_tmp(1)
!      vc_sol(ir) = vc_tmp(1)
      vx_sol(ir,1) = vx_tmp(1)
      vc_sol(ir,1) = vc_tmp(1)
! =========================================================================== 4.0
   end do
   end subroutine calc_x_lda_sol

!=============================================== added by K. T. ============== 4.0
subroutine calc_x_lda_sol_kt(ier)
  use parameters
  implicit none

  integer,intent(out) :: ier
  integer :: ir, ispin
  real(8) :: rho1, rho2, rho_tmp(2), &
       ex_tmp, ec_tmp, vx_tmp(2), vc_tmp(2)

  ier = 0

  do ir = 1,nmesh

     Do ispin=1, nspin

        select case (is_pcc)

        case (NONE)
           rho_tmp(ispin) = rho_sol(ir,ispin)
        case (PCC)
           rho_tmp(ispin) = rho_sol(ir,ispin) + rho_pcore(ir)/dble(nspin)
        case (FCC)
           rho_tmp(ispin) = rho_sol(ir,ispin) + rho_core(ir)/dble(nspin)
        end select
     End do

     if ( nspin == 1 ) then
        rho1 = rho_tmp(1)*0.5d0 ;   rho2 = rho1
     else if ( nspin == 2 ) then
        rho1 = rho_tmp(1);    rho2 = rho_tmp(2)
     endif

     call lda_x(rho1,rho2,ex_tmp,ec_tmp,vx_tmp,vc_tmp)

     ex_sol(ir) = ex_tmp
     ec_sol(ir) = ec_tmp

     Do ispin=1, nspin
        vx_sol(ir,ispin) = vx_tmp(ispin)
        vc_sol(ir,ispin) = vc_tmp(ispin)
     End do
     
  end do

end subroutine calc_x_lda_sol_kt
! =========================================================================== 4.0

!=====================================================================
   subroutine calc_x_lda_ss(ier)
!=====================================================================
!
!  M. Okamoto
!
!---------------------------------------------------------------------
   use parameters
   implicit none
   integer,intent(out) :: ier
   integer :: ir, ispin
   real(8) :: rho1, rho2, rho1_tmp, &
              ex_tmp, ec_tmp, vx_tmp(2), vc_tmp(2)
   ier = 0
   do ir = 1,nmesh
      select case (is_spin_ss)
      case (RESTRICTED)
         select case (is_pcc)
         case (NONE)
            rho1_tmp = rho_ss(ir,1)
         case (PCC)
            rho1_tmp = rho_ss(ir,1) + rho_pcore(ir)
         case (FCC)
            rho1_tmp = rho_ss(ir,1) + rho_core(ir)
         end select
         rho1 = rho1_tmp*0.5d0 ; rho2 = rho1
      case (POLARIZED)
         select case (is_pcc)
         case (NONE)
            rho1 = rho_ss(ir,1) ; rho2 = rho_ss(ir,2)
         case (PCC)
            rho1 = rho_ss(ir,1) + rho_pcore(ir)*0.5d0
            rho2 = rho_ss(ir,2) + rho_pcore(ir)*0.5d0
         case (FCC)
            rho1 = rho_ss(ir,1) + rho_core(ir)*0.5d0
            rho2 = rho_ss(ir,2) + rho_core(ir)*0.5d0
         end select
      end select
      call lda_x(rho1,rho2,ex_tmp,ec_tmp,vx_tmp,vc_tmp)
      ex_ss(ir) = ex_tmp
      ec_ss(ir) = ec_tmp
      do ispin = 1,nspin_ss
         vx_ss(ir,ispin) = vx_tmp(ispin)
         vc_ss(ir,ispin) = vc_tmp(ispin)
      end do
   end do
   end subroutine calc_x_lda_ss

!=====================================================================
   subroutine calc_x_gga_sol(ier)
!=====================================================================
!
!  M. Okamoto
!
!---------------------------------------------------------------------
   use parameters
   implicit none
   integer,intent(out) :: ier
   integer :: ir
   real(8) :: r, rho1, rho2, &
              drho1, drho2, ddrho1, ddrho2, &
              rho1_tmp, &
              drho1_tmp, ddrho1_tmp, &
              ex_tmp, ec_tmp, vx_tmp(2), vc_tmp(2), &
              rhomin = 1.d-25
   ier = 0
   do ir = 1,nmesh
      select case (is_pcc)

! ======================================= modified by K. T. ============== 4.0
!      case (NONE)
!           rho1_tmp =   rho_sol(ir)
!          drho1_tmp =  drho_sol(ir)
!         ddrho1_tmp = ddrho_sol(ir)
!      case (PCC)
!           rho1_tmp =   rho_sol(ir) +   rho_pcore(ir)
!          drho1_tmp =  drho_sol(ir) +  drho_pcore(ir)
!         ddrho1_tmp = ddrho_sol(ir) + ddrho_pcore(ir)
!      case (FCC)
!           rho1_tmp =   rho_sol(ir) +   rho_core(ir)
!          drho1_tmp =  drho_sol(ir) +  drho_core(ir)
!         ddrho1_tmp = ddrho_sol(ir) + ddrho_core(ir)
!      end select
!
      case (NONE)
           rho1_tmp =   rho_sol(ir,1)
          drho1_tmp =  drho_sol(ir,1)
         ddrho1_tmp = ddrho_sol(ir,1)
      case (PCC)
           rho1_tmp =   rho_sol(ir,1) +   rho_pcore(ir)
          drho1_tmp =  drho_sol(ir,1) +  drho_pcore(ir)
         ddrho1_tmp = ddrho_sol(ir,1) + ddrho_pcore(ir)
      case (FCC)
           rho1_tmp =   rho_sol(ir,1) +   rho_core(ir)
          drho1_tmp =  drho_sol(ir,1) +  drho_core(ir)
         ddrho1_tmp = ddrho_sol(ir,1) + ddrho_core(ir)
      end select
! ===================================================================== 4.0

        rho1 =    rho1_tmp*0.5d0 ;    rho2 =    rho1
       drho1 =   drho1_tmp*0.5d0 ;   drho2 =   drho1
      ddrho1 =  ddrho1_tmp*0.5d0 ;  ddrho2 =  ddrho1
      if (rho1 < rhomin) then
           rho1 = rhomin ;   rho2 = rho1
          drho1 =   0.d0 ;  drho2 = 0.d0
         ddrho1 =   0.d0 ; ddrho2 = 0.d0
      end if
      r = rpos(ir)
      call gga_x(r,rho1,rho2,drho1,drho2,ddrho1,ddrho2, &
                 ex_tmp,ec_tmp,vx_tmp,vc_tmp)
      ex_sol(ir) = ex_tmp
      ec_sol(ir) = ec_tmp

! =============================================== modified by K. T. ========= 4.0
!      vx_sol(ir) = vx_tmp(1)
!      vc_sol(ir) = vc_tmp(1)
      vx_sol(ir,1) = vx_tmp(1)
      vc_sol(ir,1) = vc_tmp(1)
! =========================================================================== 4.0
   end do
   end subroutine calc_x_gga_sol

!==================================================== added by K. T. ============ 4.0
subroutine calc_x_gga_sol_kt(ier)
  use parameters
  implicit none

  integer,intent(out) :: ier
  integer :: ir, ispin
  real(8) :: r, rho1, rho2, &
       drho1, drho2, ddrho1, ddrho2, &
       rho_tmp(2), &
       drho_tmp(2), ddrho_tmp(2), &
       ex_tmp, ec_tmp, vx_tmp(2), vc_tmp(2), &
       rhomin = 1.d-25
  ier = 0

  do ir = 1,nmesh

     Do ispin=1, nspin

        select case (is_pcc)

        case (NONE)
             rho_tmp(ispin) =   rho_sol(ir,ispin)
            drho_tmp(ispin) =  drho_sol(ir,ispin)
           ddrho_tmp(ispin) = ddrho_sol(ir,ispin)
        case (PCC)
             rho_tmp(ispin) =   rho_sol(ir,ispin) +   rho_pcore(ir)/dble(nspin)
            drho_tmp(ispin) =  drho_sol(ir,ispin) +  drho_pcore(ir)/dble(nspin)
           ddrho_tmp(ispin) = ddrho_sol(ir,ispin) + ddrho_pcore(ir)/dble(nspin)
        case (FCC)
             rho_tmp(ispin) =   rho_sol(ir,ispin) +   rho_core(ir)/dble(nspin)
            drho_tmp(ispin) =  drho_sol(ir,ispin) +  drho_core(ir)/dble(nspin)
           ddrho_tmp(ispin) = ddrho_sol(ir,ispin) + ddrho_core(ir)/dble(nspin)
        end select
        
     End do

     if ( nspin == 1 ) then
          rho1 =    rho_tmp(1)*0.5d0 ;    rho2 =    rho1
         drho1 =   drho_tmp(1)*0.5d0 ;   drho2 =   drho1
        ddrho1 =  ddrho_tmp(1)*0.5d0 ;  ddrho2 =  ddrho1

        if (rho1 < rhomin) then
             rho1 = rhomin ;   rho2 = rho1
            drho1 =   0.d0 ;  drho2 = 0.d0
           ddrho1 =   0.d0 ; ddrho2 = 0.d0
        endif
        
     else if ( nspin == 2 ) then
          rho1 =    rho_tmp(1);    rho2 =    rho_tmp(2)
         drho1 =   drho_tmp(1);   drho2 =   drho_tmp(2)
        ddrho1 =  ddrho_tmp(1);  ddrho2 =  ddrho_tmp(2)

        if (rho1 < rhomin) then
           rho1 = rhomin ;    drho1 =   0.d0 ;     ddrho1 =   0.d0
        endif
        if (rho2 < rhomin) then
           rho2 = rhomin ;    drho2 =   0.d0 ;     ddrho2 =   0.d0
        endif

     end if
     
     r = rpos(ir)
     call gga_x(r,rho1,rho2,drho1,drho2,ddrho1,ddrho2, &
          ex_tmp,ec_tmp,vx_tmp,vc_tmp)

     ex_sol(ir) = ex_tmp
     ec_sol(ir) = ec_tmp

     Do ispin=1, nspin
        vx_sol(ir,ispin) = vx_tmp(ispin)
        vc_sol(ir,ispin) = vc_tmp(ispin)
     End do

  end do

end subroutine calc_x_gga_sol_kt
! =========================================================================== 4.0

!=====================================================================
   subroutine calc_x_gga_ss(ier)
!=====================================================================
!
!  M. Okamoto
!
!---------------------------------------------------------------------
   use parameters
   implicit none
   integer,intent(out) :: ier
   integer :: ir, ispin
   real(8) :: r, rho1, rho2, &
              drho1, drho2, ddrho1, ddrho2, &
              rho1_tmp, &
              drho1_tmp, ddrho1_tmp, &
              ex_tmp, ec_tmp, vx_tmp(2), vc_tmp(2), &
              rhomin = 1.d-25
   ier = 0
   do ir = 1,nmesh
      select case (is_spin_ss)
      case (RESTRICTED)
         select case (is_pcc)
         case (NONE)
              rho1_tmp =   rho_ss(ir,1)
             drho1_tmp =  drho_ss(ir,1)
            ddrho1_tmp = ddrho_ss(ir,1)
         case (PCC)
              rho1_tmp =   rho_ss(ir,1) +   rho_pcore(ir)
             drho1_tmp =  drho_ss(ir,1) +  drho_pcore(ir)
            ddrho1_tmp = ddrho_ss(ir,1) + ddrho_pcore(ir)
         case (FCC)
              rho1_tmp =   rho_ss(ir,1) +   rho_core(ir)
             drho1_tmp =  drho_ss(ir,1) +  drho_core(ir)
            ddrho1_tmp = ddrho_ss(ir,1) + ddrho_core(ir)
         end select
           rho1 =    rho1_tmp*0.5d0 ;    rho2 =    rho1
          drho1 =   drho1_tmp*0.5d0 ;   drho2 =   drho1
         ddrho1 =  ddrho1_tmp*0.5d0 ;  ddrho2 =  ddrho1
         if (rho1 < rhomin) then
              rho1 = rhomin ;   rho2 = rho1
             drho1 =   0.d0 ;  drho2 = 0.d0
            ddrho1 =   0.d0 ; ddrho2 = 0.d0
         end if
      case (POLARIZED)
         select case (is_pcc)
         case (NONE)
              rho1 =   rho_ss(ir,1) ;   rho2 =   rho_ss(ir,2)
             drho1 =  drho_ss(ir,1) ;  drho2 =  drho_ss(ir,2)
            ddrho1 = ddrho_ss(ir,1) ; ddrho2 = ddrho_ss(ir,2)
         case (PCC)
              rho1 =   rho_ss(ir,1) +   rho_pcore(ir)*0.5d0
             drho1 =  drho_ss(ir,1) +  drho_pcore(ir)*0.5d0
            ddrho1 = ddrho_ss(ir,1) + ddrho_pcore(ir)*0.5d0
              rho2 =   rho_ss(ir,2) +   rho_pcore(ir)*0.5d0
             drho2 =  drho_ss(ir,2) +  drho_pcore(ir)*0.5d0
            ddrho2 = ddrho_ss(ir,2) + ddrho_pcore(ir)*0.5d0
         case (FCC)
              rho1 =   rho_ss(ir,1) +   rho_core(ir)*0.5d0
             drho1 =  drho_ss(ir,1) +  drho_core(ir)*0.5d0
            ddrho1 = ddrho_ss(ir,1) + ddrho_core(ir)*0.5d0
              rho2 =   rho_ss(ir,2) +   rho_core(ir)*0.5d0
             drho2 =  drho_ss(ir,2) +  drho_core(ir)*0.5d0
            ddrho2 = ddrho_ss(ir,2) + ddrho_core(ir)*0.5d0
         end select
      end select
      r = rpos(ir)
      call gga_x(r,rho1,rho2,drho1,drho2,ddrho1,ddrho2, &
                 ex_tmp,ec_tmp,vx_tmp,vc_tmp)
      ex_ss(ir) = ex_tmp
      ec_ss(ir) = ec_tmp
      do ispin = 1,nspin_ss
         vx_ss(ir,ispin) = vx_tmp(ispin)
         vc_ss(ir,ispin) = vc_tmp(ispin)
      end do
   end do
   end subroutine calc_x_gga_ss

!=====================================================================
   subroutine calc_xc_none_sol(ier)
!=====================================================================
!
!  M. Okamoto
!
!---------------------------------------------------------------------
   use parameters
   implicit none
   integer,intent(out) :: ier
   ier = 0
   ex_sol(:) = 0.d0
   ec_sol(:) = 0.d0

! ================================ modified by K. T. ================ 4.0
!   vx_sol(:) = 0.d0
!   vc_sol(:) = 0.d0
   vx_sol(:,:) = 0.d0
   vc_sol(:,:) = 0.d0
! =================================================================== 4.0

   end subroutine calc_xc_none_sol

!=====================================================================
   subroutine calc_xc_none_ss(ier)
!=====================================================================
!
!  M. Okamoto
!
!---------------------------------------------------------------------
   use parameters
   implicit none
   integer,intent(out) :: ier
   ier = 0
   ex_ss(:)   = 0.d0
   ec_ss(:)   = 0.d0
   vx_ss(:,:) = 0.d0
   vc_ss(:,:) = 0.d0
   end subroutine calc_xc_none_ss
