! ************************************************************* 
!
!   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_bound_state_loc, calc_bound_state_nonscf_sol
!                : calc_bound_state_ss, set_initpoints_right_sol
!                : int_from_right_sol, guess_de_sol, calc_beta_phi_sol
!                : calc_beta_phi_ss, set_initpoints_left_sol
!                : int_from_left_sol, pc_adams_5_sol
!                : write_energy_level_sol, write_energy_level_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_bound_state_loc(ier,IFLOG, &
                 iord_pc,iord_nec,iord_diff,dx,eps_de, &
                 nmesh,rpos,wr,vloc_scr,ll,node,ee_solved,is_solved)
!=====================================================================
!
!  M. Okamoto
!
!---------------------------------------------------------------------
   implicit none
   integer,intent(in)  :: IFLOG, iord_pc, iord_nec, iord_diff, &
                          nmesh, ll, node
   real(8),intent(in)  :: rpos(nmesh), wr(nmesh), vloc_scr(nmesh), &
                          dx, eps_de
   integer,intent(out) :: ier, is_solved
   real(8),intent(out) :: ee_solved
   real(8),allocatable :: bsum(:), rphi(:), wt(:), &
                          chi_gl(:), chi_fl(:), &
                          dxchi_gl(:), dxchi_fl(:), &
                          chi_gr(:), chi_fr(:), &
                          dxchi_gr(:), dxchi_fr(:)
   real(8),parameter   :: ARGMAX = 150.d0
   integer :: ir, node_sum, nmesh_max, loop, max_loop, &
              nrm, nrt, num_eslides, max_eslides, lguess
   real(8) :: vloc_min, ee, de, r, vv, ss, rr, fguess, gg_norm, &
              sign_gr, ee_upper_limit, ee_lower_limit,      &
              ee_upper_limit_in, engy_minimum, sum, etest, tmp
   ier = 0
  !++++++++++++++++++++++++++++++++++++++++++++++++++++++++++++++++++
   allocate(bsum(nmesh),rphi(nmesh),wt(nmesh), &
      chi_gl(nmesh),chi_fl(nmesh),dxchi_gl(nmesh),dxchi_fl(nmesh), &
      chi_gr(nmesh),chi_fr(nmesh),dxchi_gr(nmesh),dxchi_fr(nmesh))
      bsum = 0.d0 ; rphi = 0.d0 ; wt = 0.d0
      chi_gl   = 0.d0 ; chi_fl   = 0.d0
      dxchi_gl = 0.d0 ; dxchi_fl = 0.d0
      chi_gr   = 0.d0 ; chi_fr   = 0.d0
      dxchi_gr = 0.d0 ; dxchi_fr = 0.d0
  !++++++++++++++++++++++++++++++++++++++++++++++++++++++++++++++++++
   max_eslides  =  25
   max_loop     = 100
   engy_minimum = 1.d-4
   ee_solved    = 0.d0
   rphi(:)      = 0.d0
   is_solved    = 1
   write(IFLOG,*) 'SOL-LOC: ll,node ...',ll,node
   fguess = 1.d0
   lguess = 1
   node_sum = node
   if (mod(node,2) == 0) then
      sign_gr = +1.d0
   else
      sign_gr = -1.d0
   end if
   num_eslides = 0
      write(IFLOG,'(1x,a20,2i5)') &
         'SOL-LOC: ll,node ...',ll,node
   ee = ee_solved
   nmesh_max = nmesh
   do ir = nmesh,10,-1
      r  = rpos(ir)
      vv = vloc_scr(ir)
      ss = sqrt(2.d0*abs(ee-vv))
      if (ss*r < ARGMAX) then
         nmesh_max = ir ; exit
      end if
   end do
   vloc_min = 0.d0
   do ir = 1,nmesh
      r  = rpos(ir)
      vv = vloc_scr(ir)
      if (vv < vloc_min) then
         vloc_min = vv
      end if
   end do
   ee_upper_limit = vloc_scr(nmesh_max) - engy_minimum
   if (ee_upper_limit > -engy_minimum) then
      ee_upper_limit = -engy_minimum
   end if
   ee_upper_limit_in = ee_upper_limit
   ee_lower_limit = vloc_min
   ee = 0.5d0*(ee_upper_limit + ee_lower_limit)
   de = ee
   loop = 0
SRCH_EE:do while (abs(de) > eps_de)
   loop = loop + 1
   if (loop > max_loop) then
      if (lguess < 3) then
         lguess = lguess + 1
         fguess = fguess * 0.5d0
         max_loop = max_loop * 2
         loop = 0
         node_sum = node
         cycle SRCH_EE
      end if
      if (node_sum < node) then
         write(IFLOG,*) '### CAUTION ### node_sum < node'
         write(IFLOG,*) '   node_sum,node ...',node_sum,node
         write(IFLOG,*) &
            '   Following state may be an unbound state.'
         write(IFLOG,*) '      ll ...',ll
         is_solved = 0 ; ee = 0.d0 ; exit SRCH_EE
      else
         write(IFLOG,*) '### ERROR ### loop > max_loop'
         write(IFLOG,*) '   loop, max_loop ...',loop,max_loop
         write(IFLOG,*) '   ll,node        ...',ll,node
         write(IFLOG,*) '   node_sum,node  ...',node_sum,node
         write(IFLOG,*) '   ee_upper_limit ...',ee_upper_limit
         write(IFLOG,*) '   ee_lower_limit ...',ee_lower_limit
         write(IFLOG,*) '   ee             ...',ee
         write(IFLOG,*) '   de             ...',de
         ier=1 ; go to 99
      end if
   end if
   if (num_eslides > max_eslides) then
      write(IFLOG,*) '### CAUTION ### Eigenvalue was not converged !'
      write(IFLOG,*) '      num_eslides  ...',num_eslides
      write(IFLOG,*) '      max_eslides  ...',max_eslides
      write(IFLOG,*) '   Following state may be an unbound state.'
      write(IFLOG,*) '      ll           ...',ll
      is_solved = 0 ; ee = 0.d0 ; exit SRCH_EE
   end if
SRCH_RT:do ir = nmesh_max,10,-1
      r = rpos(ir)
      tmp = vloc_scr(ir)-ee
      if (tmp < 0.d0) then
         nrt = ir ; exit SRCH_RT
      end if
   end do SRCH_RT
   bsum = 0.d0
   call set_initpoints_left_sol(ier,nmesh,ll,ee,rpos, &
           chi_gl,chi_fl,dxchi_gl,dxchi_fl,vloc_scr,bsum)
   call int_from_left_sol(ier,nmesh,node_sum,nrt, &
           ll,ee,iord_nec,dx,rpos, &
           chi_gl,chi_fl,dxchi_gl,dxchi_fl,vloc_scr,bsum)
   if (ier /= 0) then
      write(IFLOG,*) '### ERROR ### in int_from_left_sol'
      go to 99
   end if
   do ir = 1,nrt
      r = rpos(ir)
      chi_fl(ir) = dxchi_gl(ir)/r - dble(ll+1)/r*chi_gl(ir)
   end do
   if (node_sum > node) then
      if (ee < ee_upper_limit) then
         ee_upper_limit = ee
      end if
      if (ee_upper_limit > ee_upper_limit_in) then
         ee_upper_limit = ee_upper_limit_in
      end if
      ee = 0.5d0*(ee + ee_lower_limit)
      ee_lower_limit = ee_lower_limit * 1.2d0
      cycle SRCH_EE
   else if (node_sum < node) then
      if (ee > ee_lower_limit) then
         ee_lower_limit = ee
      end if
      ee = 0.5d0*(ee_upper_limit + ee)
      ee_upper_limit = ee_upper_limit_in
      ee = 0.5d0*(ee_upper_limit + ee)
      cycle SRCH_EE
   end if
      nrm = nrt
SRCH_RM:do ir = nrt,10,-1
      if (sign_gr*(chi_gl(ir-1)-chi_gl(ir)) < 0.d0) then
         nrm = ir ; exit SRCH_RM
      end if
   end do SRCH_RM
   nmesh_max = nmesh
   do ir = nmesh,10,-1
      r  = rpos(ir)
      vv = vloc_scr(ir)
      ss = sqrt(2.d0*abs(ee-vv))
      if (ss*r < ARGMAX) then
         nmesh_max = ir ; exit
      end if
   end do
   if (nmesh_max < nmesh) then
      r  = rpos(nmesh_max)
      vv = vloc_scr(nmesh_max)
      ss = sqrt(2.d0*abs(ee-vv))
      do ir = nmesh_max+1,nmesh
         r  = rpos(ir)
         vv = vloc_scr(ir)
         ss = sqrt(2.d0*abs(ee-vv))
         chi_gr(ir) = exp(-ss*r) * sign_gr
         chi_fr(ir) = -ss * chi_gr(ir) 
         dxchi_gr(ir) = 0.d0
         dxchi_fr(ir) = 0.d0
      end do
   end if
   call set_initpoints_right_sol(ier,nmesh,nmesh_max,ll,ee,rpos, &
           chi_gr,chi_fr,dxchi_gr,dxchi_fr,vloc_scr,bsum,sign_gr)
   if (ier /= 0) then
      write(IFLOG,*) '### ERROR ### in set_initpoints_right_sol'
      go to 99
   end if
   nrt = nrm - 1 - max(iord_pc,iord_diff)
   call int_from_right_sol(ier,nmesh,nmesh_max,nrt, &
           ll,ee,iord_nec,dx,rpos, &
           chi_gr,chi_fr,dxchi_gr,dxchi_fr,vloc_scr,bsum)
   if (ier /= 0) then
      write(IFLOG,*) '### ERROR ### in int_from_right_sol'
      go to 99
   end if
   rr = chi_gl(nrm) / chi_gr(nrm)
   do ir = nmesh,nrt,-1
        chi_gr(ir) =   chi_gr(ir) * rr
        chi_fr(ir) =   chi_fr(ir) * rr
      dxchi_gr(ir) = dxchi_gr(ir) * rr
      dxchi_fr(ir) = dxchi_fr(ir) * rr
   end do
   call guess_de_sol(ier,IFLOG,nmesh,nrm,rpos,wt, &
           chi_gl,chi_fl,chi_gr,chi_fr,de,fguess,gg_norm)
   if (ier /= 0) then
      write(IFLOG,*) '### ERROR ### in guess_de' ; go to 99
   end if
   if (de > 0.d0) then
      ee_lower_limit = ee
   else if (de < 0.d0) then
      ee_upper_limit = ee
      if (ee_upper_limit > ee_upper_limit_in) then
         ee_upper_limit = ee_upper_limit_in
      end if
   end if
   etest = ee + de
   if ((etest-ee_upper_limit)*(etest-ee_lower_limit) < 0.d0) then
      ee = etest
   else
      ee = 0.5d0*(ee_upper_limit + ee_lower_limit)
      num_eslides = num_eslides + 1
   end if
      write(IFLOG,'(1x,a25,i5,f25.15,1pe20.10)') &
        '### SLOC ### ll,ee,de ...',ll,ee,de
