!
!  Software name : CIAO (Code for Investigating Atomic Orbitals)
!  Subroutine(s) : calc_vh_sol, calc_vh_ss, calc_vxc_exc_sol
!                : calc_vxc_exc_ss, calc_dmat_ss,calc_vloc_ion_sol
!                : calc_vloc_scr_ss, write_sol, write_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_vh_sol(ier)
!=====================================================================
!
!  M. Okamoto
!
!---------------------------------------------------------------------
   use parameters
   implicit none
   integer,intent(out) :: ier
   integer :: ir, ii, i0, is, j, jr
   real(8) :: sum1, sum2
   ier = 0
   do ir = 1,nmesh
      sum1 = 0.d0
      sum2 = 0.d0
      if (ir == 1) then
         sum1 = 0.d0
      else if ((ir >= 2).and.(ir <= 5)) then
         do ii = 2,ir
            i0 = ii-1
            is = 1
            call set_open_weight_exp(ier,i0,is,rpos,wt)
            do j = 1,4
               sum1 = sum1 &
! ================================================= modified by K. T. =========== 4.0
!                  + rpos(i0+j*is)**2*rho_sol(i0+j*is)*wt(i0+j*is)
                  + rpos(i0+j*is)**2*rho_sol(i0+j*is,1)*wt(i0+j*is)
! ============================================================================== 4.0
            end do
            
         end do
      else
         call set_weight_exp(ier,1,ir,rpos,wt)
         do jr = 1,ir
! ================================================== modified by K. T. ======== 4.0
!            sum1 = sum1 + rpos(jr)**2*rho_sol(jr)*wt(jr)
            sum1 = sum1 + rpos(jr)**2*rho_sol(jr,1)*wt(jr)
! ============================================================================== 4.0
         end do
      end if
      sum1 = sum1*(4.d0*PI/rpos(ir))
      if (ir == nmesh) then
            sum2 = 0.d0
      else if ((ir <= nmesh-1).and.(ir >= nmesh-4)) then
         do ii = ir,nmesh-1
            i0 = ii+1
            is = -1
            call set_open_weight_exp(ier,i0,is,rpos,wt)
            do j = 1,4
               sum2 = sum2 &
! ======================================================== modified by K. T. ======= 4.0
!                    - rpos(i0+j*is)**2*rho_sol(i0+j*is)*wt(i0+j*is)
                    - rpos(i0+j*is)**2*rho_sol(i0+j*is,1)*wt(i0+j*is)
! ============================================================================== 4.0
            end do
         end do
      else
         call set_weight_exp(ier,ir,nmesh,rpos,wt)
         do jr = ir,nmesh
! ==================================================== modified by K. T. ======= 4.0
!            sum2 = sum2 + rpos(jr)*rho_sol(jr)*wt(jr)
            sum2 = sum2 + rpos(jr)*rho_sol(jr,1)*wt(jr)
! ============================================================================== 4.0
         end do
      end if
      sum2 = sum2*(4.d0*PI)
      vh_sol(ir) = sum1 + sum2
   end do
99 continue
   end subroutine calc_vh_sol

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

  integer,intent(out) :: ier
  integer :: ir, ii, i0, is, j, jr
  integer :: ispin

  real(8) :: sum1, sum2

  ier = 0
  do ir = 1,nmesh
     sum1 = 0.d0
     sum2 = 0.d0

     if (ir == 1) then
        sum1 = 0.d0
     else if ((ir >= 2).and.(ir <= 5)) then
        do ii = 2,ir
           i0 = ii-1
           is = 1
           
           call set_open_weight_exp(ier,i0,is,rpos,wt)
           
           do ispin = 1,nspin
              do j = 1,4
                 sum1 = sum1 &
                      & + rpos(i0+j*is)**2*rho_sol(i0+j*is,ispin)*wt(i0+j*is)
              end do
           end do
           
        end do

     else
        call set_weight_exp(ier,1,ir,rpos,wt)
        do jr = 1,ir

           do ispin = 1,nspin
              sum1 = sum1 + rpos(jr)**2*rho_sol(jr,ispin)*wt(jr)
           end do
        end do

     end if

     sum1 = sum1*(4.d0*PI/rpos(ir))

     if (ir == nmesh) then
        sum2 = 0.d0
     else if ((ir <= nmesh-1).and.(ir >= nmesh-4)) then
        do ii = ir,nmesh-1
           i0 = ii+1
           is = -1
           call set_open_weight_exp(ier,i0,is,rpos,wt)
           
           do ispin = 1,nspin
              do j = 1,4
                 sum2 = sum2 &
                      & - rpos(i0+j*is)**2*rho_sol(i0+j*is,ispin)*wt(i0+j*is)
              end do
           end do
        end do

     else
        call set_weight_exp(ier,ir,nmesh,rpos,wt)
        do jr = ir,nmesh

           do ispin=1, nspin
              sum2 = sum2 + rpos(jr)*rho_sol(jr,ispin)*wt(jr)
           end do
        end do
     end if

     sum2 = sum2*(4.d0*PI)
     vh_sol(ir) = sum1 + sum2

  end do

