! ************************************************************* 
!
!   This is a software package CIAO
!
!     developed as a part of the national project "Research and 
!     Development of Innovative Simulation software",which is   
!     supported by the next-generation IT program of MEXT of Japan
!
!   latest version: 
!
!     4.0:  2013/01/17 
!           codes for spin-polarized pseudopotential generation are added
!
! ************************************************************* 
!
!  Software name : CIAO (Code for Investigating Atomic Orbitals)
!  Subroutine(s) : calc_xc_lda_pz81, calc_xc_lda_pz81_ps
!                : calc_xc_lda_pw92, calc_xc_lda_pw92_ps
!                : calc_xc_gga_pbe96, calc_xc_gga_pbe96_ps
!                : calc_xc_gga_pw91, calc_xc_gga_pw91_ps
!                : calc_x_lda, calc_x_lda_ps, calc_x_gga
!                : calc_x_gga_ps, calc_xc_none, calc_xc_none_ps
!  Author(s)     : Masakuni Okamoto (August 25, 2003)
!
!  The license of the code and contact address :
!  See the files, COPYRIGHT and LICENSE (or LICENSE_J.pdf)
!
!=====================================================================
   subroutine calc_xc_lda_pz81(ier)
!=====================================================================
!
!  M. Okamoto
!
!---------------------------------------------------------------------
   use parameters
   implicit none
   integer,intent(out) :: ier
   integer :: ir, ispin
   real(8) :: rho1, rho2, vxs(2), vcs(2), &
              rhomin = 1.d-35
   ier = 0
   do ir = 1,nmesh
      if (is_spin == POLARIZED) then
         rho1 = rho(ir,1) ; rho2 = rho(ir,2)
      else
         rho1 = rho(ir,1)*0.5d0 ; rho2 = rho1
      end if
      call lda_pz81(rho1,rho2,ex(ir),ec(ir),vxs,vcs)
      do ispin = 1,nspin
         vx(ir,ispin) = vxs(ispin)
         vc(ir,ispin) = vcs(ispin)
      end do
   end do
   end subroutine calc_xc_lda_pz81