end do SRCH_EE
   if (is_solved /= 0) then
      ee_solved = ee
   else
      ee_solved = 0.d0
   end if
   if (is_solved /= 0) then
      do ir = 1,nrm
         rphi(ir) = chi_gl(ir)
      end do
      do ir = nrm,nmesh
         rphi(ir) = chi_gr(ir)
      end do
   else
      rphi(:) = 0.d0
   end if
   if (is_solved /= 0) then
      sum = 0.d0
      do ir = 1,nmesh
         sum = sum + rphi(ir)**2*wr(ir)
      end do
      rphi(:) = rphi(:)/sqrt(sum)*sign_gr
   end if
   do ir = 1,nmesh
      if (abs(rphi(ir)) < 1.d-99) then
         rphi(ir) = 0.d0
      end if
   end do
99 continue
  !++++++++++++++++++++++++++++++++++++++
   deallocate(bsum,rphi,wt, &
      chi_gl,chi_fl,dxchi_gl,dxchi_fl, &
      chi_gr,chi_fr,dxchi_gr,dxchi_fr)
  !++++++++++++++++++++++++++++++++++++++
   end subroutine calc_bound_state_loc

!=====================================================================
   subroutine calc_bound_state_nonscf_sol(ier)
!=====================================================================
!
!  M. Okamoto
!
!---------------------------------------------------------------------
   use parameters
   implicit none
   integer,intent(out) :: ier
   real(8),allocatable :: &
      bsum(:), amat(:,:), bvec(:), coeff(:), fmat(:,:), hmat(:,:), &
      h0vec(:), rphi_gl(:,:), dxrphi_gl(:,:)
   integer :: ir, ips, ishell, nn, ll, tt, lt, t1, t2, lt1, lt2, &
              ltt, nref, loop, nrm, nrt, node_sum, nmesh_max, &
              max_loop, lguess, nn_sol(0:3), node
   real(8) :: ee, de, r, sign_gr, vv, ss, rr, sum, fguess, gg_norm, &
              eps_de_tmp = 1.d-9, sign_phi
  !++++++++++++++++++++++++++++++++++++
   allocate(bsum(nmesh)) ; bsum = 0.d0
  !++++++++++++++++++++++++++++++++++++
   engy_sol(:)       = 0.d0
   rphi_sol(:,:)     = 0.d0
   beta_phi_sol(:,:) = 0.d0
   nn_sol(:)         = 0
   write(IFLOG,*) 'SOL: nps ...',nps
L_PS:do ips = 1,nps
      ishell = ishell_ps(ips,1)
      if (is_solve(ishell) == 0) then
         cycle L_PS
      end if
      nn = n_qnum(ishell)
      ll = l_qnum(ishell)
      nref = nref_us(ll)
     !++++++++++++++++++++++++++++++++++++++++++++++++++++++++
      allocate(amat(nref,nref),bvec(nref),coeff(nref), &
               fmat(nref,nref),hmat(nref,nref),h0vec(nref), &
               rphi_gl(nmesh,0:nref),dxrphi_gl(nmesh,0:nref))
         amat = 0.d0 ; bvec = 0.d0 ; coeff = 0.d0
         fmat = 0.d0 ; hmat = 0.d0 ; h0vec = 0.d0
         rphi_gl = 0.d0 ; dxrphi_gl = 0.d0
     !++++++++++++++++++++++++++++++++++++++++++++++++++++++++
      if (nn_sol(ll) == 0) then
         nn_sol(ll) = nn
         node = 0
      else if (nn_sol(ll) /= 0) then
         node = nn - nn_sol(ll)
      end if
      node_sum = node
      max_loop = 50
      fguess = 0.5d0
      lguess = 1
      ee  = engy(ishell)
      de  = ee
      nrm = max(nrm_pos(ishell),nrcut_max_us)
      loop = 0
SRCH_EE:do while (abs(de) > eps_de_tmp)
      loop = loop + 1
      if ((loop > max_loop).or.(node_sum /= node)) then
         write(IFLOG,*) &
            '### CAUTION ### loop > max_loop or node_sum != node'
         write(IFLOG,*) '   loop     ...',loop
         write(IFLOG,*) '   max_loop ...',max_loop
         write(IFLOG,*) '   lguess   ...',lguess
         write(IFLOG,*) '   fguess   ...',fguess
         write(IFLOG,*) '   (n,l)    ...',nn,ll
         write(IFLOG,*) '   node_sum ...',node_sum
         write(IFLOG,*) '   node     ...',node
         write(IFLOG,*) '   ee       ...',ee
         write(IFLOG,*) '   de       ...',de
         if (lguess > 1) then
            write(IFLOG,*) '### ERROR ### lguess > 1'
            ier = 1 ; go to 99
         else
            lguess = lguess + 1
            fguess = fguess * 0.5d0
            max_loop = max_loop * 2
            loop = 0
            node_sum = node
            ee = engy(ishell)
            de = ee
            write(IFLOG,*) 'Reset parameters & continue calculation'
            write(IFLOG,*) '   loop     ...',loop
            write(IFLOG,*) '   max_loop ...',max_loop
            write(IFLOG,*) '   lguess   ...',lguess
            write(IFLOG,*) '   fguess   ...',fguess
            write(IFLOG,*) '   ee       ...',ee
            cycle SRCH_EE
         end if
      end if
      nrt = nrm + 1 + max(iord_pc,iord_diff)
      bsum = 0.d0
      call set_initpoints_left_sol(ier,nmesh,ll,ee,rpos, &
              chi_gl,chi_fl,dxchi_gl,dxchi_fl,vloc_scr_sol,bsum)
      call int_from_left_sol(ier,nmesh,node_sum,nrt, &
              ll,ee,iord_nec,dx,rpos, &
              chi_gl,chi_fl,dxchi_gl,dxchi_fl,vloc_scr_sol,bsum)
      if (ier /= 0) then
         write(IFLOG,*) '### ERROR ### in int_from_left_sol [0]'
         go to 99
      end if
      rphi_gl(:,0)   = chi_gl(:)
      dxrphi_gl(:,0) = dxchi_gl(:)
      do tt = 1,nref
         lt = lt_n_us(ll,tt)
         bsum(:) = -rbeta_us(:,lt)
         call set_initpoints_left_sol(ier,nmesh,ll,ee,rpos, &
                 chi_gl,chi_fl,dxchi_gl,dxchi_fl,vloc_scr_sol,bsum)
         call int_from_left_sol(ier,nmesh,node_sum,nrt, &
                 ll,ee,iord_nec,dx,rpos, &
                 chi_gl,chi_fl,dxchi_gl,dxchi_fl,vloc_scr_sol,bsum)
         if (ier /= 0) then
            write(IFLOG,*) '### ERROR ### in int_from_left_sol [1]'
            go to 99
         end if
         rphi_gl(:,tt)   = chi_gl(:)
         dxrphi_gl(:,tt) = dxchi_gl(:)
      end do
      fmat(:,:) = 0.d0
      do t1 = 1,nref
         lt1 = lt_n_us(ll,t1)
         do t2 = 1,nref
            ltt = ltt_nm_us(ll,t1,t2)
            fmat(t1,t2) = dmat_us(ltt) - ee*q_sum_us(ltt)
            sum = 0.d0
            do ir = 1,nmesh
               sum = sum + rbeta_us(ir,lt1)*rphi_gl(ir,t2)*wr(ir)
            end do
            hmat(t1,t2) = sum
         end do
      end do
      amat = matmul(fmat,hmat)
      do tt = 1,nref
         amat(tt,tt) = amat(tt,tt) + 1.d0
         lt = lt_n_us(ll,tt)
         sum = 0.d0
         do ir = 1,nmesh
            sum = sum + rbeta_us(ir,lt)*rphi_gl(ir,0)*wr(ir)
         end do
         h0vec(tt) = sum
      end do
      bvec = -matmul(fmat,h0vec)
      call axb_real_matrix(ier,nref,1,amat,coeff,bvec)
      chi_gl(:)   = rphi_gl(:,0)
      dxchi_gl(:) = dxrphi_gl(:,0)
      do tt = 1,nref
         chi_gl(:) = chi_gl(:) + coeff(tt)*rphi_gl(:,tt)
         dxchi_gl(:) = dxchi_gl(:) + coeff(tt)*dxrphi_gl(:,tt)
      end do
      do ir = 1,nrt
         r = rpos(ir)
         chi_fl(ir) = dxchi_gl(ir)/r - dble(ll+1)/r*chi_gl(ir)
      end do
      call calc_nodes_us(nmesh,chi_gl,nrm,node_sum)
      if (mod(node_sum,2) == 0) then
         sign_gr = +1.d0
      else
         sign_gr = -1.d0
      end if
      nmesh_max = nmesh
      do ir = nmesh,10,-1
         r  = rpos(ir)

! =========================================== modified by K. T. ===============4.0
!         vv = vloc_scr_sol(ir)
         vv = vloc_scr_sol(ir,1)
! ============================================================================= 4.0
         ss = sqrt(2.d0*abs(ee-vv))
         if (ss*r < ARGMAX) then
            nmesh_max = ir ; exit
         end if
      end do
      if (nmesh_max < nmesh) then
         r  = rpos(nmesh_max)

! ============================================ modified by K. T. ============== 4.0
!         vv = vloc_scr_sol(nmesh_max)
         vv = vloc_scr_sol(nmesh_max,1)
! ============================================================================= 4.0

         ss = sqrt(2.d0*abs(ee-vv))
         do ir = nmesh_max+1,nmesh
            r  = rpos(ir)

! =========================================== modified by K. T. ============= 4.0
!            vv = vloc_scr_sol(ir)
            vv = vloc_scr_sol(ir,1)
! ============================================================================ 4.0
            ss = sqrt(2.d0*abs(ee-vv))
            chi_gr(ir) = exp(-ss*r) * sign_gr
            chi_fr(ir) = -ss * chi_gr(ir) 
            dxchi_gr(ir) = 0.d0
            dxchi_fr(ir) = 0.d0
         end do
      end if
      call set_initpoints_right_sol(ier, &
              nmesh,nmesh_max,ll,ee,rpos, &
              chi_gr,chi_fr,dxchi_gr,dxchi_fr,vloc_scr_sol,bsum, &
              sign_gr)
      if (ier /= 0) then
         write(IFLOG,*) '### ERROR ### in set_initpoints_right_sol'
         go to 99
      end if
      nrt = nrm - 1 - max(iord_pc,iord_diff)
      call int_from_right_sol(ier,nmesh,nmesh_max,nrt, &
              ll,ee,iord_nec,dx,rpos, &
              chi_gr,chi_fr,dxchi_gr,dxchi_fr,vloc_scr_sol,bsum)
      if (ier /= 0) then
         write(IFLOG,*) '### ERROR ### in int_from_right_sol'
         go to 99
      end if
      rr = chi_gl(nrm) / chi_gr(nrm)
      do ir = nmesh,nrt,-1
           chi_gr(ir) =   chi_gr(ir) * rr
           chi_fr(ir) =   chi_fr(ir) * rr
         dxchi_gr(ir) = dxchi_gr(ir) * rr
         dxchi_fr(ir) = dxchi_fr(ir) * rr
      end do
      call guess_de_sol(ier,IFLOG,nmesh,nrm,rpos,wt, &
              chi_gl,chi_fl,chi_gr,chi_fr,de,fguess,gg_norm)
      if (ier /= 0) then
         write(IFLOG,*) '### ERROR ### in guess_de' ; go to 99
      end if
      ee = ee + de
      write(IFLOG,'(1x,a33,3i3,2(1pe20.10))') &
         '### SEE ### ips,ll,node,ee,de ...',ips,ll,node_sum,ee,de
