! ************************************************************* 
!
!   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
!
!   Version history: 
!
!     4.0:  2013/03/01
!           codes for spin-polarized pseudopotential generation are added
!     4.1:  2013/11/22 - 
!           Info of core wfns and energy contributions can be added to gncpp2
!     4.2:  2014/07/23 - 
!           gncpp2 can be geregated even when nmesh /= 1501
!
! ************************************************************* 
!
!  Software name : CIAO (Code for Investigating Atomic Orbitals)
!  Subroutine(s) : calc_etot_sol, calc_etot_ss, write_etot_sol
!  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_etot_sol(ier)
!=====================================================================
!
!  M. Okamoto
!
!---------------------------------------------------------------------
   use parameters
   implicit none
   integer,intent(out) :: ier
   integer :: ir, ishell, ips, ll, t1, t2, ltt, &
              iord_tmp, lt1, lt2, nref
   real(8) :: r, pi4, pi2
   real(8),allocatable :: drphi_tmp(:)
   ier = 0
   pi4 = 4.d0*PI ; pi2 = 2.d0*PI
  !++++++++++++++++++++++++++++++++++++++++++++++
   allocate(drphi_tmp(nmesh)) ; drphi_tmp = 0.d0
  !++++++++++++++++++++++++++++++++++++++++++++++
   iord_tmp = 5
   ekin_sum1_sol = 0.d0
   do ips = 1,nps
      ishell = ishell_ps(ips,1)
      if (is_solve(ishell) == 0) then
         cycle
      end if
      ll = l_qnum(ishell)
      call calc_diff_exp(ier,iord_tmp,nmesh,rpos, &
                         rphi_sol(1,ips),drphi_tmp)
      do ir = 1,nmesh
         r = rpos(ir)
         ekin_sum1_sol = ekin_sum1_sol + focc_sol(ips) &
         * 0.5d0*wr(ir) &
         *( drphi_tmp(ir)**2 &
            + dble(ll*(ll+1))*(rphi_sol(ir,ips)/r)**2 )
      end do
   end do
  !++++++++++++++++++++++
   deallocate(drphi_tmp)
  !++++++++++++++++++++++
   eband_sum_sol = 0.d0
   do ips = 1,nps
      ishell = ishell_ps(ips,1)
      if (is_solve(ishell) /= 0) then
         eband_sum_sol = eband_sum_sol + focc_sol(ips) * engy_sol(ips)
      end if
   end do
   eloc_ion_sum_sol = 0.d0
   do ir = 1,nmesh
      r = rpos(ir)
      eloc_ion_sum_sol = eloc_ion_sum_sol &
! =========================================== modified by K. T. ============ 4.0
!         + pi4*r*r*wr(ir)*rho_sol(ir)*vloc_ion_sol(ir)
         + pi4*r*r*wr(ir)*rho_sol(ir,1)*vloc_ion_sol(ir,1)
! =========================================================================== 4.0

   end do
   enl_ion_sum_sol = 0.d0
   do ips = 1,nps
      ishell = ishell_ps(ips,1)
      if (is_solve(ishell) == 0) then
         cycle
      end if
      ll = l_qnum(ishell)
      nref = nref_us(ll)
      do t1 = 1,nref
      do t2 = 1,nref
         lt1 = lt_n_us(ll,t1)
         lt2 = lt_n_us(ll,t2)
         ltt = ltt_nm_us(ll,t1,t2)
         enl_ion_sum_sol = enl_ion_sum_sol &
            + focc_sol(ips) * dion_us(ltt) &
               * beta_phi_sol(lt1,ips) &
               * beta_phi_sol(lt2,ips)
      end do
      end do
   end do
   vlocqps_sum_sol = 0.d0
   do ips = 1,nps
      ishell = ishell_ps(ips,1)
      if (is_solve(ishell) == 0) then
         cycle
      end if
      ll = l_qnum(ishell)
      nref = nref_us(ll)
      do t1 = 1,nref
      do t2 = 1,nref
         lt1 = lt_n_us(ll,t1)
         lt2 = lt_n_us(ll,t2)
         ltt = ltt_nm_us(ll,t1,t2)
         vlocqps_sum_sol = vlocqps_sum_sol &
            + focc_sol(ips) * vlocqps_us(ltt) &
               * beta_phi_sol(lt1,ips) &
               * beta_phi_sol(lt2,ips)
      end do
      end do
   end do
   eh_sum_sol = 0.d0
   do ir = 1,nmesh
      r = rpos(ir)
      eh_sum_sol = eh_sum_sol &
! ================================================== modified by K. T. ========= 4.0
!             + pi2*r*r*wr(ir)*rho_sol(ir)*vh_sol(ir)
             + pi2*r*r*wr(ir)*rho_sol(ir,1)*vh_sol(ir)
