! ************************************************************* 
!
!   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_rho_sol, calc_rho_ss, calc_drho_ddrho_core_sol
!                : calc_drho_ddrho_pcore_sol, calc_drho_ddrho_sol
!                : calc_drho_ddrho_ss, calc_drho_core_sol
!                : calc_drho_pcore_sol, calc_drho_sol, calc_drho_ss
!  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_rho_sol(ier)
!=====================================================================
!
!  M. Okamoto
!
!---------------------------------------------------------------------
   use parameters
   implicit none
   integer,intent(out) :: ier
   integer :: ir, ishell, ips, ll, nref, t1, t2, lt1, lt2, ltlt, icore
   real(8) :: sum, pi4
   ier = 0
   pi4 = 4.d0 * PI

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

   do ips = 1,nps
      ishell = ishell_ps(ips,1)
      ll = l_qnum(ishell)
      nref = nref_us(ll)
      if (is_solve(ishell) == 0) then
         cycle
      end if
      do ir = 1,nmesh

! ========================================= modified by K. T. ============== 4.0
!         rho_sol(ir) = rho_sol(ir) &
!            + focc(ishell) * rphi_sol(ir,ips)**2
         rho_sol(ir,1) = rho_sol(ir,1) &
            + focc(ishell) * rphi_sol(ir,ips)**2
! ========================================================================== 4.0

         do t1 = 1,nref
         do t2 = 1,nref
            lt1 = lt_n_us(ll,t1)
            lt2 = lt_n_us(ll,t2)
            ltlt = ltlt_nm_us(ll,t1,ll,t2)
            if (ltlt /= 0) then
! ========================================= modified by K. T. =========== 4.0
!               rho_sol(ir) = rho_sol(ir) &
!                  + focc(ishell) &
!                     * qps_us(ir,ltlt,0) * rpos(ir)**2 &
!                     * beta_phi_sol(lt1,ips) &
!                     * beta_phi_sol(lt2,ips)
               rho_sol(ir,1) = rho_sol(ir,1) &
                  + focc(ishell) &
                     * qps_us(ir,ltlt,0) * rpos(ir)**2 &
                     * beta_phi_sol(lt1,ips) &
                     * beta_phi_sol(lt2,ips)
! ======================================================================= 4.0
            end if
         end do
         end do
      end do
   end do
   do ir = 1,nmesh
! ================================================ modified by K. T. ====== 4.0
!      rho_sol(ir) = rho_sol(ir) / (pi4*rpos(ir)**2)
      rho_sol(ir,1) = rho_sol(ir,1) / (pi4*rpos(ir)**2)
! ========================================================================= 4.0
   end do
   if (num_core_hole > 0) then
      felec_sol  = felec_sol  + ftot_core_hole
      felec_core = felec_core - ftot_core_hole
      felec_val  = felec_sol
      do icore = 1,num_core_hole
         ishell = ishell_core_hole(icore)
         do ir = 1,nmesh
! ================================================ modified by K. T. ========== 4.0
!            rho_sol(ir) = rho_sol(ir) &
!               + focc_core_hole(icore) &
!                  * (chi_g(ir,ishell)/rpos(ir))**2 / pi4
            rho_sol(ir,1) = rho_sol(ir,1) &
               + focc_core_hole(icore) &
                  * (chi_g(ir,ishell)/rpos(ir))**2 / pi4
! ============================================================================= 4.0
         end do
      end do
   end if
   sum = 0.d0
   do ir = 1,nmesh
! ============================================= modified by K. T. ============ 4.0
!      sum = sum + pi4*rpos(ir)**2*wr(ir) * rho_sol(ir)
      sum = sum + pi4*rpos(ir)**2*wr(ir) * rho_sol(ir,1)
! ============================================================================= 4.0
   end do
   if (abs(sum-felec_sol) > 1.d-5) then
      write(IFLOG,*) '### ERROR ### sum of rho_sol != felec_sol'
      write(IFLOG,*) '   sum of rho_sol ...', sum
      write(IFLOG,*) '   felec_sol      ...', felec_sol
      ier = 1 ; go to 99
   end if

! ===================================== modified by K. T. ============== 4.0
!   rho_sol(:) = rho_sol(:) * felec_sol/sum
!   do ir = 1,nmesh
!      if (abs(rho_sol(ir)) < 1.d-99) then
!         rho_sol(ir) = 0.d0
!      end if
!   end do

   rho_sol(:,1) = rho_sol(:,1) * felec_sol/sum
   do ir = 1,nmesh
      if (abs(rho_sol(ir,1)) < 1.d-99) then
         rho_sol(ir,1) = 0.d0
      end if
   end do
! ==================================================================== 4.0