99 continue

end subroutine calc_vh_sol_kt
! ======================================================================= 4.0

!=====================================================================
   subroutine calc_vh_ss(ier)
!=====================================================================
!
!  M. Okamoto
!
!---------------------------------------------------------------------
   use parameters
   implicit none
   integer,intent(out) :: ier
   integer :: ir, ii, i0, is, j, jr, ispin
   real(8) :: sum1, sum2
   ier = 0
   do ir = 1,nmesh
      sum1 = 0.d0
      sum2 = 0.d0
      if (ir == 1) then
         sum1 = 0.d0
      else if ((ir >= 2).and.(ir <= 5)) then
         do ii = 2,ir
            i0 = ii-1
            is = 1
            call set_open_weight_exp(ier,i0,is,rpos,wt)
            do ispin = 1,nspin_ss
            do j = 1,4
               sum1 = sum1 &
                  + rpos(i0+j*is)**2*rho_ss(i0+j*is,ispin)*wt(i0+j*is)
            end do
            end do
         end do
      else
         call set_weight_exp(ier,1,ir,rpos,wt)
         do ispin = 1,nspin_ss
         do jr = 1,ir
            sum1 = sum1 + rpos(jr)**2*rho_ss(jr,ispin)*wt(jr)
         end do
         end do
      end if
      sum1 = sum1*(4.d0*PI/rpos(ir))
      if (ir == nmesh) then
            sum2 = 0.d0
      else if ((ir <= nmesh-1).and.(ir >= nmesh-4)) then
         do ii = ir,nmesh-1
            i0 = ii+1
            is = -1
            call set_open_weight_exp(ier,i0,is,rpos,wt)
            do ispin = 1,nspin_ss
            do j = 1,4
               sum2 = sum2 &
                    - rpos(i0+j*is)**2*rho_ss(i0+j*is,ispin)*wt(i0+j*is)
            end do
            end do
         end do
      else
         call set_weight_exp(ier,ir,nmesh,rpos,wt)
         do ispin = 1,nspin_ss
         do jr = ir,nmesh
            sum2 = sum2 + rpos(jr)*rho_ss(jr,ispin)*wt(jr)
         end do
         end do
      end if
      sum2 = sum2*(4.d0*PI)
      vh_ss(ir) = sum1 + sum2
   end do
99 continue
   end subroutine calc_vh_ss

!=====================================================================
   subroutine calc_vxc_exc_sol(ier)