!=====================================================================
   subroutine calc_xc_lda_pz81_ps(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_ps(ir)
!         rho1_tmp = rho_ps(ir)
!      case (PCC)
!         rho1_tmp = rho_ps(ir) + rho_pcore(ir)
!      case (FCC)
!         rho1_tmp = rho_ps(ir) + rho_core(ir)
!      end select
!
      case (NONE)
         rho1_tmp = rho_ps(ir,1)
      case (PCC)
         rho1_tmp = rho_ps(ir,1) + rho_pcore(ir)
      case (FCC)
         rho1_tmp = rho_ps(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_ps(ir) = ex_tmp
      ec_ps(ir) = ec_tmp

! ======================================= modiifed by K. T. ===========4.0
!      vx_ps(ir) = vx_tmp(1)
!      vc_ps(ir) = vc_tmp(1)
!
      vx_ps(ir,1) = vx_tmp(1)
      vc_ps(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(1) = 0.d0
         vc_tmp(1) = 0.d0
      end select
      expc_ps(ir) = ex_tmp
      ecpc_ps(ir) = ec_tmp
      vxpc_ps(ir) = vx_tmp(1)
      vcpc_ps(ir) = vc_tmp(1)
   end do

   end subroutine calc_xc_lda_pz81_ps

!=====================================================================
   subroutine calc_xc_lda_pw92(ier)
!=====================================================================
!
!  M. Okamoto
!
!---------------------------------------------------------------------
   use parameters
   implicit none
   integer,intent(out) :: ier
   integer :: ir, ispin
   real(8) :: rho1, rho2, vxs(2), vcs(2), &
              decdrs, decdzeta, &
              rhomin = 1.d-35
   ier = 0
   do ir = 1,nmesh
      if (is_spin == POLARIZED) then
         rho1 = rho(ir,1) ; rho2 = rho(ir,2)
      else
         rho1 = rho(ir,1)*0.5d0 ; rho2 = rho1
      end if
      call lda_pw92(rho1,rho2,ex(ir),ec(ir),vxs,vcs, &
                    decdrs,decdzeta)
      do ispin = 1,nspin
         vx(ir,ispin) = vxs(ispin)
         vc(ir,ispin) = vcs(ispin)
      end do
   end do
   end subroutine calc_xc_lda_pw92

!=====================================================================
   subroutine calc_xc_lda_pw92_ps(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_ps(ir)
!      case (PCC)
!         rho1_tmp = rho_ps(ir) + rho_pcore(ir)
!      case (FCC)
!         rho1_tmp = rho_ps(ir) + rho_core(ir)
!      end select
!
      case (NONE)
         rho1_tmp = rho_ps(ir,1)
      case (PCC)
         rho1_tmp = rho_ps(ir,1) + rho_pcore(ir)
      case (FCC)
         rho1_tmp = rho_ps(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_ps(ir) = ex_tmp
      ec_ps(ir) = ec_tmp

! ========================================= modified by K. T. ============== 4.0
!      vx_ps(ir) = vx_tmp(1)
!      vc_ps(ir) = vc_tmp(1)
!
      vx_ps(ir,1) = vx_tmp(1)
      vc_ps(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(1) = 0.d0
         vc_tmp(1) = 0.d0
      end select
      expc_ps(ir) = ex_tmp
      ecpc_ps(ir) = ec_tmp
      vxpc_ps(ir) = vx_tmp(1)
      vcpc_ps(ir) = vc_tmp(1)
   end do
   end subroutine calc_xc_lda_pw92_ps

!=====================================================================
   subroutine calc_xc_gga_pbe96(ier,imode)
!=====================================================================
!
!  M. Okamoto
!
!---------------------------------------------------------------------
   use parameters
   implicit none
   integer,intent(in)  :: imode
   integer,intent(out) :: ier
   integer :: ir, ispin
   real(8) :: r,rho1, rho2, ex_tmp, ec_tmp, vx_tmp(2), vc_tmp(2), &
              drho1, drho2, ddrho1, ddrho2, &
              eps_chg = 1.d-25
   ier = 0
   do ir = 1,nmesh
      if (is_spin == POLARIZED) then
            rho1 =    rho(ir,1) ;    rho2 =    rho(ir,2)
           drho1 =   drho(ir,1) ;   drho2 =   drho(ir,2)
          ddrho1 =  ddrho(ir,1) ;  ddrho2 =  ddrho(ir,2)
      else
            rho1 =    rho(ir,1)*0.5d0 ;    rho2 =    rho1
           drho1 =   drho(ir,1)*0.5d0 ;   drho2 =   drho1
          ddrho1 =  ddrho(ir,1)*0.5d0 ;  ddrho2 =  ddrho1
      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(ir) = ex_tmp
      ec(ir) = ec_tmp
      if (max(rho1,rho2) < eps_chg) then
         ec(ir) = 0.d0
      end if
      do ispin = 1,nspin
         vx(ir,ispin) = vx_tmp(ispin)
         vc(ir,ispin) = vc_tmp(ispin)
      end do
      if (rho1 < eps_chg) then
         vc(ir,1) = 0.d0
      end if
      if (nspin == 2) then
         if (rho2 < eps_chg) then
            vc(ir,2) = 0.d0
         end if
      end if
   end do
   end subroutine calc_xc_gga_pbe96

!=====================================================================
   subroutine calc_xc_gga_pbe96_ps(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_ps(ir)
!          drho1_tmp =  drho_ps(ir)
!         ddrho1_tmp = ddrho_ps(ir)
!      case (PCC)
!           rho1_tmp =   rho_ps(ir) +   rho_pcore(ir)
!          drho1_tmp =  drho_ps(ir) +  drho_pcore(ir)
!         ddrho1_tmp = ddrho_ps(ir) + ddrho_pcore(ir)
!      case (FCC)
!           rho1_tmp =   rho_ps(ir) +   rho_core(ir)
!          drho1_tmp =  drho_ps(ir) +  drho_core(ir)
!         ddrho1_tmp = ddrho_ps(ir) + ddrho_core(ir)
!      end select

      case (NONE)
           rho1_tmp =   rho_ps(ir,1)
          drho1_tmp =  drho_ps(ir,1)
         ddrho1_tmp = ddrho_ps(ir,1)
      case (PCC)
           rho1_tmp =   rho_ps(ir,1) +   rho_pcore(ir)
          drho1_tmp =  drho_ps(ir,1) +  drho_pcore(ir)
         ddrho1_tmp = ddrho_ps(ir,1) + ddrho_pcore(ir)
      case (FCC)
           rho1_tmp =   rho_ps(ir,1) +   rho_core(ir)
          drho1_tmp =  drho_ps(ir,1) +  drho_core(ir)
         ddrho1_tmp = ddrho_ps(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
      !### DEBUG ### [begin]
      if (rho1_tmp < rhomin) then
           rho1 = rhomin ;   rho2 = rho1
          drho1 =   0.d0 ;  drho2 = 0.d0
         ddrho1 =   0.d0 ; ddrho2 = 0.d0
      end if
      !### DEBUG ### [end]
      r = rpos(ir)
      call gga_pbe96_spherical(imode, &
                 r,rho1,rho2,drho1,drho2,ddrho1,ddrho2, &
                 ex_tmp,ec_tmp,vx_tmp,vc_tmp)

      ex_ps(ir) = ex_tmp
      ec_ps(ir) = ec_tmp
      if (max(rho1,rho2) < eps_chg) then
         ec_ps(ir) = 0.d0    
      end if

! ========================================== modified by K. T. ============ 4.0
!      vx_ps(ir) = vx_tmp(1)
!      vc_ps(ir) = vc_tmp(1)
!      if (max(rho1,rho2) < eps_chg) then
!         vc_ps(ir) = 0.d0
!      end if

      vx_ps(ir,1) = vx_tmp(1)
      vc_ps(ir,1) = vc_tmp(1)
      if (max(rho1,rho2) < eps_chg) then
         vc_ps(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
      !### DEBUG ### [begin]
      if (rho1_tmp < rhomin) then
           rho1 = rhomin ;   rho2 = rho1
          drho1 =   0.d0 ;  drho2 = 0.d0
         ddrho1 =   0.d0 ; ddrho2 = 0.d0
      end if
      !### DEBUG ### [end]
      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(1) = 0.d0
         vc_tmp(1) = 0.d0
      end select
      expc_ps(ir) = ex_tmp
      ecpc_ps(ir) = ec_tmp
      if (max(rho1,rho2) < eps_chg) then
         ecpc_ps(ir) = 0.d0    
      end if
      vxpc_ps(ir) = vx_tmp(1)
      vcpc_ps(ir) = vc_tmp(1)
      if (max(rho1,rho2) < eps_chg) then
         vcpc_ps(ir) = 0.d0
      end if
   end do
   end subroutine calc_xc_gga_pbe96_ps

!=====================================================================
   subroutine calc_xc_gga_pbe96_rad(ier,imode)
!=====================================================================
!
!  M. Okamoto
!
!---------------------------------------------------------------------
   use parameters
   implicit none
   integer,intent(in)  :: imode
   integer,intent(out) :: ier
   ier = 0
   if (is_spin == POLARIZED) then
       rho1_rad(:) =  rho(:,1) ;  rho2_rad(:) =  rho(:,2)
      drho1_rad(:) = drho(:,1) ; drho2_rad(:) = drho(:,2)
   else
       rho1_rad(:) =  rho(:,1)*0.5d0 ;  rho2_rad(:) =  rho1_rad(:)
      drho1_rad(:) = drho(:,1)*0.5d0 ; drho2_rad(:) = drho1_rad(:)
   end if
   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,vc,ex,ec,ex_sum,ec_sum)
   if (ier /= 0) then
      write(IFLOG,*) '### ERROR ### in gga_fxc_rmesh' ; go to 99
   end if
99 continue
   end subroutine calc_xc_gga_pbe96_rad

!=====================================================================
   subroutine calc_xc_gga_pbe96_rad_ps(ier,imode)
!=====================================================================
!
!  M. Okamoto
!
!---------------------------------------------------------------------
   use parameters
   implicit none
   integer,intent(in)  :: imode
   integer,intent(out) :: ier
   real(8) :: ex_sum_tmp, ec_sum_tmp
   ier = 0
   select case (is_pcc)
! ======================================== modified by K. T. ================ 4.0
!   case (NONE)
!       rho1_rad(:) =  rho_ps(:) * 0.5d0
!      drho1_rad(:) = drho_ps(:) * 0.5d0
!   case (PCC)
!       rho1_rad(:) = ( rho_ps(:) +  rho_pcore(:)) * 0.5d0
!      drho1_rad(:) = (drho_ps(:) + drho_pcore(:)) * 0.5d0
!   case (FCC)
!       rho1_rad(:) = ( rho_ps(:) +  rho_core(:)) * 0.5d0
!      drho1_rad(:) = (drho_ps(:) + drho_core(:)) * 0.5d0
!   end select
!
   case (NONE)
       rho1_rad(:) =  rho_ps(:,1) * 0.5d0
      drho1_rad(:) = drho_ps(:,1) * 0.5d0
   case (PCC)
       rho1_rad(:) = ( rho_ps(:,1) +  rho_pcore(:)) * 0.5d0
      drho1_rad(:) = (drho_ps(:,1) + drho_pcore(:)) * 0.5d0
   case (FCC)
       rho1_rad(:) = ( rho_ps(:,1) +  rho_core(:)) * 0.5d0
      drho1_rad(:) = (drho_ps(:,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_ps,vc_ps,ex_ps,ec_ps,ex_sum_tmp,ec_sum_tmp)
   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_ps(:) = 0.d0 ; vcpc_ps(:) = 0.d0
      expc_ps(:) = 0.d0 ; ecpc_ps(:) = 0.d0
      expc_sum   = 0.d0 ; ecpc_sum   = 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_ps,vcpc_ps,expc_ps,ecpc_ps,expc_sum,ecpc_sum)
      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_ps

!=====================================================================
   subroutine calc_xc_gga_pw91_rad(ier)
!=====================================================================
!
!  M. Okamoto
!
!---------------------------------------------------------------------
   use parameters
   implicit none
   integer,intent(out) :: ier
   ier = 0
   if (is_spin == POLARIZED) then
       rho1_rad(:) =  rho(:,1) ;  rho2_rad(:) =  rho(:,2)
      drho1_rad(:) = drho(:,1) ; drho2_rad(:) = drho(:,2)
   else
       rho1_rad(:) =  rho(:,1)*0.5d0 ;  rho2_rad(:) =  rho1_rad(:)
      drho1_rad(:) = drho(:,1)*0.5d0 ; drho2_rad(:) = drho1_rad(:)
   end if
   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,vc,ex,ec,ex_sum,ec_sum)
   if (ier /= 0) then
      write(IFLOG,*) '### ERROR ### in gga_fxc_rmesh' ; go to 99
   end if
99 continue
   end subroutine calc_xc_gga_pw91_rad

!=====================================================================
   subroutine calc_xc_gga_pw91_rad_ps(ier)
!=====================================================================
!
!  M. Okamoto
!
!---------------------------------------------------------------------
   use parameters
   implicit none
   integer,intent(out) :: ier
   real(8) :: ex_sum_tmp, ec_sum_tmp
   ier = 0
   select case (is_pcc)

! ======================================= modiifed by K. T. ============== 4.0
!   case (NONE)
!       rho1_rad(:) =  rho_ps(:) * 0.5d0
!      drho1_rad(:) = drho_ps(:) * 0.5d0
!   case (PCC)
!       rho1_rad(:) = ( rho_ps(:) +  rho_pcore(:)) * 0.5d0
!      drho1_rad(:) = (drho_ps(:) + drho_pcore(:)) * 0.5d0
!   case (FCC)
!       rho1_rad(:) = ( rho_ps(:) +  rho_core(:)) * 0.5d0
!      drho1_rad(:) = (drho_ps(:) + drho_core(:)) * 0.5d0
!   end select
!
   case (NONE)
       rho1_rad(:) =  rho_ps(:,1) * 0.5d0
      drho1_rad(:) = drho_ps(:,1) * 0.5d0
   case (PCC)
       rho1_rad(:) = ( rho_ps(:,1) +  rho_pcore(:)) * 0.5d0
      drho1_rad(:) = (drho_ps(:,1) + drho_pcore(:)) * 0.5d0
   case (FCC)
       rho1_rad(:) = ( rho_ps(:,1) +  rho_core(:)) * 0.5d0
      drho1_rad(:) = (drho_ps(:,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_ps,vc_ps,ex_ps,ec_ps,ex_sum_tmp,ec_sum_tmp)
   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_ps(:) = 0.d0 ; vcpc_ps(:) = 0.d0
      expc_ps(:) = 0.d0 ; ecpc_ps(:) = 0.d0
      expc_sum   = 0.d0 ; ecpc_sum   = 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_ps,vcpc_ps,expc_ps,ecpc_ps,expc_sum,ecpc_sum)
      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_ps

!=====================================================================
   subroutine calc_x_lda(ier)
!=====================================================================
!
!  M. Okamoto
!
!---------------------------------------------------------------------
   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)
   ier = 0
   do ir = 1,nmesh
      if (is_spin == POLARIZED) then
         rho1 = rho(ir,1) ; rho2 = rho(ir,2)
      else
         rho1 = rho(ir,1)*0.5d0 ; rho2 = rho1
      end if
      call lda_x(rho1,rho2,ex_tmp,ec_tmp,vx_tmp,vc_tmp)
      ex(ir) = ex_tmp
      ec(ir) = ec_tmp
      do ispin = 1,nspin
         vx(ir,ispin) = vx_tmp(ispin)
         vc(ir,ispin) = vc_tmp(ispin)
      end do
   end do
   end subroutine calc_x_lda

!=====================================================================
   subroutine calc_x_lda_ps(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_ps(ir)
!      case (PCC)
!         rho1_tmp = rho_ps(ir) + rho_pcore(ir)
!      case (FCC)
!         rho1_tmp = rho_ps(ir) + rho_core(ir)
!      end select
!
      case (NONE)
         rho1_tmp = rho_ps(ir,1)
      case (PCC)
         rho1_tmp = rho_ps(ir,1) + rho_pcore(ir)
      case (FCC)
         rho1_tmp = rho_ps(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_ps(ir) = ex_tmp
      ec_ps(ir) = ec_tmp

! =============================== modiifed by K. T. ================= 4.0
!      vx_ps(ir) = vx_tmp(1)
!      vc_ps(ir) = vc_tmp(1)
      vx_ps(ir,1) = vx_tmp(1)
      vc_ps(ir,1) = vc_tmp(1)
! ======================================================================= 4.0

   end do
   end subroutine calc_x_lda_ps

!=====================================================================
   subroutine calc_x_gga(ier)
!=====================================================================
!
!  M. Okamoto
!
!---------------------------------------------------------------------
   use parameters
   implicit none
   integer,intent(out) :: ier
   integer :: ir, ispin
   real(8) :: r, rho1, rho2, ex_tmp, ec_tmp, vx_tmp(2), vc_tmp(2), &
              drho1, drho2, ddrho1, ddrho2
   ier = 0
   do ir = 1,nmesh
      if (is_spin == POLARIZED) then
            rho1 =    rho(ir,1) ;    rho2 =    rho(ir,2)
           drho1 =   drho(ir,1) ;   drho2 =   drho(ir,2)
          ddrho1 =  ddrho(ir,1) ;  ddrho2 =  ddrho(ir,2)
      else
            rho1 =    rho(ir,1)*0.5d0 ;    rho2 =    rho1
           drho1 =   drho(ir,1)*0.5d0 ;   drho2 =   drho1
          ddrho1 =  ddrho(ir,1)*0.5d0 ;  ddrho2 =  ddrho1
      end if
      r = rpos(ir)
      call gga_x(r,rho1,rho2,drho1,drho2,ddrho1,ddrho2, &
                 ex_tmp,ec_tmp,vx_tmp,vc_tmp)
      ex(ir) = ex_tmp
      ec(ir) = ec_tmp
      do ispin = 1,nspin
         vx(ir,ispin) = vx_tmp(ispin)
         vc(ir,ispin) = vc_tmp(ispin)
      end do
   end do
   end subroutine calc_x_gga

!=====================================================================
   subroutine calc_x_gga_ps(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)
! ======================================= modiified by K. T. ============= 4.0
!      case (NONE)
!           rho1_tmp =   rho_ps(ir)
!          drho1_tmp =  drho_ps(ir)
!         ddrho1_tmp = ddrho_ps(ir)
!      case (PCC)
!           rho1_tmp =   rho_ps(ir) +   rho_pcore(ir)
!          drho1_tmp =  drho_ps(ir) +  drho_pcore(ir)
!         ddrho1_tmp = ddrho_ps(ir) + ddrho_pcore(ir)
!      case (FCC)
!           rho1_tmp =   rho_ps(ir) +   rho_core(ir)
!          drho1_tmp =  drho_ps(ir) +  drho_core(ir)
!         ddrho1_tmp = ddrho_ps(ir) + ddrho_core(ir)
!      end select
!
      case (NONE)
           rho1_tmp =   rho_ps(ir,1)
          drho1_tmp =  drho_ps(ir,1)
         ddrho1_tmp = ddrho_ps(ir,1)
      case (PCC)
           rho1_tmp =   rho_ps(ir,1) +   rho_pcore(ir)
          drho1_tmp =  drho_ps(ir,1) +  drho_pcore(ir)
         ddrho1_tmp = ddrho_ps(ir,1) + ddrho_pcore(ir)
      case (FCC)
           rho1_tmp =   rho_ps(ir,1) +   rho_core(ir)
          drho1_tmp =  drho_ps(ir,1) +  drho_core(ir)
         ddrho1_tmp = ddrho_ps(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
      !### DEBUG ### [begin]
      if (rho1_tmp < rhomin) then
           rho1 = rhomin ;   rho2 = rho1
          drho1 =   0.d0 ;  drho2 = 0.d0
         ddrho1 =   0.d0 ; ddrho2 = 0.d0
      end if
      !### DEBUG ### [end]
      r = rpos(ir)
      call gga_x(r,rho1,rho2,drho1,drho2,ddrho1,ddrho2, &
                 ex_tmp,ec_tmp,vx_tmp,vc_tmp)
      ex_ps(ir) = ex_tmp
      ec_ps(ir) = ec_tmp

! ===================================== modified by K. T. =================== 4.0
!      vx_ps(ir) = vx_tmp(1)
!      vc_ps(ir) = vc_tmp(1)
      vx_ps(ir,1) = vx_tmp(1)
      vc_ps(ir,1) = vc_tmp(1)
! =========================================================================== 4.0
   end do
   end subroutine calc_x_gga_ps

!=====================================================================
   subroutine calc_xc_none(ier)
!=====================================================================
!
!  M. Okamoto
!
!---------------------------------------------------------------------
   use parameters
   implicit none
   integer,intent(out) :: ier
   integer :: ir, ispin
   ier = 0
   do ir = 1,nmesh
      ex(ir) = 0.d0
      ec(ir) = 0.d0
      do ispin = 1,nspin
         vx(ir,ispin) = 0.d0
         vc(ir,ispin) = 0.d0
      end do
   end do
   end subroutine calc_xc_none

!=====================================================================
   subroutine calc_xc_none_ps(ier)
!=====================================================================
!
!  M. Okamoto
!
!---------------------------------------------------------------------
   use parameters
   implicit none
   integer,intent(out) :: ier
   integer :: ir
   ier = 0
   do ir = 1,nmesh
      ex_ps(ir) = 0.d0
      ec_ps(ir) = 0.d0
! ===================================== modified by K. T. =========== 4.0
!      vx_ps(ir) = 0.d0
!      vc_ps(ir) = 0.d0
      vx_ps(ir,:) = 0.d0
      vc_ps(ir,:) = 0.d0
! =================================================================== 4.0
   end do
   end subroutine calc_xc_none_ps