99 continue
   end subroutine calc_rho_sol

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

  integer,intent(out) :: ier
  integer :: ir, ishell, ips, ll, nref, t1, t2, lt1, lt2, ltlt, icore
  real(8) :: sum, pi4

  integer :: ispin, itmp1, itmp2

  ier = 0
  pi4 = 4.d0 * PI

  rho_sol(:,:) = 0.d0

  do ips = 1,nps
     ishell = ishell_ps(ips,1)
     ll = l_qnum(ishell)

     nref = nref_us(ll)

     ispin = ( 1-spin(ishell) ) /2 +1

     if (is_solve(ishell) == 0) then
        cycle
     end if
     
     do ir = 1,nmesh
        
        rho_sol(ir,ispin) = rho_sol(ir,ispin) &
             + focc(ishell) * rphi_sol(ir,ips)**2
        
        do t1 = 1,nref
           do t2 = 1,nref
              itmp1 = t1 + nref_max_us *(ispin -1)
              itmp2 = t2 + nref_max_us *(ispin -1)
              
              lt1 = lt_n_us(ll,itmp1)
              lt2 = lt_n_us(ll,itmp2)
              
              ltlt = ltlt_nm_us(ll,itmp1,ll,itmp2)
              
              if (ltlt /= 0) then
                 rho_sol(ir,ispin) = rho_sol(ir,ispin) &
                      + focc(ishell) &
                      * qps_us(ir,ltlt,0) * rpos(ir)**2 &
                      * beta_phi_sol(lt1,ips) &
                      * beta_phi_sol(lt2,ips)
              end if
           end do
        end do
     end do
  end do

  do ir = 1,nmesh
     rho_sol(ir,:) = rho_sol(ir,:) / (pi4*rpos(ir)**2)
  end do

  if (num_core_hole > 0) then          

     stop "Not supported"

     felec_sol  = felec_sol  + ftot_core_hole
     felec_core = felec_core - ftot_core_hole
     felec_val  = felec_sol

     do icore = 1,num_core_hole
        ishell = ishell_core_hole(icore)
        do ir = 1,nmesh
           rho_sol(ir,:) = rho_sol(ir,:) &
                + focc_core_hole(icore) &
                * (chi_g(ir,ishell)/rpos(ir))**2 / pi4
        end do
     end do
  end if

  sum = 0.d0
  Do ispin=1, nspin
     do ir = 1,nmesh
        sum = sum + pi4*rpos(ir)**2*wr(ir) * rho_sol(ir,ispin)
     end do
  End do

  if (abs(sum-felec_sol) > 1.d-5) then
     write(IFLOG,*) '### ERROR ### sum of rho_sol != felec_sol'
     write(IFLOG,*) '   sum of rho_sol ...', sum
     write(IFLOG,*) '   felec_sol      ...', felec_sol
     ier = 1 ; go to 99
  end if

  rho_sol(:,:) = rho_sol(:,:) * felec_sol/sum

  Do ispin=1, nspin
     do ir = 1,nmesh
        if (abs(rho_sol(ir,ispin)) < 1.d-99) then
           rho_sol(ir,ispin) = 0.d0
        end if
     end do
  end do

99 continue

end subroutine calc_rho_sol_kt
! ======================================================================= 4.0

!=====================================================================
   subroutine check_negative_rho_sol(ier)
!=====================================================================
!
!  M. Okamoto
!
!---------------------------------------------------------------------
   use parameters
   implicit none
   integer,intent(out) :: ier
   integer :: ir, is_negative
   real(8) :: rho_tmp, sum, pi4
   ier = 0
   pi4 = 4.d0 * PI
   is_negative = 0
   do ir = 1,nmesh
      select case (is_pcc)
! =========================================== modified by K. T. ============== 4.0
!      case (NONE)
!         rho_tmp = rho_sol(ir)
!      case (PCC)
!         rho_tmp = rho_sol(ir) + rho_pcore(ir)
!      case (FCC)
!         rho_tmp = rho_sol(ir) + rho_core(ir)
!      end select
!
      case (NONE)
         rho_tmp = rho_sol(ir,1)
      case (PCC)
         rho_tmp = rho_sol(ir,1) + rho_pcore(ir)
      case (FCC)
         rho_tmp = rho_sol(ir,1) + rho_core(ir)
      end select
! ============================================================================ 4.0

      if (rho_tmp < 0.d0) then
         is_negative = 1

! ========================================= modified by K. T. ============= 4.0
!         write(IFLOG,'(i10,3(1pd20.10))') ir,rpos(ir),rho_sol(ir),rho_tmp
!         rho_sol(ir) = 1.d-20
         write(IFLOG,'(i10,3(1pd20.10))') ir,rpos(ir),rho_sol(ir,1),rho_tmp
         rho_sol(ir,1) = 1.d-20
! =========================================================================== 4.0
      end if

   end do
   sum = 0.d0
   do ir = 1,nmesh
! ============================================== modified by K. T. ========== 4.0
!      sum = sum + pi4*rpos(ir)**2*wr(ir) * rho_sol(ir)
      sum = sum + pi4*rpos(ir)**2*wr(ir) * rho_sol(ir,1)