!=====================================================================
!
!  M. Okamoto
!
!---------------------------------------------------------------------
   use parameters
   implicit none
   integer,intent(out) :: ier
   integer :: imode
   ier = 0
   select case (is_xc)
   case(LDAPZ81)
      call calc_xc_lda_pz81_sol(ier)
      if (ier /= 0) then
         write(IFLOG,*) '### ERROR ### in calc_xc_lda_pz81_sol'
         write(IFLOG,*) '   ier ...',ier ; go to 99
      end if
   case(LDAPW92_MOMO)
      call calc_xc_lda_pw92_sol(ier)
      if (ier /= 0) then
         write(IFLOG,*) '### ERROR ### in calc_xc_lda_pw92_sol'
         write(IFLOG,*) '   ier ...',ier ; go to 99
      end if
   case(LDAPW92_GNCPP, GGAPBE96_GNCPP, GGAPBE96_KATO, &
        GGAPW91_F90, GGAPW91_F77)
      ier = 1 ! call calc_xc_gga_gncpp_sol(ier)
      if (ier /= 0) then
         write(IFLOG,*) '### ERROR ### in calc_xc_gga_gncpp_sol'
         write(IFLOG,*) '   ier ...',ier ; go to 99
      end if
   case(GGAPBE96_MOMO)
      imode = 0
      call calc_xc_gga_pbe96_sol(ier,imode)
      if (ier /= 0) then
         write(IFLOG,*) '### ERROR ### in calc_xc_gga_pbe96_sol'
         write(IFLOG,*) '   ier   ...',ier
         write(IFLOG,*) '   imode ...',imode
         go to 99
      end if
   case(GGAPBE96_MOMO2)
      imode = 0
      call calc_xc_gga_pbe96_rad_sol(ier,imode)
      if (ier /= 0) then
         write(IFLOG,*) '### ERROR ### in calc_xc_gga_pbe96_rad_sol'
         write(IFLOG,*) '   ier   ...',ier
         write(IFLOG,*) '   imode ...',imode
         go to 99
      end if
   case(REVPBE)
      imode = 1
      call calc_xc_gga_pbe96_sol(ier,imode)
      if (ier /= 0) then
         write(IFLOG,*) '### ERROR ### in calc_xc_gga_pbe96_sol'
         write(IFLOG,*) '   ier   ...',ier
         write(IFLOG,*) '   imode ...',imode
         go to 99
      end if
   case(GGAPW91_MOMO, GGAPW91_MOMO2)
      call calc_xc_gga_pw91_rad_sol(ier)
      if (ier /= 0) then
         write(IFLOG,*) '### ERROR ### in calc_xc_gga_pw91_rad_sol'
         write(IFLOG,*) '   ier   ...',ier
         go to 99
      end if
   case(XLDA)
      call calc_x_lda_sol(ier)
      if (ier /= 0) then
         write(IFLOG,*) '### ERROR ### in calc_x_lda_sol'
         write(IFLOG,*) '   ier ...',ier ; go to 99
      end if
   case(XGGA)
      call calc_x_gga_sol(ier)
      if (ier /= 0) then
         write(IFLOG,*) '### ERROR ### in calc_x_gga_sol'
         write(IFLOG,*) '   ier ...',ier ; go to 99
      end if
   case(NONE)
      call calc_xc_none_sol(ier)
      if (ier /= 0) then
         write(IFLOG,*) '### ERROR ### in calc_xc_none_sol'
         write(IFLOG,*) '   ier ...',ier ; go to 99
      end if
   end select
99 continue
   end subroutine calc_vxc_exc_sol

!=========================================== adde by K. T. ============== 4.0
subroutine calc_vxc_exc_sol_kt(ier)
  use parameters
  implicit none

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

  ier = 0

  select case (is_xc)
     
  case(LDAPZ81)
     call calc_xc_lda_pz81_sol_kt(ier)
     if (ier /= 0) then
        write(IFLOG,*) '### ERROR ### in calc_xc_lda_pz81_sol_kt'
        write(IFLOG,*) '   ier ...',ier ; go to 99
     end if

  case(LDAPW92_MOMO)
     call calc_xc_lda_pw92_sol_kt(ier)
     if (ier /= 0) then
        write(IFLOG,*) '### ERROR ### in calc_xc_lda_pw92_sol_kt'
        write(IFLOG,*) '   ier ...',ier ; go to 99
     end if

  case(LDAPW92_GNCPP, GGAPBE96_GNCPP, GGAPBE96_KATO, &
       GGAPW91_F90, GGAPW91_F77)
     ier = 1 ! call calc_xc_gga_gncpp_sol(ier)
     if (ier /= 0) then
        write(IFLOG,*) '### ERROR ### in calc_xc_gga_gncpp_sol'
        write(IFLOG,*) '   ier ...',ier ; go to 99
     end if

  case(GGAPBE96_MOMO)
     imode = 0
     call calc_xc_gga_pbe96_sol_kt(ier,imode)
     if (ier /= 0) then
        write(IFLOG,*) '### ERROR ### in calc_xc_gga_pbe96_sol_kt'
        write(IFLOG,*) '   ier   ...',ier
        write(IFLOG,*) '   imode ...',imode
        go to 99
     end if

  case(GGAPBE96_MOMO2)
     imode = 0
     call calc_xc_gga_pbe96_rad_sol_kt(ier,imode)
     if (ier /= 0) then
        write(IFLOG,*) '### ERROR ### in calc_xc_gga_pbe96_rad_sol_kt'
        write(IFLOG,*) '   ier   ...',ier
        write(IFLOG,*) '   imode ...',imode
        go to 99
     end if

  case(REVPBE)
     imode = 1
     call calc_xc_gga_pbe96_sol_kt(ier,imode)
     if (ier /= 0) then
        write(IFLOG,*) '### ERROR ### in calc_xc_gga_pbe96_sol_kt'
        write(IFLOG,*) '   ier   ...',ier
        write(IFLOG,*) '   imode ...',imode
        go to 99
     end if

  case(GGAPW91_MOMO, GGAPW91_MOMO2)
     call calc_xc_gga_pw91_rad_sol_kt(ier)
     if (ier /= 0) then
        write(IFLOG,*) '### ERROR ### in calc_xc_gga_pw91_rad_sol_kt'
        write(IFLOG,*) '   ier   ...',ier
        go to 99
     end if
     
  case(XLDA)
     call calc_x_lda_sol_kt(ier)
     if (ier /= 0) then
        write(IFLOG,*) '### ERROR ### in calc_x_lda_sol_kt'
        write(IFLOG,*) '   ier ...',ier ; go to 99
     end if

  case(XGGA)
     call calc_x_gga_sol_kt(ier)
     if (ier /= 0) then
        write(IFLOG,*) '### ERROR ### in calc_x_gga_sol_kt'
        write(IFLOG,*) '   ier ...',ier ; go to 99
     end if

  case(NONE)
     call calc_xc_none_sol(ier)
     if (ier /= 0) then
        write(IFLOG,*) '### ERROR ### in calc_xc_none_sol'
        write(IFLOG,*) '   ier ...',ier ; go to 99
     end if
  end select