end do SRCH_EE
      engy_sol(ips) = ee
      do ir = 1,nrm
         rphi_sol(ir,ips) = chi_gl(ir)
      end do
      do ir = nrm,nmesh
         rphi_sol(ir,ips) = chi_gr(ir)
      end do
      call calc_beta_phi_sol(ier,ips)
      sum = 0.d0
      do ir = 1,nmesh
         sum = sum + rphi_sol(ir,ips)**2*wr(ir)
      end do
      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)
         sum = sum + q_sum_us(ltt) &
                   * beta_phi_sol(lt1,ips) &
                   * beta_phi_sol(lt2,ips)
      end do
      end do
      sign_phi = sign(1.d0,rphi_sol(nmesh,ips))
      !rphi_sol(:,ips) = rphi_sol(:,ips)/sqrt(sum)*sign_gr
      rphi_sol(:,ips) = rphi_sol(:,ips)/sqrt(sum)*sign_phi
      call calc_beta_phi_sol(ier,ips)
      do ir = 1,nmesh
         if (abs(rphi_sol(ir,ips)) < 1.d-99) then
            rphi_sol(ir,ips) = 0.d0
         end if
      end do
     !++++++++++++++++++++++++++++++++++++++++++++++++++++++++++++++
      deallocate(amat,bvec,coeff,fmat,hmat,h0vec,rphi_gl,dxrphi_gl)
     !++++++++++++++++++++++++++++++++++++++++++++++++++++++++++++++
end do L_PS
99 continue
  !+++++++++++++++++
   deallocate(bsum)
  !+++++++++++++++++
   end subroutine calc_bound_state_nonscf_sol

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

  integer,intent(out) :: ier

  real(8),allocatable :: &
       bsum(:), amat(:,:), bvec(:), coeff(:), fmat(:,:), hmat(:,:), &
       h0vec(:), rphi_gl(:,:), dxrphi_gl(:,:)

  integer :: ir, ips, ishell, nn, ll, tt, lt, t1, t2, lt1, lt2, &
       ltt, nref, loop, nrm, nrt, node_sum, nmesh_max, &
       max_loop, lguess, nn_sol(0:3), node

  real(8) :: ee, de, r, sign_gr, vv, ss, rr, sum, fguess, gg_norm, &
       eps_de_tmp = 1.d-9, sign_phi

  integer :: ispin, itmp1, itmp2

  !++++++++++++++++++++++++++++++++++++
  allocate(bsum(nmesh)) ; bsum = 0.d0
  !++++++++++++++++++++++++++++++++++++
  engy_sol(:)       = 0.d0
  rphi_sol(:,:)     = 0.d0
  beta_phi_sol(:,:) = 0.d0
  nn_sol(:)         = 0
  write(IFLOG,*) 'SOL: nps ...',nps

  L_PS:do ips = 1,nps

     ishell = ishell_ps(ips,1)
     if (is_solve(ishell) == 0) then
        cycle L_PS
     end if

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

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

     !++++++++++++++++++++++++++++++++++++++++++++++++++++++++
     allocate(amat(nref,nref),bvec(nref),coeff(nref), &
          fmat(nref,nref),hmat(nref,nref),h0vec(nref), &
          rphi_gl(nmesh,0:nref),dxrphi_gl(nmesh,0:nref))
     amat = 0.d0 ; bvec = 0.d0 ; coeff = 0.d0
     fmat = 0.d0 ; hmat = 0.d0 ; h0vec = 0.d0
     rphi_gl = 0.d0 ; dxrphi_gl = 0.d0
     !++++++++++++++++++++++++++++++++++++++++++++++++++++++++

     if (nn_sol(ll) == 0) then
        nn_sol(ll) = nn
        node = 0
     else if (nn_sol(ll) /= 0) then
        node = nn - nn_sol(ll)
     end if

     node_sum = node
     max_loop = 50
     fguess = 0.5d0
     lguess = 1

     ee  = engy(ishell)
     de  = ee

     nrm = max(nrm_pos(ishell),nrcut_max_us)
     loop = 0

     SRCH_EE:do while (abs(de) > eps_de_tmp)
        loop = loop + 1

        if ((loop > max_loop).or.(node_sum /= node)) then
           write(IFLOG,*) &
                '### CAUTION ### loop > max_loop or node_sum != node'
           write(IFLOG,*) '   loop     ...',loop
           write(IFLOG,*) '   max_loop ...',max_loop
           write(IFLOG,*) '   lguess   ...',lguess
           write(IFLOG,*) '   fguess   ...',fguess
           write(IFLOG,*) '   (n,l)    ...',nn,ll
           write(IFLOG,*) '   node_sum ...',node_sum
           write(IFLOG,*) '   node     ...',node
           write(IFLOG,*) '   ee       ...',ee
           write(IFLOG,*) '   de       ...',de

           if (lguess > 1) then
              write(IFLOG,*) '### ERROR ### lguess > 1'
              ier = 1 ; go to 99
           else
              lguess = lguess + 1
              fguess = fguess * 0.5d0
              max_loop = max_loop * 2
              loop = 0
              node_sum = node
              ee = engy(ishell)
              de = ee
              write(IFLOG,*) 'Reset parameters & continue calculation'
              write(IFLOG,*) '   loop     ...',loop
              write(IFLOG,*) '   max_loop ...',max_loop
              write(IFLOG,*) '   lguess   ...',lguess
              write(IFLOG,*) '   fguess   ...',fguess
              write(IFLOG,*) '   ee       ...',ee
              cycle SRCH_EE
           end if

        end if

        nrt = nrm + 1 + max(iord_pc,iord_diff)

        bsum = 0.d0
        call set_initpoints_left_sol(ier,nmesh,ll,ee,rpos, &
             & chi_gl,chi_fl,dxchi_gl,dxchi_fl,&
             & vloc_scr_sol(:,ispin),bsum )

        call int_from_left_sol(ier,nmesh,node_sum,nrt, &
             & ll,ee,iord_nec,dx,rpos, &
             & chi_gl,chi_fl,dxchi_gl,dxchi_fl, &
             & vloc_scr_sol(:,ispin),bsum )

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

        rphi_gl(:,0)   = chi_gl(:)
        dxrphi_gl(:,0) = dxchi_gl(:)

        do tt = 1, nref

           itmp1 = tt + nref_max_us *(ispin -1)
           lt = lt_n_us(ll,itmp1)

           bsum(:) = -rbeta_us(:,lt)

           call set_initpoints_left_sol(ier,nmesh,ll,ee,rpos, &
                & chi_gl,chi_fl,dxchi_gl,dxchi_fl, &
                & vloc_scr_sol(:,ispin),bsum )

           call int_from_left_sol(ier,nmesh,node_sum,nrt, &
                & ll,ee,iord_nec,dx,rpos, &
                & chi_gl,chi_fl,dxchi_gl,dxchi_fl, &
                & vloc_scr_sol(:,ispin),bsum )

           if (ier /= 0) then
              write(IFLOG,*) '### ERROR ### in int_from_left_sol [1]'
              go to 99
           end if

           rphi_gl(:,tt)   = chi_gl(:)
           dxrphi_gl(:,tt) = dxchi_gl(:)
        end do

        fmat(:,:) = 0.d0

        do t1 = 1,nref
           itmp1 = t1 + nref_max_us *( ispin -1 )
           lt1 = lt_n_us(ll,itmp1)

           do t2 = 1,nref
              itmp2 = t2 + nref_max_us *( ispin -1 )

              ltt = ltt_nm_us(ll,itmp1,itmp2)

              fmat(t1,t2) = dmat_us(ltt) - ee*q_sum_us(ltt)
              sum = 0.d0
              do ir = 1,nmesh
                 sum = sum + rbeta_us(ir,lt1)*rphi_gl(ir,t2)*wr(ir)
              end do
              hmat(t1,t2) = sum
           end do
        end do

        amat = matmul(fmat,hmat)

        do tt = 1,nref
           amat(tt,tt) = amat(tt,tt) + 1.d0

           itmp1 = tt + nref_max_us *(ispin -1 )
           lt = lt_n_us(ll,itmp1)

           sum = 0.d0
           do ir = 1,nmesh
              sum = sum + rbeta_us(ir,lt)*rphi_gl(ir,0)*wr(ir)
           end do
           h0vec(tt) = sum
        end do

        bvec = -matmul(fmat,h0vec)

        call axb_real_matrix(ier,nref,1,amat,coeff,bvec)

        chi_gl(:)   = rphi_gl(:,0)
        dxchi_gl(:) = dxrphi_gl(:,0)
        
        do tt = 1,nref
           chi_gl(:) = chi_gl(:) + coeff(tt)*rphi_gl(:,tt)
           dxchi_gl(:) = dxchi_gl(:) + coeff(tt)*dxrphi_gl(:,tt)
        end do

        do ir = 1,nrt
           r = rpos(ir)
           chi_fl(ir) = dxchi_gl(ir)/r - dble(ll+1)/r*chi_gl(ir)
        end do

        call calc_nodes_us(nmesh,chi_gl,nrm,node_sum)
        if (mod(node_sum,2) == 0) then
           sign_gr = +1.d0
        else
           sign_gr = -1.d0
        end if

        nmesh_max = nmesh

        do ir = nmesh,10,-1
           r  = rpos(ir)

           vv = vloc_scr_sol(ir,ispin)

           ss = sqrt(2.d0*abs(ee-vv))
           if (ss*r < ARGMAX) then
              nmesh_max = ir ; exit
           end if
        end do

        if (nmesh_max < nmesh) then
           r  = rpos(nmesh_max)

           vv = vloc_scr_sol(nmesh_max,ispin)

           ss = sqrt(2.d0*abs(ee-vv))
           do ir = nmesh_max+1,nmesh
              r  = rpos(ir)
              
              vv = vloc_scr_sol(ir,ispin)

              ss = sqrt(2.d0*abs(ee-vv))
              chi_gr(ir) = exp(-ss*r) * sign_gr
              chi_fr(ir) = -ss * chi_gr(ir) 
              dxchi_gr(ir) = 0.d0
              dxchi_fr(ir) = 0.d0
           end do
        end if

        call set_initpoints_right_sol(ier, &
             & nmesh,nmesh_max,ll,ee,rpos, &
             & chi_gr,chi_fr,dxchi_gr,dxchi_fr,&
             & vloc_scr_sol(:,ispin), bsum, &
             & sign_gr )

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

        nrt = nrm - 1 - max(iord_pc,iord_diff)

        call int_from_right_sol(ier,nmesh,nmesh_max,nrt, &
             & ll,ee,iord_nec,dx,rpos, &
             & chi_gr,chi_fr,dxchi_gr,dxchi_fr, &
             & vloc_scr_sol(:,ispin), bsum )

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

        rr = chi_gl(nrm) / chi_gr(nrm)
        do ir = nmesh,nrt,-1
           chi_gr(ir) =   chi_gr(ir) * rr
           chi_fr(ir) =   chi_fr(ir) * rr
           dxchi_gr(ir) = dxchi_gr(ir) * rr
           dxchi_fr(ir) = dxchi_fr(ir) * rr
        end do

        call guess_de_sol(ier,IFLOG,nmesh,nrm,rpos,wt, &
             chi_gl,chi_fl,chi_gr,chi_fr,de,fguess,gg_norm)
        if (ier /= 0) then
           write(IFLOG,*) '### ERROR ### in guess_de' ; go to 99
        end if

        ee = ee + de
        write(IFLOG,'(1x,a33,3i3,2(1pe20.10))') &
             '### SEE ### ips,ll,node,ee,de ...',ips,ll,node_sum,ee,de

     end do SRCH_EE

     engy_sol(ips) = ee
     do ir = 1,nrm
        rphi_sol(ir,ips) = chi_gl(ir)
     end do

     do ir = nrm,nmesh
        rphi_sol(ir,ips) = chi_gr(ir)
     end do

     call calc_beta_phi_sol_kt(ier,ips)

     sum = 0.d0
     do ir = 1,nmesh
        sum = sum + rphi_sol(ir,ips)**2*wr(ir)
     end do

     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)

           sum = sum + q_sum_us(ltt) &
                * beta_phi_sol(lt1,ips) &
                * beta_phi_sol(lt2,ips)
        end do
     end do

     sign_phi = sign(1.d0,rphi_sol(nmesh,ips))
      !rphi_sol(:,ips) = rphi_sol(:,ips)/sqrt(sum)*sign_gr
     rphi_sol(:,ips) = rphi_sol(:,ips)/sqrt(sum)*sign_phi

     call calc_beta_phi_sol_kt(ier,ips)
     do ir = 1,nmesh
        if (abs(rphi_sol(ir,ips)) < 1.d-99) then
           rphi_sol(ir,ips) = 0.d0
        end if
     end do

     !++++++++++++++++++++++++++++++++++++++++++++++++++++++++++++++
     deallocate(amat,bvec,coeff,fmat,hmat,h0vec,rphi_gl,dxrphi_gl)
     !++++++++++++++++++++++++++++++++++++++++++++++++++++++++++++++

  end do L_PS