! ============================================================================== 4.0

   end do
   select case (is_xc)
   case (LDAPW92_GNCPP, GGAPW91_F90, GGAPW91_F77, &
         GGAPBE96_GNCPP, GGAPBE96_KATO, &
         GGAPBE96_MOMO2)
   case default
      ex_sum_sol   = 0.d0
      ec_sum_sol   = 0.d0
      expc_sum_sol = 0.d0
      ecpc_sum_sol = 0.d0
      select case (is_pcc)
      case (NONE)
         do ir = 1,nmesh
            r = rpos(ir)
            ex_sum_sol = ex_sum_sol &
! ============================================ modified by K. T. ============ 4.0
!               + pi4*r*r*wr(ir)*rho_sol(ir)*ex_sol(ir)
               + pi4*r*r*wr(ir)*rho_sol(ir,1)*ex_sol(ir)
! ============================================================================ 4.0

            ec_sum_sol = ec_sum_sol &
! ============================================ modified by K. T. ============ 4.0
!               + pi4*r*r*wr(ir)*rho_sol(ir)*ec_sol(ir)
               + pi4*r*r*wr(ir)*rho_sol(ir,1)*ec_sol(ir)
! ============================================================================ 4.0
         end do

      case (PCC,FCC)
         do ir = 1,nmesh
            r = rpos(ir)
! ============================================ modified by K. T. ============== 4.0
!            ex_sum_sol = ex_sum_sol &
!               + pi4*r*r*wr(ir)*(rho_sol(ir)+rho_pcore(ir))*ex_sol(ir)
!            ec_sum_sol = ec_sum_sol &
!               + pi4*r*r*wr(ir)*(rho_sol(ir)+rho_pcore(ir))*ec_sol(ir)
!
            ex_sum_sol = ex_sum_sol &
               + pi4*r*r*wr(ir)*(rho_sol(ir,1)+rho_pcore(ir))*ex_sol(ir)
            ec_sum_sol = ec_sum_sol &
               + pi4*r*r*wr(ir)*(rho_sol(ir,1)+rho_pcore(ir))*ec_sol(ir)
! =========================================================================== 4.0

            expc_sum_sol = expc_sum_sol &
               - pi4*r*r*wr(ir)*rho_pcore(ir)*expc_sol(ir)
            ecpc_sum_sol = ecpc_sum_sol &
               - pi4*r*r*wr(ir)*rho_pcore(ir)*ecpc_sol(ir)
         end do
      end select
   end select
   exc_sum_sol   = ex_sum_sol + ec_sum_sol
   excpc_sum_sol = expc_sum_sol + ecpc_sum_sol
   vx_sum_sol = 0.d0
   vc_sum_sol = 0.d0
   do ir = 1,nmesh
      r = rpos(ir)

! ========================================= modified by K. T. ============ 4.0
!      vx_sum_sol = vx_sum_sol &
!         + pi4*r*r*wr(ir)*rho_sol(ir)*vx_sol(ir)
!      vc_sum_sol = vc_sum_sol &
!         + pi4*r*r*wr(ir)*rho_sol(ir)*vc_sol(ir)
!
      vx_sum_sol = vx_sum_sol &
         + pi4*r*r*wr(ir)*rho_sol(ir,1)*vx_sol(ir,1)
      vc_sum_sol = vc_sum_sol &
         + pi4*r*r*wr(ir)*rho_sol(ir,1)*vc_sol(ir,1)
! ========================================================================= 4.0

   end do
   vxc_sum_sol = vx_sum_sol + vc_sum_sol
   eion_sum_sol  = eloc_ion_sum_sol + enl_ion_sum_sol
   etot_sum1_sol = ekin_sum1_sol + eion_sum_sol  &
                 + eh_sum_sol + exc_sum_sol + excpc_sum_sol
   etot_sum2_sol = eband_sum_sol - eh_sum_sol  &
                 + exc_sum_sol - vxc_sum_sol + excpc_sum_sol
   etot_sum_sol  = etot_sum2_sol
   etot_sol      = etot_sum_sol
   ekin_sum2_sol = eband_sum_sol - eion_sum_sol - 2.d0*eh_sum_sol &
                 - vxc_sum_sol
   ekin_sum_sol  = ekin_sum2_sol
   end subroutine calc_etot_sol

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

  integer,intent(out) :: ier
  integer :: ir, ishell, ips, ll, t1, t2, ltt, &
              iord_tmp, lt1, lt2, nref
  real(8) :: r, pi4, pi2
  real(8),allocatable :: drphi_tmp(:)

  integer :: ispin, itmp1, itmp2
  real(8) :: rho_tmp

  ier = 0
  pi4 = 4.d0*PI ; pi2 = 2.d0*PI

  !++++++++++++++++++++++++++++++++++++++++++++++
  allocate(drphi_tmp(nmesh)) ; drphi_tmp = 0.d0
  !++++++++++++++++++++++++++++++++++++++++++++++

  iord_tmp = 5