99 continue

end subroutine calc_vxc_exc_sol_kt
! =============================================================================== 4.0

!=====================================================================
   subroutine calc_vxc_exc_ss(ier)
!=====================================================================
!
!  M. Okamoto
!
!---------------------------------------------------------------------
   use parameters
   implicit none
   integer,intent(out) :: ier
   integer :: imode
   ier = 0
   select case (is_xc)
   case(LDAPZ81)
      call calc_xc_lda_pz81_ss(ier)
      if (ier /= 0) then
         write(IFLOG,*) '### ERROR ### in calc_xc_lda_pz81_ss'
         write(IFLOG,*) '   ier ...',ier ; go to 99
      end if
   case(LDAPW92_MOMO)
      call calc_xc_lda_pw92_ss(ier)
      if (ier /= 0) then
         write(IFLOG,*) '### ERROR ### in calc_xc_lda_pw92_ss'
         write(IFLOG,*) '   ier ...',ier ; go to 99
      end if
   case(LDAPW92_GNCPP, GGAPBE96_GNCPP, GGAPBE96_KATO, &
        GGAPW91_F90, GGAPW91_F77)
      ier = 1 ! call calc_xc_gga_gncpp_ss(ier)
      if (ier /= 0) then
         write(IFLOG,*) '### ERROR ### in calc_xc_gga_gncpp_ss'
         write(IFLOG,*) '   ier ...',ier ; go to 99
      end if
   case(GGAPBE96_MOMO)
      imode = 0
      call calc_xc_gga_pbe96_ss(ier,imode)
      if (ier /= 0) then
         write(IFLOG,*) '### ERROR ### in calc_xc_gga_pbe96_ss'
         write(IFLOG,*) '   ier   ...',ier
         write(IFLOG,*) '   imode ...',imode
         go to 99
      end if
   case(GGAPBE96_MOMO2)
      imode = 0
      call calc_xc_gga_pbe96_rad_ss(ier,imode)
      if (ier /= 0) then
         write(IFLOG,*) '### ERROR ### in calc_xc_gga_pbe96_rad_ss'
         write(IFLOG,*) '   ier   ...',ier
         write(IFLOG,*) '   imode ...',imode
         go to 99
      end if
   case(REVPBE)
      imode = 1
      call calc_xc_gga_pbe96_ss(ier,imode)
      if (ier /= 0) then
         write(IFLOG,*) '### ERROR ### in calc_xc_gga_pbe96_ss'
         write(IFLOG,*) '   ier   ...',ier
         write(IFLOG,*) '   imode ...',imode
         go to 99
      end if
   case(GGAPW91_MOMO, GGAPW91_MOMO2)
      call calc_xc_gga_pw91_rad_ss(ier)
      if (ier /= 0) then
         write(IFLOG,*) '### ERROR ### in calc_xc_gga_pw91_rad_ss'
         write(IFLOG,*) '   ier   ...',ier
         go to 99
      end if
   case(XLDA)
      call calc_x_lda_ss(ier)
      if (ier /= 0) then
         write(IFLOG,*) '### ERROR ### in calc_x_lda_ss'
         write(IFLOG,*) '   ier ...',ier ; go to 99
      end if
   case(XGGA)
      call calc_x_gga_ss(ier)
      if (ier /= 0) then
         write(IFLOG,*) '### ERROR ### in calc_x_gga_ss'
         write(IFLOG,*) '   ier ...',ier ; go to 99
      end if
   case(NONE)
      call calc_xc_none_ss(ier)
      if (ier /= 0) then
         write(IFLOG,*) '### ERROR ### in calc_xc_none_ss'
         write(IFLOG,*) '   ier ...',ier ; go to 99
      end if
   end select