! ============================================================================= 4.0
   end do
   if (is_negative /= 0) then
      write(IFLOG,*) '### CAUTION ### rho_sol < 0 for some ir.'
      write(IFLOG,*) 'ir, rpos, rho_sol'
      do ir = 1,nmesh,10
! ================================================ modified by K. T. ========== 4.0
!         write(IFLOG,'(i10,2(1pd20.10))') ir,rpos(ir),rho_sol(ir)
         write(IFLOG,'(i10,2(1pd20.10))') ir,rpos(ir),rho_sol(ir,1)
!============================================================================== 4.0
      end do
      write(IFLOG,*) 'sum of rho_sol ...',sum
      write(IFLOG,*) 'felec_sol      ...',felec_sol

! ================================================ modified by K. T. ============ 4.0
!      rho_sol(:) = rho_sol(:) * felec_sol/sum
      rho_sol(:,1) = rho_sol(:,1) * felec_sol/sum
! =============================================================================== 4.0

      write(IFSUM,*)
      write(IFSUM,*) '##########################################'
      write(IFSUM,*) '##  [SOL] Negative charge was detected  ##'
      write(IFSUM,*) '##########################################'
      ier = 0 ; go to 99
   end if

   if (abs(sum-felec_sol) > 1.d-5) then
      write(IFLOG,*) '### ERROR ### sum of rho_sol != felec_sol'
      write(IFLOG,*) '   sum of rho_sol ...', sum
      write(IFLOG,*) '   felec_sol      ...', felec_sol
      ier = 1 ; go to 99
   end if

! ===================================== modified by K. T. ============ 4.0
!   rho_sol(:) = rho_sol(:) * felec_sol/sum
!   do ir = 1,nmesh
!      if (abs(rho_sol(ir)) < 1.d-99) then
!         rho_sol(ir) = 0.d0
!      end if
!   end do
!
   rho_sol(:,1) = rho_sol(:,1) * felec_sol/sum
   do ir = 1,nmesh
      if (abs(rho_sol(ir,1)) < 1.d-99) then
         rho_sol(ir,1) = 0.d0
      end if
   end do
! ========================================================================= 4.0

99 continue
   end subroutine check_negative_rho_sol

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

  integer,intent(out) :: ier
  integer :: ir, is_negative
  real(8) :: rho_tmp, sum, pi4

  integer :: ispin

  ier = 0
  pi4 = 4.d0 * PI
  is_negative = 0

  Do ispin=1, nspin

     do ir = 1,nmesh
        select case (is_pcc)
        case (NONE)
           rho_tmp = rho_sol(ir,ispin)
        case (PCC)
           rho_tmp = rho_sol(ir,ispin) + rho_pcore(ir)
        case (FCC)
           rho_tmp = rho_sol(ir,ispin) + rho_core(ir)
        end select

        if (rho_tmp < 0.d0) then
           is_negative = 1
           write(IFLOG,'(i10,i3,3(1pd20.10))') ir, ispin, rpos(ir), &
                &                              rho_sol(ir,ispin), rho_tmp
           rho_sol(ir,ispin) = 1.d-20
        end if

     end do
     
  End do

  sum = 0.d0

  Do ispin=1, nspin
     do ir = 1,nmesh
        sum = sum + pi4*rpos(ir)**2*wr(ir) * rho_sol(ir,ispin)
     end do
  End do

  if (is_negative /= 0) then
     write(IFLOG,*) '### CAUTION ### rho_sol < 0 for some ir.'
     write(IFLOG,*) 'ir, rpos, rho_sol'

     Do ispin=1, nspin
        write(IFLOG,*) 'ispin = ', ispin
        do ir = 1,nmesh,10
           write(IFLOG,'(i10,2(1pd20.10))') ir,rpos(ir),rho_sol(ir,ispin)
        end do
     End do

     write(IFLOG,*) 'sum of rho_sol ...',sum
     write(IFLOG,*) 'felec_sol      ...',felec_sol


     rho_sol(:,:) = rho_sol(:,:) * felec_sol/sum

     write(IFSUM,*)
     write(IFSUM,*) '##########################################'
     write(IFSUM,*) '##  [SOL] Negative charge was detected  ##'
     write(IFSUM,*) '##########################################'
     ier = 0 ; go to 99
  end if

  if (abs(sum-felec_sol) > 1.d-5) then
     write(IFLOG,*) '### ERROR ### sum of rho_sol != felec_sol'
     write(IFLOG,*) '   sum of rho_sol ...', sum
     write(IFLOG,*) '   felec_sol      ...', felec_sol
     ier = 1 ; go to 99
  end if

  rho_sol(:,:) = rho_sol(:,:) * felec_sol/sum

  Do ispin=1, nspin
     do ir = 1,nmesh
        if (abs(rho_sol(ir,ispin)) < 1.d-99) then
           rho_sol(ir,ispin) = 0.d0
        end if
     end do
  End do