! ---------------------------------- kinetic ---------------------------
  ekin_sum1_sol = 0.d0
  do ips = 1,nps
     ishell = ishell_ps(ips,1)
     if (is_solve(ishell) == 0) then
        cycle
     end if
     ll = l_qnum(ishell)
     call calc_diff_exp(ier,iord_tmp,nmesh,rpos, &
          rphi_sol(1,ips),drphi_tmp)
     do ir = 1,nmesh
        r = rpos(ir)
        ekin_sum1_sol = ekin_sum1_sol + focc_sol(ips) &
             * 0.5d0*wr(ir) &
             *( drphi_tmp(ir)**2 &
             + dble(ll*(ll+1))*(rphi_sol(ir,ips)/r)**2 )
     end do
  end do

  !++++++++++++++++++++++
  deallocate(drphi_tmp)
  !++++++++++++++++++++++

! ------------------------------------ band ----------------------------
  eband_sum_sol = 0.d0
  do ips = 1,nps
     ishell = ishell_ps(ips,1)
     if (is_solve(ishell) /= 0) then
        eband_sum_sol = eband_sum_sol + focc_sol(ips) * engy_sol(ips)
     end if
  end do

! -------------------------------------- local ion ----------------
  eloc_ion_sum_sol = 0.d0
  Do ispin=1, nspin
     do ir = 1,nmesh
        r = rpos(ir)
        eloc_ion_sum_sol = eloc_ion_sum_sol &
             + pi4*r*r*wr(ir)*rho_sol(ir,ispin)*vloc_ion_sol(ir,ispin)
     end do
  End do

! ------------------------------- nonlocal ion -----------------
  enl_ion_sum_sol = 0.d0
  do ips = 1,nps
     ishell = ishell_ps(ips,1)

     if (is_solve(ishell) == 0) then
        cycle
     end if

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

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

     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)
           ltt = ltt_nm_us(ll,itmp1,itmp2)

           enl_ion_sum_sol = enl_ion_sum_sol &
                + focc_sol(ips) * dion_us(ltt) &
                * beta_phi_sol(lt1,ips) &
                * beta_phi_sol(lt2,ips)

        end do
     end do
  end do

! -------------------------------------------------------
  vlocqps_sum_sol = 0.d0
  do ips = 1,nps
     ishell = ishell_ps(ips,1)

     if (is_solve(ishell) == 0) then
        cycle
     end if

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

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

     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)
           ltt = ltt_nm_us(ll,itmp1,itmp2)

           vlocqps_sum_sol = vlocqps_sum_sol &
                + focc_sol(ips) * vlocqps_us(ltt) &
                * beta_phi_sol(lt1,ips) &
                * beta_phi_sol(lt2,ips)
        end do
     end do
  end do

! ---------------------------------------- hartree ----------------
  eh_sum_sol = 0.d0
  Do ispin=1, nspin
     do ir = 1,nmesh
        r = rpos(ir)
        eh_sum_sol = eh_sum_sol &
             + pi2*r*r*wr(ir)*rho_sol(ir,ispin)*vh_sol(ir)
     end do
  End do

! ---------------------------------------------EXC ------------------
  select case (is_xc)

  case (LDAPW92_GNCPP, GGAPW91_F90, GGAPW91_F77, &
       GGAPBE96_GNCPP, GGAPBE96_KATO, &
       GGAPBE96_MOMO2)

  case default
     ex_sum_sol   = 0.d0
     ec_sum_sol   = 0.d0
     expc_sum_sol = 0.d0
     ecpc_sum_sol = 0.d0

     select case (is_pcc)

     case (NONE)

        Do ispin=1, nspin
           do ir = 1,nmesh
              r = rpos(ir)
              ex_sum_sol = ex_sum_sol &
                   + pi4*r*r*wr(ir)*rho_sol(ir,ispin)*ex_sol(ir)
              ec_sum_sol = ec_sum_sol &
                   + pi4*r*r*wr(ir)*rho_sol(ir,ispin)*ec_sol(ir)
           end do
        End do

     case (PCC,FCC)

        Do ispin=1, nspin
           do ir = 1,nmesh
              r = rpos(ir)

              rho_tmp = rho_sol(ir,ispin) + rho_pcore(ir) /dble(nspin)
              ex_sum_sol = ex_sum_sol &
                   + pi4*r*r*wr(ir) *rho_tmp *ex_sol(ir)
              ec_sum_sol = ec_sum_sol &
                   + pi4*r*r*wr(ir) *rho_tmp *ec_sol(ir)

              rho_tmp = rho_pcore(ir) /dble(nspin)
              expc_sum_sol = expc_sum_sol &
                   - pi4*r*r*wr(ir) *rho_tmp *expc_sol(ir)
              ecpc_sum_sol = ecpc_sum_sol &
                   - pi4*r*r*wr(ir) *rho_tmp *ecpc_sol(ir)
           end do
        End do

     end select
  end select

  exc_sum_sol   = ex_sum_sol + ec_sum_sol
  excpc_sum_sol = expc_sum_sol + ecpc_sum_sol