99 continue
   end subroutine calc_vxc_exc_ss

!=====================================================================
   subroutine calc_dmat_ss(ier)
!=====================================================================
!
!  M. Okamoto
!
!---------------------------------------------------------------------
   use parameters
   implicit none
   integer,intent(out) :: ier
   integer :: ir, ltlt, ltt, ll, tn, tm, ispin
   real(8) :: r, sum
   ier = 0
   do ispin = 1,nspin_ss
   do ltt = 1,num_lttx_us
      ll   = l_ltt_us(ltt)
      tn   = tn_ltt_us(ltt)
      tm   = tm_ltt_us(ltt)
      ltlt = ltlt_nm_us(ll,tn,ll,tm)
      if (ltlt /= 0) then
         sum = 0.d0
         do ir = 1,nmesh
            r = rpos(ir)
            sum = sum &
            + r*r*wr(ir) * vloc_scr_ss(ir,ispin) * qps_us(ir,ltlt,0)
         end do
      else
         sum = 0.d0
      end if
      vlocqps_ss(ltt,ispin) = sum
      dmat_ss(ltt,ispin) = dion_us(ltt) + vlocqps_ss(ltt,ispin)
   end do
   end do
99 continue
   end subroutine calc_dmat_ss

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

  integer,intent(out) :: ier
  integer :: ir, ltlt, ltt, ll, tn, tm, ispin

  integer :: myspin1, myspin2, itmp1, itmp2
  real(8) :: r, sum

  ier = 0
  dmat_ss = 0.0d0

  do ispin = 1,nspin_ss

     do ltt = 1,num_lttx_us
        ll   = l_ltt_us(ltt)
        tn   = tn_ltt_us(ltt)
        tm   = tm_ltt_us(ltt)
!
        myspin1 = spin1_index_ltt_us(ltt)
        myspin2 = spin2_index_ltt_us(ltt)

        if ( nspin == 2 ) then
           if ( myspin1 /= myspin2 ) cycle
           if ( myspin1 /= ispin ) cycle
        endif
!
        itmp1 = tn + nref_max_us *(myspin1 -1)
        itmp2 = tm + nref_max_us *(myspin2 -1)

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

        if (ltlt /= 0) then
           sum = 0.d0
           do ir = 1,nmesh
              r = rpos(ir)
              sum = sum &
                   + r*r*wr(ir) * vloc_scr_ss(ir,ispin) * qps_us(ir,ltlt,0)
           end do
        else
           sum = 0.d0
        end if
        vlocqps_ss(ltt,ispin) = sum
        dmat_ss(ltt,ispin) = dion_us(ltt) + vlocqps_ss(ltt,ispin)

     end do
  end do

99 continue

end subroutine calc_dmat_ss_kt
! ======================================================================= 4.0

!=====================================================================
   subroutine calc_vloc_ion_sol(ier)