! ========================================================================= 4.0

99 continue

end subroutine check_negative_rho_sol_kt
! ============================================================================= 4.0   

!=====================================================================
   subroutine calc_rho_ss(ier)
!=====================================================================
!
!  M. Okamoto
!
!---------------------------------------------------------------------
   use parameters
   implicit none
   integer,intent(out) :: ier
   integer :: ir, ishell, ll, nref, t1, t2, lt1, lt2, ltlt, iss, &
              ispin, is_negative
   real(8) :: sum, sum1, sum2, pi4, rho_tmp
   ier = 0
   is_negative = 0
   pi4 = 4.d0 * PI
   rho_ss(:,:) = 0.d0
   do iss = 1,nss
      ispin = 2-(spin_ss(iss)+1)/2
      ishell = ishell_ss(iss)
      ll = l_qnum(ishell)
      nref = nref_us(ll)
      if (is_solve_ss(iss) == 0) then
         cycle
      end if
      do ir = 1,nmesh
         rho_ss(ir,ispin) = rho_ss(ir,ispin) &
            + focc_ss(iss) * rphi_ss(ir,iss)**2
         do t1 = 1,nref
         do t2 = 1,nref
            lt1 = lt_n_us(ll,t1)
            lt2 = lt_n_us(ll,t2)
            ltlt = ltlt_nm_us(ll,t1,ll,t2)
            if (ltlt /= 0) then
               rho_ss(ir,ispin) = rho_ss(ir,ispin) &
                  + focc_ss(iss) &
                     * qps_us(ir,ltlt,0) * rpos(ir)**2 &
                     * beta_phi_ss(lt1,iss) &
                     * beta_phi_ss(lt2,iss)
            end if
         end do
         end do
         select case (is_spin_ss)
         case (RESTRICTED)
            select case (is_pcc)
            case (NONE)
               rho_tmp = rho_ss(ir,ispin)
            case (PCC)
               rho_tmp = rho_ss(ir,ispin) + rho_pcore(ir)
            case (FCC)
               rho_tmp = rho_ss(ir,ispin) + rho_core(ir)
            end select
         case (POLARIZED)
            select case (is_pcc)
            case (NONE)
               rho_tmp = rho_ss(ir,ispin)
            case (PCC)
               rho_tmp = rho_ss(ir,ispin) + rho_pcore(ir)*0.5d0
            case (FCC)
               rho_tmp = rho_ss(ir,ispin) + rho_core(ir)*0.5d0
            end select
         end select
         if (rho_tmp < 0.d0) then
            is_negative = 1
            write(IFLOG,'(2i10,3(1pd20.10))') ir,ispin,rpos(ir),rho_ss(ir,ispin),rho_tmp
         end if
      end do
   end do
   do ispin = 1,nspin_ss
   do ir = 1,nmesh
      rho_ss(ir,ispin) = rho_ss(ir,ispin) / (pi4*rpos(ir)**2)
      if (abs(rho_ss(ir,ispin)) < 1.d-99) then
         rho_ss(ir,ispin) = 0.d0
      end if
   end do
   end do
   select case (is_spin_ss)
   case (RESTRICTED)
      sum1 = 0.d0
      do ir = 1,nmesh
         sum1 = sum1 + pi4*rpos(ir)**2*wr(ir) * rho_ss(ir,1)
      end do
      sum2 = 0.d0
      if (is_negative /= 0) then
         write(IFLOG,*) '### ERROR ### rho_ss < 0 for some ir.'
         write(IFLOG,*) 'ir, rpos, rho_ss'
         do ir = 1,nmesh,10
            write(IFLOG,'(i10,2(1pd20.10))') ir,rpos(ir),rho_ss(ir,1)
         end do
         write(IFLOG,*) 'sum of rho_ss ...',sum1
         write(IFLOG,*) 'felec_ss      ...',felec_ss
         rho_ss(:,1) = rho_ss(:,1) * felec_ss/sum1
         write(IFSUM,*)
         write(IFSUM,*) '#########################################'
         write(IFSUM,*) '##  [SS] Negative charge was detected  ##'
         write(IFSUM,*) '#########################################'
         ier = 0 ; go to 99
      end if
      if (abs(sum1-felec_ss) > 1.d-5) then
         write(IFLOG,*) '### ERROR ### sum of rho_ss != felec_ss'
         write(IFLOG,*) '   sum of rho_ss ...', sum1
         write(IFLOG,*) '   felec_ss      ...', felec_ss
         ier = 1 ; go to 99
      end if
   case (POLARIZED)
      sum1 = 0.d0
      do ir = 1,nmesh
         sum1 = sum1 + pi4*rpos(ir)**2*wr(ir) * rho_ss(ir,1)
      end do
      sum2 = 0.d0
      do ir = 1,nmesh
         sum2 = sum2 + pi4*rpos(ir)**2*wr(ir) * rho_ss(ir,2)
      end do
      if (is_negative /= 0) then
         write(IFLOG,*) '### ERROR ### rho_ss < 0 for some ir.'
         write(IFLOG,*) 'ir, rpos, rho_ss(1), rho_ss(2)'
         do ir = 1,nmesh,10
            write(IFLOG,'(i10,3(1pd20.10))') ir,rpos(ir), &
                                   rho_ss(ir,1),rho_ss(ir,1)
         end do
         write(IFLOG,*) 'sum of rho_ss(1) ...',sum1
         write(IFLOG,*) 'felec1_ss        ...',felec1_ss
         write(IFLOG,*) 'sum of rho_ss(2) ...',sum2
         write(IFLOG,*) 'felec2_ss        ...',felec2_ss
         rho_ss(:,1) = rho_ss(:,1) * felec1_ss/sum1
         rho_ss(:,2) = rho_ss(:,2) * felec2_ss/sum2
         write(IFSUM,*)
         write(IFSUM,*) '#########################################'
         write(IFSUM,*) '##  [SS] Negative charge was detected  ##'
         write(IFSUM,*) '#########################################'
         ier = 0 ; go to 99
      end if
      if (abs(sum1-felec1_ss) > 1.d-5) then
         write(IFLOG,*) '### ERROR ### sum of rho_ss(1) != felec1_ss'
         write(IFLOG,*) '   sum of rho_ss(1) ...', sum1
         write(IFLOG,*) '   felec1_ss        ...', felec1_ss
         ier = 1 ; go to 99
      end if
      if (abs(sum2-felec2_ss) > 1.d-5) then
         write(IFLOG,*) '### ERROR ### sum of rho_ss(2) != felec2_ss'
         write(IFLOG,*) '   sum of rho_ss(2) ...', sum2
         write(IFLOG,*) '   felec2_ss        ...', felec2_ss
         ier = 2 ; go to 99
      end if
   end select
   sum = sum1 + sum2
   write(IFLOG,'(1x,a25,3f15.10)') &
        '??? charge (f1,f2,rho)...',sum1,sum2,sum
   select case (is_spin_ss)
   case (RESTRICTED)
      rho_ss(:,1) = rho_ss(:,1) * felec_ss/sum1
   case (POLARIZED)
      if (sum1 == 0.d0) then
         rho_ss(:,1) = 0.d0
      else
         rho_ss(:,1) = rho_ss(:,1) * felec1_ss/sum1
      end if
      if (sum2 == 0.d0) then
         rho_ss(:,2) = 0.d0
      else
         rho_ss(:,2) = rho_ss(:,2) * felec2_ss/sum2
      end if
   end select