! ---------------------------------------------VXC ------------------
  vx_sum_sol = 0.d0
  vc_sum_sol = 0.d0

  Do ispin=1, nspin
     do ir = 1,nmesh
        r = rpos(ir)
        vx_sum_sol = vx_sum_sol &
             + pi4*r*r*wr(ir)*rho_sol(ir,ispin)*vx_sol(ir,ispin)
        vc_sum_sol = vc_sum_sol &
             + pi4*r*r*wr(ir)*rho_sol(ir,ispin)*vc_sol(ir,ispin)
     end do
  End Do

! ------------------------------------------------- summation ----
  vxc_sum_sol = vx_sum_sol + vc_sum_sol

  eion_sum_sol  = eloc_ion_sum_sol + enl_ion_sum_sol
  etot_sum1_sol = ekin_sum1_sol + eion_sum_sol  &
       + eh_sum_sol + exc_sum_sol + excpc_sum_sol
  etot_sum2_sol = eband_sum_sol - eh_sum_sol  &
       + exc_sum_sol - vxc_sum_sol + excpc_sum_sol
  etot_sum_sol  = etot_sum2_sol
  etot_sol      = etot_sum_sol
  ekin_sum2_sol = eband_sum_sol - eion_sum_sol - 2.d0*eh_sum_sol &
       - vxc_sum_sol
  ekin_sum_sol  = ekin_sum2_sol

end subroutine calc_etot_sol_kt
! ============================================================================= 4.0

!=====================================================================
   subroutine calc_etot_ss(ier)
!=====================================================================
!
!  M. Okamoto
!
!---------------------------------------------------------------------
   use parameters
   implicit none
   integer,intent(out) :: ier
   integer :: ir, ishell, ll, t1, t2, ltt, &
              iord_tmp, lt1, lt2, nref, iss, ispin
   real(8) :: r, pi4, pi2, rho_tmp
   real(8),allocatable :: drphi_tmp(:)
   ier    =  0
   pi4 = 4.d0*PI ; pi2 = 2.d0*PI
  !++++++++++++++++++++++++++++++++++++++++++++++
   allocate(drphi_tmp(nmesh)) ; drphi_tmp = 0.d0
  !++++++++++++++++++++++++++++++++++++++++++++++
   iord_tmp = 5
   ekin_sum1_ss = 0.d0
   do iss = 1,nss
      ishell = ishell_ss(iss)
      if (is_solve_ss(iss) == 0) then
         cycle
      end if
      ll = l_qnum(ishell)
      call calc_diff_exp(ier,iord_tmp,nmesh,rpos, &
                         rphi_ss(1,iss),drphi_tmp)
      do ir = 1,nmesh
         r = rpos(ir)
         ekin_sum1_ss = ekin_sum1_ss + focc_ss(iss) &
         * 0.5d0*wr(ir) &
         *( drphi_tmp(ir)**2 &
            + dble(ll*(ll+1))*(rphi_ss(ir,iss)/r)**2 )
      end do
   end do
  !++++++++++++++++++++++
   deallocate(drphi_tmp)
  !++++++++++++++++++++++
   eband_sum_ss = 0.d0
   do iss = 1,nss
      if (is_solve_ss(iss) /= 0) then
         eband_sum_ss = eband_sum_ss + focc_ss(iss) * engy_ss(iss)
      end if
   end do
   eloc_ion_sum_ss = 0.d0
   do ispin = 1,nspin_ss
   do ir = 1,nmesh
      r = rpos(ir)
      eloc_ion_sum_ss = eloc_ion_sum_ss &
! ============================================== modified by K. T. ========= 4.0
!         + pi4*r*r*wr(ir)*rho_ss(ir,ispin)*vloc_ion_sol(ir)
         + pi4*r*r*wr(ir)*rho_ss(ir,ispin)*vloc_ion_sol(ir,1)