!=====================================================================
!
!  M. Okamoto
!
!---------------------------------------------------------------------
   use parameters
   implicit none
   integer,intent(out) :: ier
   integer :: ips, ir
   ier = 0
   call calc_vh_sol(ier)
   if (ier /= 0) then
      write(IFLOG,*) '### ERROR ### in calc_vh_sol'
      write(IFLOG,*) '   ier ...',ier ; go to 99
   end if
   call calc_vxc_exc_sol(ier)
   if (ier /= 0) then
      write(IFLOG,*) '### ERROR ### in calc_vxc_exc_sol'
      write(IFLOG,*) '   ier ...',ier ; go to 99
   end if

! ======================================= modified by K. T. ========= 4.0
!   vloc_ion_sol(:) = vloc_scr_sol(:) - vh_sol(:) &
!                        - vx_sol(:) - vc_sol(:)
   vloc_ion_sol(:,1) = vloc_scr_sol(:,1) - vh_sol(:) &
                        - vx_sol(:,1) - vc_sol(:,1)
! =================================================================== 4.0

   do ips = 1,nps
   do ir = 1,nmesh
! ======================================= modified by K. T. =========== 4.0
!      vion_ps(ir,ips,:) = veff_ps(ir,ips,:) - vh_sol(ir) &
!                     - vx_sol(ir) - vc_sol(ir)
      vion_ps(ir,ips,:) = veff_ps(ir,ips,:) - vh_sol(ir) &
                     - vx_sol(ir,1) - vc_sol(ir,1)
! ==================================================================== 4.0
   end do
   end do
99 continue
   end subroutine calc_vloc_ion_sol

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

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

  ier = 0

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

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

  Do ispin=1, nspin
     vloc_ion_sol(:,ispin) = vloc_scr_sol(:,ispin) - vh_sol(:) &
          &            - vx_sol(:,ispin) - vc_sol(:,ispin)
  End do

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

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

     do ir = 1,nmesh
        vion_ps(ir,ips,:) = veff_ps(ir,ips,:) - vh_sol(ir) &
             - vx_sol(ir,ispin) - vc_sol(ir,ispin)
     end do
  end do

99 continue

end subroutine calc_vloc_ion_sol_kt
! ================================================================================ 4.0

!=====================================================================
   subroutine calc_vloc_scr_ss(ier)
!=====================================================================
!
!  M. Okamoto
!
!---------------------------------------------------------------------
   use parameters
   implicit none
   integer,intent(out) :: ier
   integer :: ispin, ir
   ier = 0
   call calc_vh_ss(ier)
   if (ier /= 0) then
      write(IFLOG,*) '### ERROR ### in calc_vh_ss'
      write(IFLOG,*) '   ier ...',ier ; go to 99
   end if
   call calc_vxc_exc_ss(ier)
   if (ier /= 0) then
      write(IFLOG,*) '### ERROR ### in calc_vxc_exc_ss'
      write(IFLOG,*) '   ier ...',ier ; go to 99
   end if
   do ispin = 1,nspin_ss
      do ir = 1,nmesh
! =============================================== modified by K. T. ========= 4.0
!         vloc_scr_ss(ir,ispin) = vloc_ion_sol(ir) + vh_ss(ir) &
!                               + vx_ss(ir,ispin) + vc_ss(ir,ispin)
         vloc_scr_ss(ir,ispin) = vloc_ion_sol(ir,1) + vh_ss(ir) &
                               + vx_ss(ir,ispin) + vc_ss(ir,ispin)
! ============================================================================ 4.0
      end do
   end do
   call calc_dmat_ss(ier)
   if (ier /= 0) then
      write(IFLOG,*) '### ERROR ### in calc_dmat_ss'
      write(IFLOG,*) '   ier ...',ier ; go to 99
   end if
99 continue
   end subroutine calc_vloc_scr_ss

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

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

  ier = 0

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

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


! -------
!  Do ir=1, nmesh
!     write(500,*) ir, ( vloc_ion_sol(ir,ispin), ispin=1, nspin )
!  End do
!  stop

! ------
  if ( nspin==1 ) then
     do ispin = 1,nspin_ss
        do ir = 1,nmesh
           vloc_scr_ss(ir,ispin) = vloc_ion_sol(ir,1) + vh_ss(ir) &
                + vx_ss(ir,ispin) + vc_ss(ir,ispin)
        end do
     end do
  else if ( nspin == 2 ) then

     do ispin = 1,nspin_ss

        ispin_ps = ispin              ! uncertain

        do ir = 1,nmesh
           vloc_scr_ss(ir,ispin) = vloc_ion_sol(ir,ispin_ps) + vh_ss(ir) &
                + vx_ss(ir,ispin) + vc_ss(ir,ispin)
        end do
     end do
  endif
  
  call calc_dmat_ss_kt(ier)                ! Hen ??