99 continue
  !+++++++++++++++++
  deallocate(bsum)
  !+++++++++++++++++

end subroutine calc_bound_state_nonscf_sol_kt
! ======================================================================= 4.0
   
!=====================================================================
   subroutine calc_bound_state_ss(ier)
!=====================================================================
!
!  M. Okamoto
!
!---------------------------------------------------------------------
   use parameters
   implicit none
   integer,intent(out) :: ier
   real(8),allocatable :: &
      bsum(:), amat(:,:), bvec(:), coeff(:), fmat(:,:), hmat(:,:), &
      h0vec(:), rphi_gl(:,:), dxrphi_gl(:,:)
   integer :: ir, iss, ishell, nn, ll, tt, lt, t1, t2, lt1, lt2, &
              ltt, nref, nrm, nrt, node_sum, node, nmesh_max, &
              num_eslides, max_eslides, loop, max_loop, ispin, &
              nn_ss(0:3), lguess, max_loop_in
   real(8) :: ee, de, r, vv, ss, rr, &
              sign_gr, ee_upper_limit, ee_lower_limit,  &
              ee_upper_limit_in, engy_minimum,          &
              sum, etest, fguess, gg_norm, ee_in,       &
              eps_de_tmp = 1.d-9
   ier = 0
   max_eslides  =  25
   max_loop_in  =  50
   engy_minimum = 1.d-4
  !++++++++++++++++++++++++++++++++++++
   allocate(bsum(nmesh)) ; bsum = 0.d0
  !++++++++++++++++++++++++++++++++++++
   rphi_ss(:,:)     = 0.d0
   beta_phi_ss(:,:) = 0.d0
   nn_ss(:) = 0
   write(IFLOG,*) 'SS: nss ...',nss
L_SS:do iss = 1,nss
      if (is_solve_ss(iss) == 0) then
         write(IFLOG,*) 'SS: bypass iss =',iss
         engy_ss(iss) = 0.d0 ; cycle L_SS
      end if
      ishell = ishell_ss(iss)
      ispin = (1-spin_ss(iss))/2 + 1
      nn = n_qnum(ishell)
      ll = l_qnum(ishell)
      nref = nref_us(ll)
     !++++++++++++++++++++++++++++++++++++++++++++++++++++++++
      allocate(amat(nref,nref),bvec(nref),coeff(nref), &
               fmat(nref,nref),hmat(nref,nref),h0vec(nref), &
               rphi_gl(nmesh,0:nref),dxrphi_gl(nmesh,0:nref))
         amat = 0.d0 ; bvec = 0.d0 ; coeff = 0.d0
         fmat = 0.d0 ; hmat = 0.d0 ; h0vec = 0.d0
         rphi_gl = 0.d0 ; dxrphi_gl = 0.d0
     !++++++++++++++++++++++++++++++++++++++++++++++++++++++++
      fguess = 1.d0
      lguess = 1
      if (nn_ss(ll) == 0) then
         nn_ss(ll) = nn
         node = 0
      else if (nn_ss(ll) /= 0) then
         node = nn - nn_ss(ll)
      end if
      node_sum = node
      if (mod(node,2) == 0) then
         sign_gr = +1.d0
      else
         sign_gr = -1.d0
      end if
      num_eslides = 0
         write(IFLOG,'(1x,a29,5i5)') &
            'SS: iss,ispin,nn,ll,node ...',ishell,ispin,nn,ll,node
      ee = engy_ss(iss)
   if (is_core == OZAKI_KINO) then
      ee_upper_limit = 100.d0
      nmesh_max = nrcut_ok + 20
   else
      nmesh_max = nmesh
      do ir = nmesh,10,-1
         r  = rpos(ir)
         vv = vloc_scr_ss(ir,ispin)
         ss = sqrt(2.d0*abs(ee-vv))
         if (ss*r < ARGMAX) then
            nmesh_max = ir ; exit
         end if
      end do
      ee_upper_limit = vloc_scr_ss(nmesh_max,ispin) - engy_minimum
      if (ee_upper_limit > -engy_minimum) then
         ee_upper_limit = -engy_minimum
      end if
   end if
      ee_upper_limit_in = ee_upper_limit
      ee_lower_limit = ee - 2.d0
      if ((ee > ee_upper_limit).or.(ee < ee_lower_limit)) then
         ee = 0.5d0*(ee_upper_limit + ee_lower_limit)
      end if
      de = ee
      ee_in = ee
      nrm = max(nrm_pos_ss(iss),nrcut_max_us)
      max_loop = max_loop_in
      loop = 0