! ========================================================================== 4.0
   end do
   end do
   enl_ion_sum_ss = 0.d0
   do iss = 1,nss
      ishell = ishell_ss(iss)
      if (is_solve_ss(iss) == 0) then
         cycle
      end if
      ll = l_qnum(ishell)
      nref = nref_us(ll)
      do t1 = 1,nref
      do t2 = 1,nref
         lt1 = lt_n_us(ll,t1)
         lt2 = lt_n_us(ll,t2)
         ltt = ltt_nm_us(ll,t1,t2)
         enl_ion_sum_ss = enl_ion_sum_ss &
            + focc_ss(iss) * dion_us(ltt) &
               * beta_phi_ss(lt1,iss) &
               * beta_phi_ss(lt2,iss)
      end do
      end do
   end do
   vlocqps_sum_ss = 0.d0
   do iss = 1,nss
      ispin = (1-spin_ss(iss))/2 + 1
      ishell = ishell_ss(iss)
      if (is_solve_ss(iss) == 0) then
         cycle
      end if
      ll = l_qnum(ishell)
      nref = nref_us(ll)
      do t1 = 1,nref
      do t2 = 1,nref
         lt1 = lt_n_us(ll,t1)
         lt2 = lt_n_us(ll,t2)
         ltt = ltt_nm_us(ll,t1,t2)
         vlocqps_sum_ss = vlocqps_sum_ss &
            + focc_ss(iss) * vlocqps_ss(ltt,ispin) &
               * beta_phi_ss(lt1,iss) &
               * beta_phi_ss(lt2,iss)
      end do
      end do
   end do
   eh_sum_ss = 0.d0
   do ispin = 1,nspin_ss
   do ir = 1,nmesh
      r = rpos(ir)
      eh_sum_ss = eh_sum_ss &
             + pi2*r*r*wr(ir)*rho_ss(ir,ispin)*vh_ss(ir)
   end do
   end do
   select case (is_xc)
   case (LDAPW92_GNCPP, GGAPW91_F90, GGAPW91_F77, &
         GGAPBE96_GNCPP, GGAPBE96_KATO, &
         GGAPBE96_MOMO2)
   case default
      ex_sum_ss   = 0.d0
      ec_sum_ss   = 0.d0
      expc_sum_ss = 0.d0
      ecpc_sum_ss = 0.d0
      select case (is_pcc)
      case (NONE)
         do ispin = 1,nspin_ss
         do ir = 1,nmesh
            r = rpos(ir)
            ex_sum_ss = ex_sum_ss &
               + pi4*r*r*wr(ir)*rho_ss(ir,ispin)*ex_ss(ir)
            ec_sum_ss = ec_sum_ss &
               + pi4*r*r*wr(ir)*rho_ss(ir,ispin)*ec_ss(ir)
         end do
         end do
      case (PCC,FCC)
         do ispin = 1,nspin_ss
         do ir = 1,nmesh
            r = rpos(ir)
            rho_tmp = rho_ss(ir,ispin)+rho_pcore(ir)/dble(nspin_ss)
            ex_sum_ss = ex_sum_ss &
               + pi4*r*r*wr(ir)*rho_tmp*ex_ss(ir)
            ec_sum_ss = ec_sum_ss &
               + pi4*r*r*wr(ir)*rho_tmp*ec_ss(ir)
            rho_tmp = rho_pcore(ir)/dble(nspin_ss)
            expc_sum_ss = expc_sum_ss &
               - pi4*r*r*wr(ir)*rho_tmp*expc_ss(ir)
            ecpc_sum_ss = ecpc_sum_ss &
               - pi4*r*r*wr(ir)*rho_tmp*ecpc_ss(ir)
         end do
         end do
      end select
   end select
   exc_sum_ss   = ex_sum_ss + ec_sum_ss
   excpc_sum_ss = expc_sum_ss + ecpc_sum_ss
   vx_sum_ss = 0.d0
   vc_sum_ss = 0.d0
   do ispin = 1,nspin_ss
   do ir = 1,nmesh
      r = rpos(ir)
      vx_sum_ss = vx_sum_ss &
         + pi4*r*r*wr(ir)*rho_ss(ir,ispin)*vx_ss(ir,ispin)
      vc_sum_ss = vc_sum_ss &
         + pi4*r*r*wr(ir)*rho_ss(ir,ispin)*vc_ss(ir,ispin)
   end do
   end do
   vxc_sum_ss = vx_sum_ss + vc_sum_ss
   eion_sum_ss  = eloc_ion_sum_ss + enl_ion_sum_ss
   etot_sum1_ss = ekin_sum1_ss + eion_sum_ss  &
                + eh_sum_ss + exc_sum_ss + excpc_sum_ss
   etot_sum2_ss = eband_sum_ss - eh_sum_ss  &
                + exc_sum_ss - vxc_sum_ss + excpc_sum_ss
   etot_sum_ss  = etot_sum2_ss
   etot_ss      = etot_sum_ss
   ekin_sum2_ss = eband_sum_ss - eion_sum_ss - 2.d0*eh_sum_ss &
                - vxc_sum_ss
   ekin_sum_ss  = ekin_sum2_ss
   end subroutine calc_etot_ss

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

  integer,intent(out) :: ier
  integer :: ir, ishell, ll, t1, t2, ltt, &
       iord_tmp, lt1, lt2, nref, iss, ispin
  real(8) :: r, pi4, pi2, rho_tmp
  real(8),allocatable :: drphi_tmp(:)

  integer :: ispin_ps, itmp1, itmp2

  ier    =  0
  pi4 = 4.d0*PI ; pi2 = 2.d0*PI

  !++++++++++++++++++++++++++++++++++++++++++++++
  allocate(drphi_tmp(nmesh)) ; drphi_tmp = 0.d0
  !++++++++++++++++++++++++++++++++++++++++++++++
  iord_tmp = 5