99 continue
   end subroutine calc_rho_ss

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

  integer,intent(out) :: ier
  integer :: ir, ishell, ll, nref, t1, t2, lt1, lt2, ltlt, iss, &
              ispin, is_negative
  real(8) :: sum, sum1, sum2, pi4, rho_tmp

  integer :: itmp1, itmp2

  ier = 0
  is_negative = 0

  pi4 = 4.d0 * PI
  rho_ss(:,:) = 0.d0

  do iss = 1,nss

     ispin = 2-(spin_ss(iss)+1)/2
     ishell = ishell_ss(iss)

     ll = l_qnum(ishell)
     nref = nref_us(ll)

     if (is_solve_ss(iss) == 0) then
        cycle
     end if

     do ir = 1,nmesh
        rho_ss(ir,ispin) = rho_ss(ir,ispin) &
             + focc_ss(iss) * rphi_ss(ir,iss)**2

        do t1 = 1,nref
           do t2 = 1,nref

              itmp1 = t1 + nref_max_us * (ispin -1)
              itmp2 = t2 + nref_max_us * (ispin -1)

              if ( nspin == 1 ) then
                 itmp1 = t1;  itmp2 = t2
              endif

              lt1 = lt_n_us(ll,itmp1)
              lt2 = lt_n_us(ll,itmp2)

              ltlt = ltlt_nm_us(ll,itmp1,ll,itmp2)

              if (ltlt /= 0) then
                 rho_ss(ir,ispin) = rho_ss(ir,ispin) &
                      + focc_ss(iss) &
                      * qps_us(ir,ltlt,0) * rpos(ir)**2 &
                      * beta_phi_ss(lt1,iss) &
                      * beta_phi_ss(lt2,iss)
              end if

           end do
        end do

        select case (is_spin_ss)
        case (RESTRICTED)
           select case (is_pcc)
           case (NONE)
              rho_tmp = rho_ss(ir,ispin)
           case (PCC)
              rho_tmp = rho_ss(ir,ispin) + rho_pcore(ir)
           case (FCC)
              rho_tmp = rho_ss(ir,ispin) + rho_core(ir)
           end select
        case (POLARIZED)
           select case (is_pcc)
           case (NONE)
              rho_tmp = rho_ss(ir,ispin)
           case (PCC)
              rho_tmp = rho_ss(ir,ispin) + rho_pcore(ir)*0.5d0
           case (FCC)
              rho_tmp = rho_ss(ir,ispin) + rho_core(ir)*0.5d0
           end select
        end select

        if (rho_tmp < 0.d0) then
           is_negative = 1
           write(IFLOG,'(2i10,3(1pd20.10))') ir,ispin,rpos(ir),rho_ss(ir,ispin),rho_tmp
        end if
     end do

  end do

  do ispin = 1,nspin_ss
     do ir = 1,nmesh
        rho_ss(ir,ispin) = rho_ss(ir,ispin) / (pi4*rpos(ir)**2)
        if (abs(rho_ss(ir,ispin)) < 1.d-99) then
           rho_ss(ir,ispin) = 0.d0
        end if
     end do
  end do

  select case (is_spin_ss)

  case (RESTRICTED)
     sum1 = 0.d0
     do ir = 1,nmesh
        sum1 = sum1 + pi4*rpos(ir)**2*wr(ir) * rho_ss(ir,1)
     end do

     sum2 = 0.d0

     if (is_negative /= 0) then
        write(IFLOG,*) '### ERROR ### rho_ss < 0 for some ir.'
        write(IFLOG,*) 'ir, rpos, rho_ss'
        do ir = 1,nmesh,10
           write(IFLOG,'(i10,2(1pd20.10))') ir,rpos(ir),rho_ss(ir,1)
        end do
        write(IFLOG,*) 'sum of rho_ss ...',sum1
        write(IFLOG,*) 'felec_ss      ...',felec_ss

        rho_ss(:,1) = rho_ss(:,1) * felec_ss/sum1

        write(IFSUM,*)
        write(IFSUM,*) '#########################################'
        write(IFSUM,*) '##  [SS] Negative charge was detected  ##'
        write(IFSUM,*) '#########################################'
        ier = 0 ; go to 99
     end if

     if (abs(sum1-felec_ss) > 1.d-5) then
        write(IFLOG,*) '### ERROR ### sum of rho_ss != felec_ss'
        write(IFLOG,*) '   sum of rho_ss ...', sum1
        write(IFLOG,*) '   felec_ss      ...', felec_ss
        ier = 1 ; go to 99
     end if

  case (POLARIZED)
     sum1 = 0.d0
     do ir = 1,nmesh
        sum1 = sum1 + pi4*rpos(ir)**2*wr(ir) * rho_ss(ir,1)
     end do

     sum2 = 0.d0
     do ir = 1,nmesh
        sum2 = sum2 + pi4*rpos(ir)**2*wr(ir) * rho_ss(ir,2)
     end do

     if (is_negative /= 0) then
        write(IFLOG,*) '### ERROR ### rho_ss < 0 for some ir.'
        write(IFLOG,*) 'ir, rpos, rho_ss(1), rho_ss(2)'
        do ir = 1,nmesh,10
           write(IFLOG,'(i10,3(1pd20.10))') ir,rpos(ir), &
                rho_ss(ir,1),rho_ss(ir,1)
        end do
        write(IFLOG,*) 'sum of rho_ss(1) ...',sum1
        write(IFLOG,*) 'felec1_ss        ...',felec1_ss
        write(IFLOG,*) 'sum of rho_ss(2) ...',sum2
        write(IFLOG,*) 'felec2_ss        ...',felec2_ss

        rho_ss(:,1) = rho_ss(:,1) * felec1_ss/sum1
        rho_ss(:,2) = rho_ss(:,2) * felec2_ss/sum2

        write(IFSUM,*)
        write(IFSUM,*) '#########################################'
        write(IFSUM,*) '##  [SS] Negative charge was detected  ##'
        write(IFSUM,*) '#########################################'
        ier = 0 ; go to 99

     end if

     if (abs(sum1-felec1_ss) > 1.d-5) then
        write(IFLOG,*) '### ERROR ### sum of rho_ss(1) != felec1_ss'
        write(IFLOG,*) '   sum of rho_ss(1) ...', sum1
        write(IFLOG,*) '   felec1_ss        ...', felec1_ss
        ier = 1 ; go to 99
     end if

     if (abs(sum2-felec2_ss) > 1.d-5) then
        write(IFLOG,*) '### ERROR ### sum of rho_ss(2) != felec2_ss'
        write(IFLOG,*) '   sum of rho_ss(2) ...', sum2
        write(IFLOG,*) '   felec2_ss        ...', felec2_ss
        ier = 2 ; go to 99
     end if

  end select

  sum = sum1 + sum2
  write(IFLOG,'(1x,a25,3f15.10)') &
       '??? charge (f1,f2,rho)...',sum1,sum2,sum


  select case (is_spin_ss)

  case (RESTRICTED)
     rho_ss(:,1) = rho_ss(:,1) * felec_ss/sum1

  case (POLARIZED)
     if (sum1 == 0.d0) then
        rho_ss(:,1) = 0.d0
     else
        rho_ss(:,1) = rho_ss(:,1) * felec1_ss/sum1
     end if
     if (sum2 == 0.d0) then
        rho_ss(:,2) = 0.d0
     else
        rho_ss(:,2) = rho_ss(:,2) * felec2_ss/sum2
     end if
  end select