SRCH_EE:do while (abs(de) > eps_de_tmp)
      loop = loop + 1
      if (loop > max_loop) then
         if (lguess < 2) then
            lguess = lguess + 1
            fguess = fguess * 0.5d0
            max_loop = max_loop * 2
            loop = 0
            node_sum = node
            ee = ee_in
            de = ee
            write(IFLOG,*) 'Reset parameters & continue calculation'
            write(IFLOG,*) '   loop     ...',loop
            write(IFLOG,*) '   max_loop ...',max_loop
            write(IFLOG,*) '   lguess   ...',lguess
            write(IFLOG,*) '   fguess   ...',fguess
            write(IFLOG,*) '   ee       ...',ee
            cycle SRCH_EE
         end if
         if (node_sum < node) then
            write(IFLOG,*) '### CAUTION ### node_sum < node'
            write(IFLOG,*) '   node_sum,node ...',node_sum,node
            write(IFLOG,*) &
               '   Following state may be an unbound state.'
            write(IFLOG,*) '      iss          ...',iss
            write(IFLOG,*) '      (nn,ll,spin) ...',nn,ll,ispin
            if (abs(focc_ss(iss)) > eps_check) then
               write(IFLOG,*) '   Since focc of the state is non-zero,'
               write(IFLOG,*) '      calculation continues.'
               exit SRCH_EE
            else
               write(IFLOG,*) &
                  '   The state is removed in the later calc.'
               is_solve_ss(iss) = 0 ; ee = 0.d0 ; exit SRCH_EE
            end if
         else
            write(IFLOG,*) '### ERROR ### loop > max_loop'
            write(IFLOG,*) '   loop, max_loop ...',loop,max_loop
            write(IFLOG,*) '   iss,nn,ll,node ...',iss,nn,ll,node
            write(IFLOG,*) '   node_sum,node  ...',node_sum,node
            write(IFLOG,*) '   ee_upper_limit ...',ee_upper_limit
            write(IFLOG,*) '   ee_lower_limit ...',ee_lower_limit
            write(IFLOG,*) '   ee             ...',ee
            write(IFLOG,*) '   de             ...',de
            ier=1 ; go to 99
         end if
      end if
      if (num_eslides > max_eslides) then
         write(IFLOG,*) '### CAUTION ### Eigenvalue was not converged !'
         write(IFLOG,*) '      num_eslides  ...',num_eslides
         write(IFLOG,*) '      max_eslides  ...',max_eslides
         write(IFLOG,*) '   Following state may be an unbound state.'
         write(IFLOG,*) '      iss          ...',iss
         write(IFLOG,*) '      (nn,ll,spin) ...',nn,ll,ispin
         if (abs(focc_ss(iss)) > eps_check) then
            write(IFLOG,*) '   Since focc of the state is non-zero,'
            write(IFLOG,*) '      calculation continues.'
            exit SRCH_EE
         else
            write(IFLOG,*) '   The state is removed in the later calc.'
            is_solve_ss(iss) = 0 ; ee = 0.d0 ; exit SRCH_EE
         end if
      end if
      nrt = nrm + 1 + max(iord_pc,iord_diff)
      bsum = 0.d0
      call set_initpoints_left_sol(ier,nmesh,ll,ee,rpos, &
              chi_gl,chi_fl,dxchi_gl,dxchi_fl, &
              vloc_scr_ss(1,ispin),bsum)
      call int_from_left_sol(ier,nmesh,node_sum,nrt, &
              ll,ee,iord_nec,dx,rpos, &
              chi_gl,chi_fl,dxchi_gl,dxchi_fl, &
              vloc_scr_ss(1,ispin),bsum)
      if (ier /= 0) then
         write(IFLOG,*) '### ERROR ### in int_from_left_sol [0]'
         go to 99
      end if
      rphi_gl(:,0)   = chi_gl(:)
      dxrphi_gl(:,0) = dxchi_gl(:)
      do tt = 1,nref
         lt = lt_n_us(ll,tt)
         bsum(:) = -rbeta_us(:,lt)
         call set_initpoints_left_sol(ier,nmesh,ll,ee,rpos, &
                 chi_gl,chi_fl,dxchi_gl,dxchi_fl, &
                 vloc_scr_ss(1,ispin),bsum)
         call int_from_left_sol(ier,nmesh,node_sum,nrt, &
                 ll,ee,iord_nec,dx,rpos, &
                 chi_gl,chi_fl,dxchi_gl,dxchi_fl, &
                 vloc_scr_ss(1,ispin),bsum)
         if (ier /= 0) then
            write(IFLOG,*) '### ERROR ### in int_from_left_sol [1]'
            go to 99
         end if
         rphi_gl(:,tt)   = chi_gl(:)
         dxrphi_gl(:,tt) = dxchi_gl(:)
      end do
      fmat(:,:) = 0.d0
      do t1 = 1,nref
         lt1 = lt_n_us(ll,t1)
         do t2 = 1,nref
            ltt = ltt_nm_us(ll,t1,t2)
            fmat(t1,t2) = dmat_ss(ltt,ispin) - ee*q_sum_us(ltt)
            sum = 0.d0
            do ir = 1,nmesh
               sum = sum + rbeta_us(ir,lt1)*rphi_gl(ir,t2)*wr(ir)
            end do
            hmat(t1,t2) = sum
         end do
      end do
      amat = matmul(fmat,hmat)
      do tt = 1,nref
         amat(tt,tt) = amat(tt,tt) + 1.d0
         lt = lt_n_us(ll,tt)
         sum = 0.d0
         do ir = 1,nmesh
            sum = sum + rbeta_us(ir,lt)*rphi_gl(ir,0)*wr(ir)
         end do
         h0vec(tt) = sum
      end do
      bvec = -matmul(fmat,h0vec)
      call axb_real_matrix(ier,nref,1,amat,coeff,bvec)
      chi_gl(:)   = rphi_gl(:,0)
      dxchi_gl(:) = dxrphi_gl(:,0)
      do tt = 1,nref
         chi_gl(:) = chi_gl(:) + coeff(tt)*rphi_gl(:,tt)
         dxchi_gl(:) = dxchi_gl(:) + coeff(tt)*dxrphi_gl(:,tt)
      end do
      do ir = 1,nrt
         r = rpos(ir)
         chi_fl(ir) = dxchi_gl(ir)/r - dble(ll+1)/r*chi_gl(ir)
      end do
      call calc_nodes_us(nmesh,chi_gl,nrm,node_sum)
      if (node_sum > node) then
         if (ee < ee_upper_limit) then
            ee_upper_limit = ee
         end if
         if (ee_upper_limit > ee_upper_limit_in) then
            ee_upper_limit = ee_upper_limit_in
         end if
         ee = 0.5d0*(ee + ee_lower_limit)
         ee_lower_limit = ee_lower_limit * 1.2d0
         cycle SRCH_EE
      else if (node_sum < node) then
         if (ee > ee_lower_limit) then
            ee_lower_limit = ee
         end if
         ee = 0.5d0*(ee_upper_limit + ee)
         ee_upper_limit = ee_upper_limit_in
         ee = 0.5d0*(ee_upper_limit + ee)
         cycle SRCH_EE
      end if
   if (is_core == OZAKI_KINO) then
      nmesh_max = nrcut_ok + 20
   else
      nmesh_max = nmesh
      do ir = nmesh,10,-1
         r  = rpos(ir)
         vv = vloc_scr_ss(ir,ispin)
         ss = sqrt(2.d0*abs(ee-vv))
         if (ss*r < ARGMAX) then
            nmesh_max = ir ; exit
         end if
      end do
   end if
      if (nmesh_max < nmesh) then
         r  = rpos(nmesh_max)
         vv = vloc_scr_ss(nmesh_max,ispin)
         ss = sqrt(2.d0*abs(ee-vv))
         do ir = nmesh_max+1,nmesh
            r  = rpos(ir)
            vv = vloc_scr_ss(ir,ispin)
            ss = sqrt(2.d0*abs(ee-vv))
            chi_gr(ir) = exp(-ss*r) * sign_gr
            chi_fr(ir) = -ss * chi_gr(ir) 
            dxchi_gr(ir) = 0.d0
            dxchi_fr(ir) = 0.d0
         end do
      end if
      call set_initpoints_right_sol(ier, &
              nmesh,nmesh_max,ll,ee,rpos, &
              chi_gr,chi_fr,dxchi_gr,dxchi_fr, &
              vloc_scr_ss(1,ispin),bsum,sign_gr)
      if (ier /= 0) then
         write(IFLOG,*) '### ERROR ### in set_initpoints_right_sol'
         go to 99
      end if
      nrt = nrm - 1 - max(iord_pc,iord_diff)
      call int_from_right_sol(ier,nmesh,nmesh_max,nrt, &
              ll,ee,iord_nec,dx,rpos, &
              chi_gr,chi_fr,dxchi_gr,dxchi_fr, &
              vloc_scr_ss(1,ispin),bsum)
      if (ier /= 0) then
         write(IFLOG,*) '### ERROR ### in int_from_right_sol'
         go to 99
      end if
      rr = chi_gl(nrm) / chi_gr(nrm)
      do ir = nmesh,nrt,-1
           chi_gr(ir) =   chi_gr(ir) * rr
           chi_fr(ir) =   chi_fr(ir) * rr
         dxchi_gr(ir) = dxchi_gr(ir) * rr
         dxchi_fr(ir) = dxchi_fr(ir) * rr
      end do
      call guess_de_sol(ier,IFLOG,nmesh,nrm,rpos,wt, &
              chi_gl,chi_fl,chi_gr,chi_fr,de,fguess,gg_norm)
      if (ier /= 0) then
         write(IFLOG,*) '### ERROR ### in guess_de' ; go to 99
      end if
      if (de > 0.d0) then
         ee_lower_limit = ee
      else if (de < 0.d0) then
         ee_upper_limit = ee
         if (ee_upper_limit > ee_upper_limit_in) then
            ee_upper_limit = ee_upper_limit_in
         end if
      end if
      etest = ee + de
      if ((etest-ee_upper_limit)*(etest-ee_lower_limit) < 0.d0) then
         ee = etest
      else
         ee = 0.5d0*(ee_upper_limit + ee_lower_limit)
         num_eslides = num_eslides + 1
      end if
         write(IFLOG,'(1x,a21,2i5,f25.15,1pe20.10)') &
           'SS: iss,ll,ee,de ...',iss,ll,ee,de
end do SRCH_EE
      if (is_solve_ss(iss) /= 0) then
         engy_ss(iss) = ee
      else
         engy_ss(iss) = 0.d0
      end if
      if (is_solve_ss(iss) /= 0) then
         do ir = 1,nrm
            rphi_ss(ir,iss) = chi_gl(ir)
         end do
         do ir = nrm,nmesh
            rphi_ss(ir,iss) = chi_gr(ir)
         end do
      else
         rphi_ss(:,iss) = 0.d0
      end if
      if (is_solve_ss(iss) /= 0) then
         call calc_beta_phi_ss(ier,iss)
         sum = 0.d0
         do ir = 1,nmesh
            sum = sum + rphi_ss(ir,iss)**2*wr(ir)
         end do
         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)
            sum = sum + q_sum_us(ltt) &
                      * beta_phi_ss(lt1,iss) &
                      * beta_phi_ss(lt2,iss)
         end do
         end do
         rphi_ss(:,iss) = rphi_ss(:,iss)/sqrt(sum)*sign_gr
         call calc_beta_phi_ss(ier,iss)
      else
         beta_phi_ss(:,iss) = 0.d0
      end if
      do ir = 1,nmesh
         if (abs(rphi_ss(ir,iss)) < 1.d-99) then
            rphi_ss(ir,iss) = 0.d0
         end if
      end do
     !++++++++++++++++++++++++++++++++++++++++++++++++++++++++++++++
      deallocate(amat,bvec,coeff,fmat,hmat,h0vec,rphi_gl,dxrphi_gl)
     !++++++++++++++++++++++++++++++++++++++++++++++++++++++++++++++
end do L_SS
99 continue
  !+++++++++++++++++
   deallocate(bsum)
  !+++++++++++++++++
   end subroutine calc_bound_state_ss

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

  integer,intent(out) :: ier
  real(8),allocatable :: &
       bsum(:), amat(:,:), bvec(:), coeff(:), fmat(:,:), hmat(:,:), &
       h0vec(:), rphi_gl(:,:), dxrphi_gl(:,:)

  integer :: ir, iss, ishell, nn, ll, tt, lt, t1, t2, lt1, lt2, &
       ltt, nref, nrm, nrt, node_sum, node, nmesh_max, &
       num_eslides, max_eslides, loop, max_loop, ispin, &
       nn_ss(0:3), lguess, max_loop_in
  real(8) :: ee, de, r, vv, ss, rr, &
       sign_gr, ee_upper_limit, ee_lower_limit,  &
       ee_upper_limit_in, engy_minimum,          &
       sum, etest, fguess, gg_norm, ee_in,       &
       eps_de_tmp = 1.d-9

  integer :: itmp1, itmp2

  ier = 0

  max_eslides  =  25
  max_loop_in  =  50
  engy_minimum = 1.d-4

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

  rphi_ss(:,:)     = 0.d0
  beta_phi_ss(:,:) = 0.d0
  nn_ss(:) = 0

  write(IFLOG,*) 'SS: nss ...',nss

  L_SS:do iss = 1,nss

     if (is_solve_ss(iss) == 0) then
        write(IFLOG,*) 'SS: bypass iss =',iss
        engy_ss(iss) = 0.d0 ; cycle L_SS
     end if

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