! ----------------------------------- kinetic ------------------------
  ekin_sum1_ss = 0.d0
  do iss = 1,nss
     ishell = ishell_ss(iss)
     if (is_solve_ss(iss) == 0) then
        cycle
     end if
     ll = l_qnum(ishell)
     call calc_diff_exp(ier,iord_tmp,nmesh,rpos, &
          rphi_ss(1,iss),drphi_tmp)
     do ir = 1,nmesh
        r = rpos(ir)
        ekin_sum1_ss = ekin_sum1_ss + focc_ss(iss) &
             * 0.5d0*wr(ir) &
             *( drphi_tmp(ir)**2 &
             + dble(ll*(ll+1))*(rphi_ss(ir,iss)/r)**2 )
     end do
  end do
  !++++++++++++++++++++++
  deallocate(drphi_tmp)
  !++++++++++++++++++++++

! ---------------------------------------- band ------------------------
  eband_sum_ss = 0.d0
  do iss = 1,nss
     if (is_solve_ss(iss) /= 0) then
        eband_sum_ss = eband_sum_ss + focc_ss(iss) * engy_ss(iss)
     end if
  end do

! ---------------------------------------- local ion ------------------------
  eloc_ion_sum_ss = 0.d0

  if ( nspin == 1 ) then
     do ispin = 1,nspin_ss
        do ir = 1,nmesh
           r = rpos(ir)
           eloc_ion_sum_ss = eloc_ion_sum_ss &
                + pi4*r*r*wr(ir)*rho_ss(ir,ispin)*vloc_ion_sol(ir,1)
        end do
     end do
  else if ( nspin == 2 ) then
     do ispin = 1,nspin_ss

        ispin_ps = ispin

        do ir = 1,nmesh
           r = rpos(ir)
           eloc_ion_sum_ss = eloc_ion_sum_ss &
                + pi4*r*r*wr(ir)*rho_ss(ir,ispin)*vloc_ion_sol(ir,ispin_ps)
        end do
     end do
  endif

! ----------------------------------------- nonlcoal ion ---------
  enl_ion_sum_ss = 0.d0
  do iss = 1,nss

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

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

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

!     write(*,*) 'ispin nspin =', ispin, nspin

     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)
           ltt = ltt_nm_us(ll,itmp1,itmp2)

           enl_ion_sum_ss = enl_ion_sum_ss &
                + focc_ss(iss) * dion_us(ltt) &
                * beta_phi_ss(lt1,iss) &
                * beta_phi_ss(lt2,iss)
        end do
     end do
  end do

! ---------------------------------------------------------------------
  vlocqps_sum_ss = 0.d0

  do iss = 1,nss
     ispin = (1-spin_ss(iss))/2 + 1
     ishell = ishell_ss(iss)
     
     if (is_solve_ss(iss) == 0) then
        cycle
     end if
     
     ll = l_qnum(ishell)
     nref = nref_us(ll)
     
     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)
           ltt = ltt_nm_us(ll,itmp1,itmp2)
           
           vlocqps_sum_ss = vlocqps_sum_ss &
                + focc_ss(iss) * vlocqps_ss(ltt,ispin) &
                * beta_phi_ss(lt1,iss) &
                * beta_phi_ss(lt2,iss)
        end do
     end do
  end do

! -------------------------------- Hartree ----------------------
  eh_sum_ss = 0.d0
  do ispin = 1,nspin_ss
     do ir = 1,nmesh
        r = rpos(ir)
        eh_sum_ss = eh_sum_ss &
             + pi2*r*r*wr(ir)*rho_ss(ir,ispin)*vh_ss(ir)
     end do
  end do