99 continue

end subroutine calc_rho_ss_kt
! ========================================================================== 4.0

!=====================================================================
   subroutine calc_drho_ddrho_core_sol(ier)
!=====================================================================
!
!  M. Okamoto
!
!---------------------------------------------------------------------
   use parameters
   implicit none
   integer,intent(out) :: ier
   integer :: ir
   ier = 0
   call calc_ddiff_exp(ier,iord_diff,nmesh,rpos, &
                       rho_core,drho_core,ddrho_core)
   call calc_ddiff_rho_origin(ier,iord_diff,nmesh, &
                              rpos,rho_core,drho_core,ddrho_core)
   do ir = nmesh-iord_diff*2-1,nmesh
        rho_core(ir) =   rho_core(nmesh-iord_diff*2-2)
       drho_core(ir) =  drho_core(nmesh-iord_diff*2-2)
      ddrho_core(ir) = ddrho_core(nmesh-iord_diff*2-2)
   end do
99 continue
   end subroutine calc_drho_ddrho_core_sol

!=====================================================================
   subroutine calc_drho_ddrho_pcore_sol(ier)
!=====================================================================
!
!  M. Okamoto
!
!---------------------------------------------------------------------
   use parameters
   implicit none
   integer,intent(out) :: ier
   integer :: ir
   ier = 0
   call calc_ddiff_exp(ier,iord_diff,nmesh,rpos, &
                       rho_pcore,drho_pcore,ddrho_pcore)
   call calc_ddiff_rho_origin(ier,iord_diff,nmesh, &
                              rpos,rho_pcore,drho_pcore,ddrho_pcore)
   do ir = nmesh-iord_diff*2-1,nmesh
        rho_pcore(ir) =   rho_pcore(nmesh-iord_diff*2-2)
       drho_pcore(ir) =  drho_pcore(nmesh-iord_diff*2-2)
      ddrho_pcore(ir) = ddrho_pcore(nmesh-iord_diff*2-2)
   end do