!     write(*,*) 'ispin @iss = ', iss, ispin

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

     !++++++++++++++++++++++++++++++++++++++++++++++++++++++++
     allocate(amat(nref,nref),bvec(nref),coeff(nref), &
          fmat(nref,nref),hmat(nref,nref),h0vec(nref), &
          rphi_gl(nmesh,0:nref),dxrphi_gl(nmesh,0:nref))
     amat = 0.d0 ; bvec = 0.d0 ; coeff = 0.d0
     fmat = 0.d0 ; hmat = 0.d0 ; h0vec = 0.d0
     rphi_gl = 0.d0 ; dxrphi_gl = 0.d0
     !++++++++++++++++++++++++++++++++++++++++++++++++++++++++

     fguess = 1.d0
     lguess = 1

     if (nn_ss(ll) == 0) then
        nn_ss(ll) = nn
        node = 0
     else if (nn_ss(ll) /= 0) then
        node = nn - nn_ss(ll)
     end if

     node_sum = node
     if (mod(node,2) == 0) then
        sign_gr = +1.d0
     else
        sign_gr = -1.d0
     end if

     num_eslides = 0
     write(IFLOG,'(1x,a29,5i5)') &
          'SS: ishell,ispin,nn,ll,node ...',ishell,ispin,nn,ll,node

     ee = engy_ss(iss)

     if (is_core == OZAKI_KINO) then
        ee_upper_limit = 100.d0
        nmesh_max = nrcut_ok + 20

     else
        nmesh_max = nmesh
        do ir = nmesh,10,-1
           r  = rpos(ir)
           vv = vloc_scr_ss(ir,ispin)
           ss = sqrt(2.d0*abs(ee-vv))
           if (ss*r < ARGMAX) then
              nmesh_max = ir ; exit
           end if
        end do

        ee_upper_limit = vloc_scr_ss(nmesh_max,ispin) - engy_minimum
        if (ee_upper_limit > -engy_minimum) then
           ee_upper_limit = -engy_minimum

        end if
     end if

     ee_upper_limit_in = ee_upper_limit
     ee_lower_limit = ee - 2.d0

     if ((ee > ee_upper_limit).or.(ee < ee_lower_limit)) then
        ee = 0.5d0*(ee_upper_limit + ee_lower_limit)
     end if

     de = ee
     ee_in = ee

     nrm = max(nrm_pos_ss(iss),nrcut_max_us)
     max_loop = max_loop_in

     loop = 0

     SRCH_EE:do while (abs(de) > eps_de_tmp)
        loop = loop + 1
        if (loop > max_loop) then
           if (lguess < 2) then
              lguess = lguess + 1
              fguess = fguess * 0.5d0
              max_loop = max_loop * 2
              loop = 0
              node_sum = node
              ee = ee_in
              de = ee
              write(IFLOG,*) 'Reset parameters & continue calculation'
              write(IFLOG,*) '   loop     ...',loop
              write(IFLOG,*) '   max_loop ...',max_loop
              write(IFLOG,*) '   lguess   ...',lguess
              write(IFLOG,*) '   fguess   ...',fguess
              write(IFLOG,*) '   ee       ...',ee
              cycle SRCH_EE
           end if

           if (node_sum < node) then
              write(IFLOG,*) '### CAUTION ### node_sum < node'
              write(IFLOG,*) '   node_sum,node ...',node_sum,node
              write(IFLOG,*) &
                   '   Following state may be an unbound state.'
              write(IFLOG,*) '      iss          ...',iss
              write(IFLOG,*) '      (nn,ll,spin) ...',nn,ll,ispin
              if (abs(focc_ss(iss)) > eps_check) then
                 write(IFLOG,*) '   Since focc of the state is non-zero,'
                 write(IFLOG,*) '      calculation continues.'
                 exit SRCH_EE
              else
                 write(IFLOG,*) &
                      '   The state is removed in the later calc.'
                 is_solve_ss(iss) = 0 ; ee = 0.d0 ; exit SRCH_EE
              end if

           else
              write(IFLOG,*) '### ERROR ### loop > max_loop'
              write(IFLOG,*) '   loop, max_loop ...',loop,max_loop
              write(IFLOG,*) '   iss,nn,ll,node ...',iss,nn,ll,node
              write(IFLOG,*) '   node_sum,node  ...',node_sum,node
              write(IFLOG,*) '   ee_upper_limit ...',ee_upper_limit
              write(IFLOG,*) '   ee_lower_limit ...',ee_lower_limit
              write(IFLOG,*) '   ee             ...',ee
              write(IFLOG,*) '   de             ...',de
              ier=1 ; go to 99
           end if

        end if

        if (num_eslides > max_eslides) then
           write(IFLOG,*) '### CAUTION ### Eigenvalue was not converged !'
           write(IFLOG,*) '      num_eslides  ...',num_eslides
           write(IFLOG,*) '      max_eslides  ...',max_eslides
           write(IFLOG,*) '   Following state may be an unbound state.'
           write(IFLOG,*) '      iss          ...',iss
           write(IFLOG,*) '      (nn,ll,spin) ...',nn,ll,ispin
           if (abs(focc_ss(iss)) > eps_check) then
              write(IFLOG,*) '   Since focc of the state is non-zero,'
              write(IFLOG,*) '      calculation continues.'
              exit SRCH_EE
           else
              write(IFLOG,*) '   The state is removed in the later calc.'
              is_solve_ss(iss) = 0 ; ee = 0.d0 ; exit SRCH_EE
           end if
        end if

        nrt = nrm + 1 + max(iord_pc,iord_diff)
        bsum = 0.d0

        call set_initpoints_left_sol(ier,nmesh,ll,ee,rpos, &
             chi_gl,chi_fl,dxchi_gl,dxchi_fl, &
             vloc_scr_ss(1,ispin),bsum)

        call int_from_left_sol(ier,nmesh,node_sum,nrt, &
              ll,ee,iord_nec,dx,rpos, &
              chi_gl,chi_fl,dxchi_gl,dxchi_fl, &
              vloc_scr_ss(1,ispin),bsum)

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

        rphi_gl(:,0)   = chi_gl(:)
        dxrphi_gl(:,0) = dxchi_gl(:)

        do tt = 1,nref
           
           if ( nspin == 1 ) then
              itmp1 = tt
           else if ( nspin ==2 ) then
              itmp1 = tt + nref_max_us *( ispin -1 )
           endif

           lt = lt_n_us(ll,itmp1)

           bsum(:) = -rbeta_us(:,lt)

           call set_initpoints_left_sol(ier,nmesh,ll,ee,rpos, &
                chi_gl,chi_fl,dxchi_gl,dxchi_fl, &
                vloc_scr_ss(1,ispin),bsum)

           call int_from_left_sol(ier,nmesh,node_sum,nrt, &
                ll,ee,iord_nec,dx,rpos, &
                chi_gl,chi_fl,dxchi_gl,dxchi_fl, &
                vloc_scr_ss(1,ispin),bsum)

           if (ier /= 0) then
              write(IFLOG,*) '### ERROR ### in int_from_left_sol [1]'
              go to 99
           end if

           rphi_gl(:,tt)   = chi_gl(:)
           dxrphi_gl(:,tt) = dxchi_gl(:)
        end do

        fmat(:,:) = 0.d0

        do t1 = 1,nref

           if ( nspin == 1 ) then
              itmp1 = t1
           else if ( nspin == 2 ) then
              itmp1 = t1 + nref_max_us *( ispin -1 )
           endif

           lt1 = lt_n_us(ll,itmp1)

           do t2 = 1,nref

              if ( nspin == 1 ) then
                 itmp2 = t2
              else if ( nspin == 2 ) then
                 itmp2 = t2 + nref_max_us *( ispin -1 )
              endif

              ltt = ltt_nm_us(ll,itmp1,itmp2)

              fmat(t1,t2) = dmat_ss(ltt,ispin) - ee*q_sum_us(ltt)

              sum = 0.d0
              do ir = 1,nmesh
                 sum = sum + rbeta_us(ir,lt1)*rphi_gl(ir,t2)*wr(ir)
              end do
              hmat(t1,t2) = sum

           end do
        end do

        amat = matmul(fmat,hmat)

        do tt = 1,nref
           amat(tt,tt) = amat(tt,tt) + 1.d0

           if ( nspin == 1 ) then
              itmp1 = tt
           else if ( nspin == 2 ) then
              itmp1 = tt + nref_max_us *(ispin -1 )
           endif

           lt = lt_n_us(ll,itmp1)

           sum = 0.d0
           do ir = 1,nmesh
              sum = sum + rbeta_us(ir,lt)*rphi_gl(ir,0)*wr(ir)
           end do
           h0vec(tt) = sum
        end do

        bvec = -matmul(fmat,h0vec)

        call axb_real_matrix(ier,nref,1,amat,coeff,bvec)
        chi_gl(:)   = rphi_gl(:,0)
        dxchi_gl(:) = dxrphi_gl(:,0)

        do tt = 1,nref
           chi_gl(:) = chi_gl(:) + coeff(tt)*rphi_gl(:,tt)
           dxchi_gl(:) = dxchi_gl(:) + coeff(tt)*dxrphi_gl(:,tt)
        end do

        do ir = 1,nrt
           r = rpos(ir)
           chi_fl(ir) = dxchi_gl(ir)/r - dble(ll+1)/r*chi_gl(ir)
        end do

        call calc_nodes_us(nmesh,chi_gl,nrm,node_sum)

        if (node_sum > node) then
           if (ee < ee_upper_limit) then
              ee_upper_limit = ee
           end if
           if (ee_upper_limit > ee_upper_limit_in) then
              ee_upper_limit = ee_upper_limit_in
           end if
           ee = 0.5d0*(ee + ee_lower_limit)
           ee_lower_limit = ee_lower_limit * 1.2d0
           cycle SRCH_EE

        else if (node_sum < node) then
           if (ee > ee_lower_limit) then
              ee_lower_limit = ee
           end if
           ee = 0.5d0*(ee_upper_limit + ee)
           ee_upper_limit = ee_upper_limit_in
           ee = 0.5d0*(ee_upper_limit + ee)
           cycle SRCH_EE
        end if

        if (is_core == OZAKI_KINO) then
           nmesh_max = nrcut_ok + 20
        else
           nmesh_max = nmesh
           do ir = nmesh,10,-1
              r  = rpos(ir)
              vv = vloc_scr_ss(ir,ispin)
              ss = sqrt(2.d0*abs(ee-vv))
              if (ss*r < ARGMAX) then
                 nmesh_max = ir ; exit
              end if
           end do
        end if

        if (nmesh_max < nmesh) then
           r  = rpos(nmesh_max)
           vv = vloc_scr_ss(nmesh_max,ispin)
           ss = sqrt(2.d0*abs(ee-vv))
           do ir = nmesh_max+1,nmesh
              r  = rpos(ir)
              vv = vloc_scr_ss(ir,ispin)
              ss = sqrt(2.d0*abs(ee-vv))
              chi_gr(ir) = exp(-ss*r) * sign_gr
              chi_fr(ir) = -ss * chi_gr(ir) 
              dxchi_gr(ir) = 0.d0
              dxchi_fr(ir) = 0.d0
           end do
        end if

        call set_initpoints_right_sol(ier, &
             nmesh,nmesh_max,ll,ee,rpos, &
             chi_gr,chi_fr,dxchi_gr,dxchi_fr, &
             vloc_scr_ss(1,ispin),bsum,sign_gr)

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

        nrt = nrm - 1 - max(iord_pc,iord_diff)

        call int_from_right_sol(ier,nmesh,nmesh_max,nrt, &
             ll,ee,iord_nec,dx,rpos, &
             chi_gr,chi_fr,dxchi_gr,dxchi_fr, &
             vloc_scr_ss(1,ispin),bsum)
        if (ier /= 0) then
           write(IFLOG,*) '### ERROR ### in int_from_right_sol'
           go to 99
        end if

        rr = chi_gl(nrm) / chi_gr(nrm)
        do ir = nmesh,nrt,-1
           chi_gr(ir) =   chi_gr(ir) * rr
           chi_fr(ir) =   chi_fr(ir) * rr
           dxchi_gr(ir) = dxchi_gr(ir) * rr
           dxchi_fr(ir) = dxchi_fr(ir) * rr
        end do

        call guess_de_sol(ier,IFLOG,nmesh,nrm,rpos,wt, &
             chi_gl,chi_fl,chi_gr,chi_fr,de,fguess,gg_norm)
        if (ier /= 0) then
           write(IFLOG,*) '### ERROR ### in guess_de' ; go to 99
        end if

        if (de > 0.d0) then
           ee_lower_limit = ee
        else if (de < 0.d0) then
           ee_upper_limit = ee
           if (ee_upper_limit > ee_upper_limit_in) then
              ee_upper_limit = ee_upper_limit_in
           end if
        end if

        etest = ee + de
        if ((etest-ee_upper_limit)*(etest-ee_lower_limit) < 0.d0) then
           ee = etest
        else
           ee = 0.5d0*(ee_upper_limit + ee_lower_limit)
           num_eslides = num_eslides + 1
        end if

        write(IFLOG,'(1x,a21,2i5,f25.15,1pe20.10)') &
             'SS: iss,ll,ee,de ...',iss,ll,ee,de

     end do SRCH_EE

     if (is_solve_ss(iss) /= 0) then
        engy_ss(iss) = ee
     else
        engy_ss(iss) = 0.d0
     end if

     if (is_solve_ss(iss) /= 0) then
        do ir = 1,nrm
           rphi_ss(ir,iss) = chi_gl(ir)
        end do
        do ir = nrm,nmesh
           rphi_ss(ir,iss) = chi_gr(ir)
        end do

     else
        rphi_ss(:,iss) = 0.d0
     end if

     if (is_solve_ss(iss) /= 0) then

        call calc_beta_phi_ss_kt(ier,iss)

        sum = 0.d0
        do ir = 1,nmesh
           sum = sum + rphi_ss(ir,iss)**2*wr(ir)
        end do

        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)

              sum = sum + q_sum_us(ltt) &
                   * beta_phi_ss(lt1,iss) &
                   * beta_phi_ss(lt2,iss)
           end do
        end do

        rphi_ss(:,iss) = rphi_ss(:,iss)/sqrt(sum)*sign_gr
        call calc_beta_phi_ss_kt(ier,iss)

     else
        beta_phi_ss(:,iss) = 0.d0
     end if

     do ir = 1,nmesh
        if (abs(rphi_ss(ir,iss)) < 1.d-99) then
           rphi_ss(ir,iss) = 0.d0
        end if
     end do

     !++++++++++++++++++++++++++++++++++++++++++++++++++++++++++++++
     deallocate(amat,bvec,coeff,fmat,hmat,h0vec,rphi_gl,dxrphi_gl)
     !++++++++++++++++++++++++++++++++++++++++++++++++++++++++++++++
  end do L_SS