! ---------------------------------- EXC --------------------------
  select case (is_xc)

  case (LDAPW92_GNCPP, GGAPW91_F90, GGAPW91_F77, &
       GGAPBE96_GNCPP, GGAPBE96_KATO, &
       GGAPBE96_MOMO2)

  case default
     ex_sum_ss   = 0.d0
     ec_sum_ss   = 0.d0
     expc_sum_ss = 0.d0
     ecpc_sum_ss = 0.d0

     select case (is_pcc)

     case (NONE)
        do ispin = 1,nspin_ss
           do ir = 1,nmesh
              r = rpos(ir)
              ex_sum_ss = ex_sum_ss &
                   + pi4*r*r*wr(ir)*rho_ss(ir,ispin)*ex_ss(ir)
              ec_sum_ss = ec_sum_ss &
                   + pi4*r*r*wr(ir)*rho_ss(ir,ispin)*ec_ss(ir)
           end do
        end do

     case (PCC,FCC)
        do ispin = 1,nspin_ss
           do ir = 1,nmesh
              r = rpos(ir)
              rho_tmp = rho_ss(ir,ispin)+rho_pcore(ir)/dble(nspin_ss)
              ex_sum_ss = ex_sum_ss &
                   + pi4*r*r*wr(ir)*rho_tmp*ex_ss(ir)
              ec_sum_ss = ec_sum_ss &
                   + pi4*r*r*wr(ir)*rho_tmp*ec_ss(ir)
              rho_tmp = rho_pcore(ir)/dble(nspin_ss)
              expc_sum_ss = expc_sum_ss &
                   - pi4*r*r*wr(ir)*rho_tmp*expc_ss(ir)
              ecpc_sum_ss = ecpc_sum_ss &
                   - pi4*r*r*wr(ir)*rho_tmp*ecpc_ss(ir)
           end do
        end do
     end select
  end select

  exc_sum_ss   = ex_sum_ss + ec_sum_ss
  excpc_sum_ss = expc_sum_ss + ecpc_sum_ss

! --------------------------------------- VXC ---------------------------------
  vx_sum_ss = 0.d0
  vc_sum_ss = 0.d0

  do ispin = 1,nspin_ss
     do ir = 1,nmesh
        r = rpos(ir)
        vx_sum_ss = vx_sum_ss &
             + pi4*r*r*wr(ir)*rho_ss(ir,ispin)*vx_ss(ir,ispin)
        vc_sum_ss = vc_sum_ss &
             + pi4*r*r*wr(ir)*rho_ss(ir,ispin)*vc_ss(ir,ispin)
     end do
  end do

! -------------------------------------- summation ----------------------
  vxc_sum_ss = vx_sum_ss + vc_sum_ss
  eion_sum_ss  = eloc_ion_sum_ss + enl_ion_sum_ss
  etot_sum1_ss = ekin_sum1_ss + eion_sum_ss  &
       + eh_sum_ss + exc_sum_ss + excpc_sum_ss
  etot_sum2_ss = eband_sum_ss - eh_sum_ss  &
       + exc_sum_ss - vxc_sum_ss + excpc_sum_ss
  etot_sum_ss  = etot_sum2_ss
  etot_ss      = etot_sum_ss
  ekin_sum2_ss = eband_sum_ss - eion_sum_ss - 2.d0*eh_sum_ss &
       - vxc_sum_ss
  ekin_sum_ss  = ekin_sum2_ss

end subroutine calc_etot_ss_kt
! =========================================================================== 4.0

!=====================================================================
   subroutine write_etot_sol(ifile)
!=====================================================================
!
!  M. Okamoto
!
!---------------------------------------------------------------------
   use parameters
   implicit none
   integer,intent(in) :: ifile
   integer        :: i
   character(100) :: line
   do i = 1,100
      line(i:i) = '-'
   end do
   write(ifile,*)
   write(ifile,*)  'etot  Total energy for the present PP [Solved]'
   write(ifile,10) line(1:100)
   write(ifile,11) 'Energy (Ha)','Energy (eV)'
   write(ifile,10) line(1:100)
   write(ifile,20) 'Ekin     ',ekin_sum1_sol   ,ekin_sum1_sol   *HARTREE
   write(ifile,20) 'Eion[NL] ',enl_ion_sum_sol ,enl_ion_sum_sol *HARTREE
   write(ifile,20) 'Eion[LOC]',eloc_ion_sum_sol,eloc_ion_sum_sol*HARTREE
   write(ifile,20) 'Eh       ',eh_sum_sol      ,eh_sum_sol      *HARTREE
   write(ifile,20) 'Exc      ',exc_sum_sol     ,exc_sum_sol     *HARTREE
   write(ifile,20) 'Epcc     ',excpc_sum_sol   ,excpc_sum_sol   *HARTREE
   write(ifile,10) line(1:100)
   write(ifile,20) 'Ekin*    ',ekin_sum2_sol   ,ekin_sum2_sol   *HARTREE
   write(ifile,20) 'Eion     ',eion_sum_sol    ,eion_sum_sol    *HARTREE
   write(ifile,20) 'VlocQps  ',vlocqps_sum_sol ,vlocqps_sum_sol *HARTREE
   write(ifile,20) 'Ex       ',ex_sum_sol      ,ex_sum_sol      *HARTREE
   write(ifile,20) 'Ec       ',ec_sum_sol      ,ec_sum_sol      *HARTREE
   write(ifile,20) 'Vx       ',vx_sum_sol      ,vx_sum_sol      *HARTREE
   write(ifile,20) 'Vc       ',vc_sum_sol      ,vc_sum_sol      *HARTREE
   write(ifile,20) 'Vxc      ',vxc_sum_sol     ,vxc_sum_sol     *HARTREE
   write(ifile,20) 'Eband    ',eband_sum_sol   ,eband_sum_sol   *HARTREE
   write(ifile,10) line(1:100)
   write(ifile,20) 'Etot     ',etot_sum1_sol   ,etot_sum1_sol   *HARTREE
   write(ifile,20) 'Etot*    ',etot_sum2_sol   ,etot_sum2_sol   *HARTREE
   write(ifile,10) line(1:100)
   write(ifile,*)  'etot  Ekin* = Eband - Eion - 2Eh - Vxc'
   write(ifile,*)  'etot  Eion  = Eion[NL] + Eion[LOC]'
   write(ifile,*)  'etot  Etot  = Ekin + Eion + Eh + Exc + Epcc'
   write(ifile,*)  'etot  Etot* = Eband - Eh + Exc - Vxc + Epcc'