99 continue
   end subroutine calc_drho_ddrho_pcore_sol

!=====================================================================

   subroutine calc_drho_ddrho_sol(ier)
!=====================================================================
!
!  M. Okamoto
!
!---------------------------------------------------------------------
   use parameters
   implicit none
   integer,intent(out) :: ier
   integer :: ir
   ier = 0
   call calc_ddiff_exp(ier,iord_diff,nmesh,rpos, &
           rho_sol,drho_sol,ddrho_sol)
   call calc_ddiff_rho_origin(ier,iord_diff,nmesh, &
           rpos,rho_sol,drho_sol,ddrho_sol)

! ======================================= modified by K. T. ============== 4.0
!   do ir = nmesh-iord_diff*2-1,nmesh
!        rho_sol(ir) =   rho_sol(nmesh-iord_diff*2-2)
!       drho_sol(ir) =  drho_sol(nmesh-iord_diff*2-2)
!      ddrho_sol(ir) = ddrho_sol(nmesh-iord_diff*2-2)
!   end do
!
   do ir = nmesh-iord_diff*2-1,nmesh
        rho_sol(ir,1) =   rho_sol(nmesh-iord_diff*2-2,1)
       drho_sol(ir,1) =  drho_sol(nmesh-iord_diff*2-2,1)
      ddrho_sol(ir,1) = ddrho_sol(nmesh-iord_diff*2-2,1)
   end do
! ========================================================================= 4.0

99 continue
   end subroutine calc_drho_ddrho_sol

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

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

  ier = 0

  Do ispin=1, nspin
     call calc_ddiff_exp( ier, iord_diff, nmesh, rpos, &
          &               rho_sol(:,ispin), drho_sol(:,ispin),ddrho_sol(:,ispin) )
     call calc_ddiff_rho_origin(ier, iord_diff, nmesh, rpos,  &
          &               rho_sol(:,ispin), drho_sol(:,ispin),ddrho_sol(:,ispin) )
  End do

  do ir = nmesh-iord_diff*2-1,nmesh
     rho_sol(ir,:) =   rho_sol(nmesh-iord_diff*2-2,:)
     drho_sol(ir,:) =  drho_sol(nmesh-iord_diff*2-2,:)
     ddrho_sol(ir,:) = ddrho_sol(nmesh-iord_diff*2-2,:)
  end do

99 continue

end subroutine calc_drho_ddrho_sol_kt
! ================================================================== 4.0