99 continue

  !+++++++++++++++++
  deallocate(bsum)
  !+++++++++++++++++

end subroutine calc_bound_state_ss_kt
! ============================================================================== 4.0

!=====================================================================
   subroutine set_initpoints_right_sol(ier, &
              nmesh,nmesh_max,ll,ee,rpos,g,f,dxg,dxf,vloc,bsum,sign_g)
!=====================================================================
!
!  M. Okamoto
!
!---------------------------------------------------------------------
   implicit none
   integer,intent(in)  :: nmesh_max, nmesh, ll
   real(8),intent(in)  :: sign_g, ee, rpos(nmesh), vloc(nmesh), &
                          bsum(nmesh)
   integer,intent(out) :: ier
   real(8),intent(out) :: g(nmesh), f(nmesh), &
                          dxg(nmesh), dxf(nmesh)
   integer :: ir
   real(8) :: vv, ss, r
   ier = 0
   vv = vloc(nmesh_max)
   ss = sqrt(2.d0*abs(ee-vv))
   do ir = nmesh_max-10,nmesh_max
      r  = rpos(ir)
      g(ir) = exp(-ss*r) * sign_g
      f(ir) = -ss * g(ir)
      call dgdx_dfdx_sol(rpos(ir),g(ir),f(ir),dxg(ir),dxf(ir), &
                         ll,ee,vloc(ir),bsum(ir))
   end do
99 continue
   end subroutine set_initpoints_right_sol

!=====================================================================
   subroutine int_from_right_sol(ier,nmesh,nmesh_max,nrt, &
              ll,ee,nec,dx,rpos,g,f,dxg,dxf,vloc,bsum)
!=====================================================================
!
!  M. Okamoto
!
!---------------------------------------------------------------------
   implicit none
   integer,intent(in)    :: nmesh, nmesh_max, nrt, ll, nec
   real(8),intent(in)    :: ee, dx, &
                            rpos(nmesh), vloc(nmesh), bsum(nmesh)
   real(8),intent(inout) :: g(nmesh), f(nmesh), &
                            dxg(nmesh), dxf(nmesh)
   integer,intent(out)   :: ier
   integer :: ir, id
   ier =  0
   id  = -1
   do ir = nmesh_max-3,nrt-1,-1
      call pc_adams_5_sol(ier, &
              nmesh,ir,id,ll,ee,nec,dx,rpos, &
              g,f,dxg,dxf,vloc,bsum)
   end do
99 continue
   end subroutine int_from_right_sol

!=====================================================================
   subroutine guess_de_sol(ier,ifile, &
      nmesh,nrm,rpos,wt,gl,fl,gr,fr,de,fguess,gg_norm)
!=====================================================================
!
!  M. Okamoto
!
!---------------------------------------------------------------------
   implicit none
   integer,intent(in)    :: nrm, nmesh, ifile
   real(8),intent(in)    :: rpos(nmesh),fguess, &
                            gl(nmesh), fl(nmesh), gr(nmesh), fr(nmesh)
   real(8),intent(inout) :: wt(nmesh)
   integer,intent(out)   :: ier
   real(8),intent(out)   :: de, gg_norm
   integer :: ir
   real(8) :: sum1, sum2
   ier = 0
   call set_weight_exp(ier,1,nrm,rpos,wt)
   if (ier /= 0) then
      write(ifile,*) '### ERROR ### in set_weight_exp(1)' ; go to 99
   end if
   sum1 = 0.d0
   do ir = 1,nrm
      sum1 = sum1 + gl(ir)**2*wt(ir)
   end do
   call set_weight_exp(ier,nrm,nmesh,rpos,wt)
   if (ier /= 0) then
      write(ifile,*) '### ERROR ### in set_weight_exp(2)' ; go to 99
   end if
   sum2 = 0.d0
   do ir = nrm,nmesh
      sum2 = sum2 + gr(ir)**2*wt(ir)
   end do
   gg_norm = sum1 + sum2
   de = 0.5d0 * gl(nrm) * (fl(nrm) - fr(nrm)) / gg_norm * fguess
99 continue
   end subroutine guess_de_sol

!=====================================================================
   subroutine calc_beta_phi_sol(ier,ips)
!=====================================================================
!
!  M. Okamoto
!
!---------------------------------------------------------------------
   use parameters
   implicit none
   integer,intent(in)  :: ips
   integer,intent(out) :: ier
   integer :: ir, ishell, ll, nref, tt, lt
   real(8) :: sum
   ier = 0
   beta_phi_sol(:,ips) = 0.d0
   ishell = ishell_ps(ips,1)
   ll = l_qnum(ishell)
   nref = nref_us(ll)
   do tt = 1,nref
      lt = lt_n_us(ll,tt)
      if (ll == lloc) then
         sum = 1.d0
      else
         sum = 0.d0
         do ir = 1,nmesh
            sum = sum &
                + wr(ir) * rbeta_us(ir,lt) * rphi_sol(ir,ips)
         end do
      end if
      beta_phi_sol(lt,ips) = sum
   end do
99 continue
   end subroutine calc_beta_phi_sol

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

  integer,intent(in)  :: ips
  integer,intent(out) :: ier
  integer :: ir, ishell, ll, nref, tt, lt
  integer :: ispin, itmp1

  real(8) :: sum

  ier = 0
  beta_phi_sol(:,ips) = 0.d0
  ishell = ishell_ps(ips,1)
  ll = l_qnum(ishell)
  nref = nref_us(ll)

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

  do tt = 1,nref
     itmp1 = tt + nref_max_us *( ispin - 1 )

     lt = lt_n_us(ll,itmp1)
     if (ll == lloc) then
        sum = 1.d0
     else
        sum = 0.d0
        do ir = 1,nmesh
           sum = sum &
                + wr(ir) * rbeta_us(ir,lt) * rphi_sol(ir,ips)
        end do
     end if
     beta_phi_sol(lt,ips) = sum
  end do

99 continue

end subroutine calc_beta_phi_sol_kt
! ======================================================================== 4.0

!=====================================================================
   subroutine calc_beta_phi_ss(ier,iss)
!=====================================================================
!
!  M. Okamoto
!
!---------------------------------------------------------------------
   use parameters
   implicit none
   integer,intent(in)  :: iss
   integer,intent(out) :: ier
   integer :: ir, ishell, ll, nref, tt, lt
   real(8) :: sum
   ier = 0
   beta_phi_ss(:,iss) = 0.d0
   ishell = ishell_ss(iss)
   ll = l_qnum(ishell)
   nref = nref_us(ll)
   do tt = 1,nref
      lt = lt_n_us(ll,tt)
      if (ll == lloc) then
         sum = 1.d0
      else
         sum = 0.d0
         do ir = 1,nmesh
            sum = sum &
                + wr(ir) * rbeta_us(ir,lt) * rphi_ss(ir,iss)
         end do
      end if
      beta_phi_ss(lt,iss) = sum
   end do
99 continue
   end subroutine calc_beta_phi_ss

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

  integer,intent(in)  :: iss
  integer,intent(out) :: ier
  integer :: ir, ishell, ll, nref, tt, lt

  integer :: ispin, itmp1
  real(8) :: sum

  ier = 0

  beta_phi_ss(:,iss) = 0.d0

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

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

  do tt = 1,nref
     itmp1 = tt + nref_max_us *( ispin - 1 )

     if ( nspin == 1 ) then
        itmp1 = tt
     endif
     
     lt = lt_n_us(ll,itmp1)

     if (ll == lloc) then
        sum = 1.d0
     else
        sum = 0.d0
        do ir = 1,nmesh
           sum = sum &
                + wr(ir) * rbeta_us(ir,lt) * rphi_ss(ir,iss)
        end do
     end if
     beta_phi_ss(lt,iss) = sum
  end do

99 continue

end subroutine calc_beta_phi_ss_kt
! ========================================================================= 4.0

!=====================================================================
   subroutine set_initpoints_left_sol(ier, &
              nmesh,ll,ee,rpos,g,f,dxg,dxf,vloc,bsum)
!=====================================================================
!
!  M. Okamoto
!
!---------------------------------------------------------------------
   implicit none
   integer,intent(in)  :: ll, nmesh
   real(8),intent(in)  :: ee, rpos(nmesh), vloc(nmesh), bsum(nmesh)
   integer,intent(out) :: ier
   real(8),intent(out) :: g(nmesh), f(nmesh), &
                          dxg(nmesh), dxf(nmesh)
   integer :: ir
   ier = 0
   do ir = 1,10
      g(ir) = rpos(ir)**(ll+1)
      f(ir) = 0.d0
      call dgdx_dfdx_sol(rpos(ir),g(ir),f(ir),dxg(ir),dxf(ir), &
                         ll,ee,vloc(ir),bsum(ir))
   end do
   end subroutine set_initpoints_left_sol

!=====================================================================
   subroutine int_from_left_sol(ier,nmesh,node_sum,nrt, &
              ll,ee,nec,dx,rpos,g,f,dxg,dxf,vloc,bsum)
!=====================================================================
!
!  M. Okamoto
!
!---------------------------------------------------------------------
   implicit none
   integer,intent(in)    :: nrt, ll, nec, nmesh
   real(8),intent(in)    :: ee, dx, &
                            rpos(nmesh), vloc(nmesh), bsum(nmesh)
   real(8),intent(inout) :: g(nmesh), f(nmesh), &
                            dxg(nmesh), dxf(nmesh)
   integer,intent(out)   :: ier, node_sum
   integer :: id, ir
   ier = 0
   id = +1
   node_sum = 0
   do ir = 4,nrt+1
      call pc_adams_5_sol(ier, &
              nmesh,ir,id,ll,ee,nec,dx,rpos, &
              g,f,dxg,dxf,vloc,bsum)
      if (g(ir)*g(ir-1) < 0.d0) then
         node_sum = node_sum + 1
      end if
   end do
99 continue
   end subroutine int_from_left_sol

!=====================================================================
   subroutine pc_adams_5_sol(ier, &
              nmesh,ir,id,ll,ee,nec,dx,rpos,g,f,dxg,dxf,vloc,bsum)