10 format(1x,'etot',a53)
11 format(1x,'etot',2x,9x,2(9x,a11))
20 format(1x,'etot',2x,a9,2(f20.10))
   end subroutine write_etot_sol

!=====================================================================
   subroutine write_etot_ss(ifile)
!=====================================================================
!
!  M. Okamoto
!
!---------------------------------------------------------------------
   use parameters
   implicit none
   integer,intent(in) :: ifile
   integer        :: i
   character(100) :: line
   do i = 1,100
      line(i:i) = '-'
   end do
   write(ifile,*)
   write(ifile,*)  'etot  Total energy for the present PP [Solved]'
   write(ifile,10) line(1:100)
   write(ifile,11) 'Energy (Ha)','Energy (eV)'
   write(ifile,10) line(1:100)
   write(ifile,20) 'Ekin     ',ekin_sum1_ss   ,ekin_sum1_ss   *HARTREE
   write(ifile,20) 'Eion[NL] ',enl_ion_sum_ss ,enl_ion_sum_ss *HARTREE
   write(ifile,20) 'Eion[LOC]',eloc_ion_sum_ss,eloc_ion_sum_ss*HARTREE
   write(ifile,20) 'Eh       ',eh_sum_ss      ,eh_sum_ss      *HARTREE
   write(ifile,20) 'Exc      ',exc_sum_ss     ,exc_sum_ss     *HARTREE
   write(ifile,20) 'Epcc     ',excpc_sum_ss   ,excpc_sum_ss   *HARTREE
   write(ifile,10) line(1:100)
   write(ifile,20) 'Ekin*    ',ekin_sum2_ss   ,ekin_sum2_ss   *HARTREE
   write(ifile,20) 'Eion     ',eion_sum_ss    ,eion_sum_ss    *HARTREE
   write(ifile,20) 'VlocQps  ',vlocqps_sum_ss ,vlocqps_sum_ss *HARTREE
   write(ifile,20) 'Ex       ',ex_sum_ss      ,ex_sum_ss      *HARTREE
   write(ifile,20) 'Ec       ',ec_sum_ss      ,ec_sum_ss      *HARTREE
   write(ifile,20) 'Vx       ',vx_sum_ss      ,vx_sum_ss      *HARTREE
   write(ifile,20) 'Vc       ',vc_sum_ss      ,vc_sum_ss      *HARTREE
   write(ifile,20) 'Vxc      ',vxc_sum_ss     ,vxc_sum_ss     *HARTREE
   write(ifile,20) 'Eband    ',eband_sum_ss   ,eband_sum_ss   *HARTREE
   write(ifile,10) line(1:100)
   write(ifile,20) 'Etot     ',etot_sum1_ss   ,etot_sum1_ss   *HARTREE
   write(ifile,20) 'Etot*    ',etot_sum2_ss   ,etot_sum2_ss   *HARTREE
   write(ifile,10) line(1:100)
   write(ifile,*)  'etot  Ekin* = Eband - Eion - 2Eh - Vxc'
   write(ifile,*)  'etot  Eion  = Eion[NL] + Eion[LOC]'
   write(ifile,*)  'etot  Etot  = Ekin + Eion + Eh + Exc + Epcc'
   write(ifile,*)  'etot  Etot* = Eband - Eh + Exc - Vxc + Epcc'
10 format(1x,'etot',a53)
11 format(1x,'etot',2x,9x,2(9x,a11))
20 format(1x,'etot',2x,a9,2(f20.10))
   end subroutine write_etot_ss