!=====================================================================
   subroutine calc_drho_ddrho_ss(ier)
!=====================================================================
!
!  M. Okamoto
!
!---------------------------------------------------------------------
   use parameters
   implicit none
   integer,intent(out) :: ier
   integer :: ir, ispin
   ier = 0
   do ispin = 1,nspin_ss
      call calc_ddiff_exp(ier,iord_diff,nmesh,rpos(1), &
         rho_ss(1,ispin),drho_ss(1,ispin),ddrho_ss(1,ispin))
      call calc_ddiff_rho_origin(ier,iord_diff,nmesh,rpos(1), &
         rho_ss(1,ispin),drho_ss(1,ispin),ddrho_ss(1,ispin))
      do ir = nmesh-iord_diff*2-1,nmesh
           rho_ss(ir,ispin) =   rho_ss(nmesh-iord_diff*2-2,ispin)
          drho_ss(ir,ispin) =  drho_ss(nmesh-iord_diff*2-2,ispin)
         ddrho_ss(ir,ispin) = ddrho_ss(nmesh-iord_diff*2-2,ispin)
      end do
   end do
99 continue
   end subroutine calc_drho_ddrho_ss
   
!=====================================================================
   subroutine calc_drho_core_sol(ier)
!=====================================================================
!
!  M. Okamoto
!
!---------------------------------------------------------------------
   use parameters
   implicit none
   integer,intent(out) :: ier
   integer :: ir
   ier = 0
   call calc_diff_exp(ier,iord_diff,nmesh,rpos, &
                       rho_core,drho_core)
   call calc_diff_rho_origin(ier,iord_diff,nmesh, &
                              rpos,rho_core,drho_core)
   do ir = nmesh-iord_diff*2-1,nmesh
        rho_core(ir) =   rho_core(nmesh-iord_diff*2-2)
       drho_core(ir) =  drho_core(nmesh-iord_diff*2-2)
   end do
99 continue
   end subroutine calc_drho_core_sol

!=====================================================================
   subroutine calc_drho_pcore_sol(ier)
!=====================================================================
!
!  M. Okamoto
!
!---------------------------------------------------------------------
   use parameters
   implicit none
   integer,intent(out) :: ier
   integer :: ir
   ier = 0
   call calc_diff_exp(ier,iord_diff,nmesh,rpos, &
                       rho_pcore,drho_pcore)
   call calc_diff_rho_origin(ier,iord_diff,nmesh, &
                              rpos,rho_pcore,drho_pcore)
   do ir = nmesh-iord_diff*2-1,nmesh
        rho_pcore(ir) =   rho_pcore(nmesh-iord_diff*2-2)
       drho_pcore(ir) =  drho_pcore(nmesh-iord_diff*2-2)
   end do
99 continue
   end subroutine calc_drho_pcore_sol

!=====================================================================
   subroutine calc_drho_sol(ier)
!=====================================================================
!
!  M. Okamoto
!
!---------------------------------------------------------------------
   use parameters
   implicit none
   integer,intent(out) :: ier
   integer :: ir
   ier = 0
   call calc_diff_exp(ier,iord_diff,nmesh,rpos, &
           rho_sol,drho_sol)
   call calc_diff_rho_origin(ier,iord_diff,nmesh, &
           rpos,rho_sol,drho_sol)

! ====================================== modified by K. T. ============= 4.0
!   do ir = nmesh-iord_diff*2-1,nmesh
!        rho_sol(ir) =   rho_sol(nmesh-iord_diff*2-2)
!       drho_sol(ir) =  drho_sol(nmesh-iord_diff*2-2)
!   end do
   do ir = nmesh-iord_diff*2-1,nmesh
        rho_sol(ir,1) =   rho_sol(nmesh-iord_diff*2-2,1)
       drho_sol(ir,1) =  drho_sol(nmesh-iord_diff*2-2,1)
   end do
! ======================================================================== 4.0

99 continue
   end subroutine calc_drho_sol

!=====================================================================
   subroutine calc_drho_ss(ier)
!=====================================================================
!
!  M. Okamoto
!
!---------------------------------------------------------------------
   use parameters
   implicit none
   integer,intent(out) :: ier
   integer :: ir, ispin
   ier = 0
   do ispin = 1,nspin_ss
      call calc_diff_exp(ier,iord_diff,nmesh,rpos(1), &
         rho_ss(1,ispin),drho_ss(1,ispin))
      call calc_diff_rho_origin(ier,iord_diff,nmesh,rpos(1), &
         rho_ss(1,ispin),drho_ss(1,ispin))
      do ir = nmesh-iord_diff*2-1,nmesh
           rho_ss(ir,ispin) =   rho_ss(nmesh-iord_diff*2-2,ispin)
          drho_ss(ir,ispin) =  drho_ss(nmesh-iord_diff*2-2,ispin)
      end do
   end do
99 continue
   end subroutine calc_drho_ss