!=====================================================================
!
!  M. Okamoto
!
!---------------------------------------------------------------------
   implicit none
   integer,intent(in)    :: ir, ll, nec, nmesh
   real(8),intent(in)    :: ee, dx, &
                            rpos(nmesh), vloc(nmesh), bsum(nmesh)
   integer,intent(inout) :: id
   real(8),intent(inout) :: g(nmesh), f(nmesh), &
                            dxg(nmesh), dxf(nmesh)
   integer,intent(out)   :: ier
   integer :: iec
   real(8) :: dx24, &
              g0, g1, g2, g3, dg0, dg1, dg2, dg3, g9, dg9, &
              f0, f1, f2, f3, df0, df1, df2, df3, f9, df9
   ier = 0
   id   = sign(1,id)
   dx24 = dx / 24.d0 * dble(id)
   select case (id)
   case(+1)
      g0  =   g(ir     ) ; f0  =   f(ir     )
      g1  =   g(ir-1*id) ; f1  =   f(ir-1*id)
      g2  =   g(ir-2*id) ; f2  =   f(ir-2*id)
      g3  =   g(ir-3*id) ; f3  =   f(ir-3*id)
      dg0 = dxg(ir     ) ; df0 = dxf(ir     )
      dg1 = dxg(ir-1*id) ; df1 = dxf(ir-1*id)
      dg2 = dxg(ir-2*id) ; df2 = dxf(ir-2*id)
      dg3 = dxg(ir-3*id) ; df3 = dxf(ir-3*id)
   case(-1)
      g0  =   g(ir     ) ; f0  =   f(ir     )
      g1  =   g(ir-1*id) ; f1  =   f(ir-1*id)
      g2  =   g(ir-2*id) ; f2  =   f(ir-2*id)
      g3  =   g(ir-3*id) ; f3  =   f(ir-3*id)
      dg0 = dxg(ir     ) ; df0 = dxf(ir     )
      dg1 = dxg(ir-1*id) ; df1 = dxf(ir-1*id)
      dg2 = dxg(ir-2*id) ; df2 = dxf(ir-2*id)
      dg3 = dxg(ir-3*id) ; df3 = dxf(ir-3*id)
   end select
   g9 = g0 + dx24 * (55.d0*dg0 - 59.d0*dg1 + 37.d0*dg2 - 9.d0*dg3)
   f9 = f0 + dx24 * (55.d0*df0 - 59.d0*df1 + 37.d0*df2 - 9.d0*df3)
   do iec = 1,nec
      call dgdx_dfdx_sol(rpos(ir+id),g9,f9,dg9,df9, &
                         ll,ee,vloc(ir+id),bsum(ir+id))
      g9 = g0 + dx24 * (9.d0*dg9 + 19.d0*dg0 - 5.d0*dg1 + dg2)
      f9 = f0 + dx24 * (9.d0*df9 + 19.d0*df0 - 5.d0*df1 + df2)
   end do
   call dgdx_dfdx_sol(rpos(ir+id),g9,f9,dg9,df9, &
                      ll,ee,vloc(ir+id),bsum(ir+id))
   select case (id)
   case(+1)
        g(ir+id) =  g9 ;   f(ir+id) =  f9
      dxg(ir+id) = dg9 ; dxf(ir+id) = df9
   case(-1)
        g(ir+id) =  g9 ;   f(ir+id) =  f9
      dxg(ir+id) = dg9 ; dxf(ir+id) = df9
   end select
   end subroutine pc_adams_5_sol

!=====================================================================
   subroutine write_energy_level_sol(ifile)
!=====================================================================  
!
!  M. Okamoto
!
!---------------------------------------------------------------------
   use parameters
   implicit none
   integer,intent(in) :: ifile
   integer        :: i, nn, ll, lshell, ips, lps
   character(100) :: line, buffer
   do i = 1,100
      line(i:i)='-'
   end do
   write(ifile,*)
      read(atom_label(zatom),*) buffer
   write(ifile,*) 'eng  Energy levels for the present PP [Solved]'
   write(ifile,*) 'eng  Element ---> ',buffer(1:3)

   write(ifile,10) line(1:100)
   write(ifile,11) 'symm', &
                   'Energy (Ha)','Energy (eV)','nocc','focc'
   write(ifile,10) line(1:100)
   do ips = 1,nps
      lps = list_sol(ips)
      lshell = ishell_ps(lps,1)
      if (is_solve(lshell) == 0) then
         cycle
      end if
      nn = n_qnum(lshell)
      ll = l_qnum(lshell)
      write(ifile,12) state(lshell)(1:2), &
         engy_sol(lps),engy_sol(lps)*HARTREE,nocc(lshell),focc_sol(lps)
   end do
   write(ifile,10) line(1:100)
   write(ifile,13) 'Total number of electrons',felec_sol
   write(ifile,10) line(1:100)
10 format(1x,'eng',a65)
11 format(1x,'eng',(3x,a4),2(9x,a11),(2x,a4),(6x,a4))
12 format(1x,'eng',(4x,a2,1x),2(f20.10),i6,f10.5)
13 format(1x,'eng',2x,a25,26x,f10.5)
   end subroutine write_energy_level_sol

!========================================= added by K. T. ======== 4.0
subroutine write_energy_level_sol_kt(ifile)
  use parameters
  implicit none

  integer,intent(in) :: ifile
  integer        :: i, nn, ll, lshell, ips, lps
  character(100) :: line, buffer

  real(8) :: felec1_tmp, felec2_tmp

  do i = 1,100
     line(i:i)='-'
  end do

  write(ifile,*)
  read(atom_label(zatom),*) buffer
  write(ifile,*) 'eng  Energy levels for the present PP [Solved]'
  write(ifile,*) 'eng  Element ---> ',buffer(1:3)
  
  if ( nspin == 1 ) then
     write(ifile,10) line(1:100)
     write(ifile,11) 'symm', &
          'Energy (Ha)','Energy (eV)','nocc','focc'
     write(ifile,10) line(1:100)
     
     do ips = 1,nps
        lps = list_sol(ips)
        lshell = ishell_ps(lps,1)
        
        if (is_solve(lshell) == 0) then
           cycle
        end if
        
        nn = n_qnum(lshell)
        ll = l_qnum(lshell)
        
        write(ifile,12) state(lshell)(1:2), &
             engy_sol(lps),engy_sol(lps)*HARTREE,nocc(lshell),focc_sol(lps)
     end do
     
     write(ifile,10) line(1:100)
     write(ifile,13) 'Total number of electrons',felec_sol
     write(ifile,10) line(1:100)
     
10   format(1x,'eng',a65)
11   format(1x,'eng',(3x,a4),2(9x,a11),(2x,a4),(6x,a4))
12   format(1x,'eng',(4x,a2,1x),2(f20.10),i6,f10.5)
13   format(1x,'eng',2x,a25,26x,f10.5)

  else if ( nspin == 2 ) then

     write(ifile,20) line(1:100)
     write(ifile,21) 'symm', 's', &
          'Energy (Ha)','Energy (eV)','nocc','focc'
     write(ifile,20) line(1:100)
     
     do ips = 1,nps
        lps = list_sol(ips)
        lshell = ishell_ps(lps,1)
        
        if (is_solve(lshell) == 0) then
           cycle
        end if
        
        nn = n_qnum(lshell)
        ll = l_qnum(lshell)
        
        write(ifile,22) state(lshell)(1:2), spin_label(lshell), &
             engy_sol(lps),engy_sol(lps)*HARTREE,nocc(lshell),focc_sol(lps)
     end do
!
! ----------------------------------------------------------
     felec1_tmp = 0
     felec2_tmp = 0
     Do ips=1, nps
        lps = list_sol(ips);   lshell = ishell_ps(lps,1)
        if ( spin(lshell) == 1 ) then
           felec1_tmp = felec1_tmp + focc_sol(lps)
        else
           felec2_tmp = felec2_tmp + focc_sol(lps)
        endif
     End do
! ----------------------------------------------------------
     write(ifile,20) line(1:100)
     write(ifile,23) 'Number of electrons (+)',felec1_tmp
     write(ifile,23) '                    (-)',felec2_tmp
     write(ifile,20) line(1:100)
     
20   format(1x,'eng',a70)
21   format(1x,'eng',(3x,a4),(4x,a1),2(9x,a11),(2x,a4),(6x,a4))
22   format(1x,'eng',(4x,a2,1x),(4x,a1),2(f20.10),i6,f10.5)
23   format(1x,'eng',2x,a23,33x,f10.5)

  endif

end subroutine write_energy_level_sol_kt

!=====================================================================
   subroutine write_energy_level_ss(ifile)
!=====================================================================  
!
!  M. Okamoto
!
!---------------------------------------------------------------------
   use parameters
   implicit none
   integer,intent(in) :: ifile
   integer        :: i, nn, ll, ishell, iss, lss, lshell
   character(100) :: line, buffer
   do i = 1,100
      line(i:i)='-'
   end do
   write(ifile,*)
      read(atom_label(zatom),*) buffer
   write(ifile,*) 'eng  Energy levels for the present PP [Solved]'
   write(ifile,*) 'eng  Element ---> ',buffer(1:3)

   select case (is_spin_ss)

   case (RESTRICTED)
   write(ifile,10) line(1:100)
   write(ifile,11) 'symm', &
                   'Energy (Ha)','Energy (eV)','nocc','focc'
   write(ifile,10) line(1:100)
   do iss = 1,nss
      ishell = ishell_ss(iss)
      if (is_solve_ss(iss) == 0) then
         cycle
      end if
      nn = n_qnum(ishell)
      ll = l_qnum(ishell)
      write(ifile,12) state(ishell)(1:2), &
         engy_ss(iss),engy_ss(iss)*HARTREE,nocc_ss(iss),focc_ss(iss)
   end do
   write(ifile,10) line(1:100)
   write(ifile,13) 'Total number of electrons',felec_ss
   write(ifile,10) line(1:100)
10 format(1x,'eng',a65)
11 format(1x,'eng',(3x,a4),2(9x,a11),(2x,a4),(6x,a4))
12 format(1x,'eng',(4x,a2,1x),2(f20.10),i6,f10.5)
13 format(1x,'eng',2x,a25,26x,f10.5)

   case (POLARIZED)
   write(ifile,20) line(1:100)
   write(ifile,21) 'symm','s', &
                   'Energy (Ha)','Energy (eV)','nocc','focc'
   write(ifile,20) line(1:100)
   do iss = 1,nss
      lss = list_ss(iss)
      lshell = ishell_ss(lss)
      if (is_solve_ss(lss) == 0) then
         cycle
      end if
      nn = n_qnum(lshell)
      ll = l_qnum(lshell)
      write(ifile,22) state(lshell)(1:2),spin_label_ss(lss)(1:1), &
         engy_ss(lss),engy_ss(lss)*HARTREE,nocc_ss(lss),focc_ss(lss)
   end do
   write(ifile,20) line(1:100)
   write(ifile,23) 'Number of electrons (+)',felec1_ss
   write(ifile,23) '                    (-)',felec2_ss
   write(ifile,20) line(1:100)
20 format(1x,'eng',a70)
21 format(1x,'eng',(3x,a4),(4x,a1),2(9x,a11),(2x,a4),(6x,a4))
22 format(1x,'eng',(4x,a2,1x),(4x,a1),2(f20.10),i6,f10.5)
23 format(1x,'eng',2x,a23,33x,f10.5)
   end select
   end subroutine write_energy_level_ss