!  call calc_dmat_ss(ier)
  if (ier /= 0) then
     write(IFLOG,*) '### ERROR ### in calc_dmat_ss_kt'
     write(IFLOG,*) '   ier ...',ier ; go to 99
  end if
   
99 continue

end subroutine calc_vloc_scr_ss_kt
! =========================================================================== 4.0

!=====================================================================
   subroutine write_sol(ier)
!=====================================================================
!
!  M. Okamoto
!
!---------------------------------------------------------------------
   use parameters
   implicit none
   integer,intent(out) :: ier
   integer :: ips, ishell, ir, nn, ll, kk, jj2, ispin
   character(1) :: fn_label_orbital
   character(2) :: ch_del, ch2
   ier = 0
   ch_del = ','//' '
   open(IFSOL,file=trim(solfile),status='unknown')
   write(IFSOL,*) 'Solved eigen-functions for the present pseudopotential'
   call write_file_header(IFSOL)
   write(IFSOL,*)
   select case (nspin)
   case (1)
      write(IFSOL,*) &
         'rpos, rho_ae, rho_sol, vloc_ion_us, vh_sol, vxc_sol'
      do ir = 1,nmesh
! =============================================== modified by K. T. ============ 4.0
!         write(IFSOL,10) rpos(ir),rho(ir,1),rho_sol(ir), &
!            vloc_ion_us(ir),vh_sol(ir),vx_sol(ir)+vc_sol(ir)
         write(IFSOL,10) rpos(ir),rho(ir,1),rho_sol(ir,1), &
            vloc_ion_us(ir,1),vh_sol(ir),vx_sol(ir,1) +vc_sol(ir,1)
! ============================================================================= 4.0
      end do
   case (2)
      write(IFSOL,*) &
         'rpos, rho1, rho2, rho_sol, vloc_ion_us, vh_sol, vxc_sol'
      do ir = 1,nmesh
! ================================================ modified by K. T. =========== 4.0
!         write(IFSOL,10) rpos(ir),rho(ir,1),rho(ir,2),rho_sol(ir), &
!            vloc_ion_us(ir),vh_sol(ir),vx_sol(ir)+vc_sol(ir)
         write(IFSOL,10) rpos(ir),rho(ir,1),rho(ir,2),rho_sol(ir,1), &
            vloc_ion_us(ir,1),vh_sol(ir),vx_sol(ir,1) +vc_sol(ir,1)
! ============================================================================== 4.0
      end do
   end select
   do ips = 1,nps
      ishell = ishell_ps(ips,1)
      nn = n_qnum(ishell)
      ll = l_qnum(ishell)
      kk = k_qnum(ishell)
      jj2 = j2_qnum(ishell)
      ispin = (1-spin(ishell))/2 + 1
      ch2(1:2) = '_'//fn_label_orbital(ll)
      write(IFSOL,*)
      write(IFSOL,30) nn,ll,jj2,ispin,'(n, l, 2*j, s)'
      write(IFSOL,31) engy_sol(ips),  'elevel'
      write(IFSOL,*)
      write(IFSOL,*) &
         'rpos'//ch2//ch_del//'rphi_sol'//ch2
      do ir = 1,nmesh
         write(IFSOL,10) rpos(ir),rphi_sol(ir,ips)
      end do
   end do
10 format(10(1pe20.10))
30 format(1x,4i5,   5x,':',1x,a14)
31 format(1x,f20.10,5x,':',1x,a6)
   close(IFSOL)
   end subroutine write_sol

!=====================================================================
   subroutine write_ss(ier)
!=====================================================================
!
!  M. Okamoto
!
!---------------------------------------------------------------------
   use parameters
   implicit none
   integer,intent(out) :: ier
   integer :: ips, iss, ishell, ir, nn, ll, kk, jj2, ispin
   character(1) :: fn_label_orbital
   character(2) :: ch_del, ch2
   ier = 0
   ch_del = ','//' '
   open(IFSOL,file=trim(solfile),status='unknown')
   write(IFSOL,*) 'Solved eigen-functions for the present pseudopotential'
   call write_file_header(IFSOL)
   write(IFSOL,*)
   select case (is_solve_pp_spin)
   case (NO)
      write(IFSOL,*) &
         'rpos, rho_ae, rho_sol, vloc_ion_us, vh_sol, vxc_sol'
      do ir = 1,nmesh
! ============================================ modified by K. T. ============ 4.0
!         write(IFSOL,10) rpos(ir),rho(ir,1),rho_sol(ir), &
!            vloc_ion_us(ir),vh_sol(ir),vx_sol(ir)+vc_sol(ir)
         write(IFSOL,10) rpos(ir),rho(ir,1),rho_sol(ir,1), &
            vloc_ion_us(ir,1),vh_sol(ir),vx_sol(ir,1)+vc_sol(ir,1)
! =========================================================================== 4.0
      end do
      do ips = 1,nps
         ishell = ishell_ps(ips,1)
         nn = n_qnum(ishell)
         ll = l_qnum(ishell)
         kk = k_qnum(ishell)
         jj2 = j2_qnum(ishell)
         ispin = (1-spin(ishell))/2 + 1
         ch2(1:2) = '_'//fn_label_orbital(ll)
         write(IFSOL,*)
         write(IFSOL,30) nn,ll,jj2,ispin,'(n, l, 2*j, s)'
         write(IFSOL,31) engy_sol(ips),  'elevel'
         write(IFSOL,*)
         write(IFSOL,*) &
            'rpos'//ch2//ch_del//'rphi_sol'//ch2
         do ir = 1,nmesh
            write(IFSOL,10) rpos(ir),rphi_sol(ir,ips)
         end do
      end do
   case (YES)
      select case (nspin_ss)
      case (1)
         write(IFSOL,*) &
            'rpos, rho_ae, rho_ss, vloc_ion_us, vh_ss, vxc_ss'
         do ir = 1,nmesh
            write(IFSOL,10) &
! ================================================ modified by K. T. ======== 4.0
!               rpos(ir),rho(ir,1),rho_ss(ir,1), &
!               vloc_ion_us(ir),vh_ss(ir),vx_ss(ir,1)+vc_ss(ir,1)

               rpos(ir),rho(ir,1),rho_ss(ir,1), &
               vloc_ion_us(ir,1),vh_ss(ir),vx_ss(ir,1)+vc_ss(ir,1)
! ============================================================================= 4.0

         end do
      case (2)
         write(IFSOL,*) &
            'rpos, rho_ae, rho_ss1, rho_ss2, vloc_ion_us, vh_ss, vxc_ss1, vxc_ss2'
         do ir = 1,nmesh
            write(IFSOL,10) &
! ================================================ modified by K. T. ======== 4.0
!               rpos(ir),rho(ir,1),rho_ss(ir,1),rho_ss(ir,2), &
!               vloc_ion_us(ir),vh_ss(ir), &
!               vx_ss(ir,1)+vc_ss(ir,1),vx_ss(ir,2)+vc_ss(ir,2)
!
               rpos(ir),rho(ir,1),rho_ss(ir,1),rho_ss(ir,2), &
               vloc_ion_us(ir,1),vh_ss(ir), &
               vx_ss(ir,1)+vc_ss(ir,1),vx_ss(ir,2)+vc_ss(ir,2)
! ========================================================================== 4.0
         end do
      end select
      do iss = 1,nss
         ishell = ishell_ss(iss)
         nn = n_qnum(ishell)
         ll = l_qnum(ishell)
         kk = k_qnum(ishell)
         jj2 = j2_qnum(ishell)
         ispin = (1-spin_ss(iss))/2 + 1
         ch2(1:2) = '_'//fn_label_orbital(ll)
         write(IFSOL,*)
         write(IFSOL,30) nn,ll,jj2,ispin,'(n, l, 2*j, s)'
         write(IFSOL,31) engy_ss(iss),  'elevel'
         write(IFSOL,*)
         write(IFSOL,*) &
            'rpos'//ch2//ch_del//'rphi_ss'//ch2
         do ir = 1,nmesh
            write(IFSOL,10) rpos(ir),rphi_ss(ir,iss)
         end do
      end do
   end select
10 format(10(1pe20.10))
30 format(1x,4i5,   5x,':',1x,a14)
31 format(1x,f20.10,5x,':',1x,a6)
   close(IFSOL)
   end subroutine write_ss
