! ************************************************************* 
!
!   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_bhs_pp_rel, write_param_bhs, find_nrc_bhs,
!                  calc_bound_state_bhs, calc_vh_bhs, calc_vxc_exc_bhs,
!                  calc_drho_ddrho_ps
!  Function(s)   : fn_bhs_cutoff
!  Author(s)     : Masakuni Okamoto (May 22, 2007)
!
!  The license of the code and contact address :
!  See the files, COPYRIGHT and LICENSE (or LICENSE_J.pdf)
!
!=====================================================================
   subroutine calc_bhs_pp_rel(ier)
!=====================================================================
!
!  M. Okamoto
!
!---------------------------------------------------------------------
   use parameters
   implicit none
   integer,intent(out) :: ier
   integer :: ips, iso, ishell, ll, kk, i, ir, is_solved, node, nrm, &
              loop, ntries, is_converged
   real(8) :: ff, fn_bhs_cutoff, rf, w1rf_sum, rfrf_sum
   real(8) :: cc(3), ee(3), gg, dd, tmp, rr, ee_check, eps_conv, arg
   real(8),allocatable :: vv1(:), vv2(:), ww1(:), ww2(:), ww_check(:)
   real(8),parameter :: EPS = 1.d-8
   real(8),parameter :: LAMBDA = 3.5d0, EPS_EIGEN = 1.d-13
   integer,parameter :: MAXLOOP = 50, MAXTRIES = 3
  !+++++++++++++++++++++++++++++++++++++++++++++++++++++++++++++++++++++++
   allocate(vv1(nmesh),vv2(nmesh),ww1(nmesh),ww2(nmesh),ww_check(nmesh))
      vv1 = 0.d0 ; vv2 = 0.d0 ; ww1 = 0.d0 ; ww2 = 0.d0 ; ww_check = 0.d0
  !+++++++++++++++++++++++++++++++++++++++++++++++++++++++++++++++++++++++

! ==================================== modified by K. T. ========== 4.0
!   rho_ps(:) = 0.d0
   rho_ps = 0.d0
! ================================================================ 4.0
   chi_ps(:,:,:) = 0.d0
   veff_ps(:,:,:) = 0.d0

   do ips = 1,nps
   do iso = 1,num_so_ps(ips)
      ishell = ishell_ps(ips,iso)
      ll = l_qnum(ishell)
      if (is_solve(ishell) /= 0) then
         call write_param_bhs(ier,IFLOG,ips,iso)
         ntries = 0
         is_converged = NO
         eps_conv = EPS
         do while ((ntries < MAXTRIES).and.(is_converged == NO))
            ntries = ntries + 1
            cc(1) = -200.d0 ; cc(3) = 200.d0 ; cc(2) = (cc(1) + cc(3)) * 0.5d0
            ee(:) = cc(:)
            loop = 0
            do while ((abs(ee(2) - engy(ishell)) > eps_conv).and.(loop < MAXLOOP))
               loop = loop + 1
               write(IFLOG,'(1x,a27,7f15.10)') 'BHS_CCC: c1,c2,c3,e1,e2,e3,ee', &
                  cc(:),ee(:),engy(ishell)
               do i = 1,3
                  do ir = 1,nmesh
                     ff = fn_bhs_cutoff(rpos(ir)/rcut_phi_ps(ips,1))
                     vv1(ir) = veff(ir,nspin,lmax_core)*(1.d0 - ff) + cc(i)*ff
                  end do
                  node = 0
                  call calc_bound_state_bhs(ier,IFLOG, &
                     iord_pc,iord_nec,iord_diff,dx,EPS_EIGEN, &
                     nmesh,rpos,wr,vv1,ll,node, &
                     is_solved,ee(i),ww1)
                  if (ier /= 0) then
                     write(IFLOG,*) '### ERROR ### in calc_bound_state_bhs' ; go to 99
                  end if
               end do
               if (ee(2) < engy(ishell)) then
                  cc(1) = cc(2) ; cc(2) = (cc(1) + cc(3)) * 0.5d0
               else
                  cc(3) = cc(2) ; cc(2) = (cc(1) + cc(3)) * 0.5d0
               end if
            end do
            if (loop < MAXLOOP) then
               is_converged = YES
            else
               is_converged = NO
               eps_conv = eps_conv * 1.d2
            end if
         end do
         if (is_converged == NO) then
            write(IFLOG,*) 'LOOP for finding c0 was not converged. ll =',ll
            write(*,*) 'LOOP for finding c0 was not converged. ll =',ll
            stop
         end if
         write(IFLOG,*) 'BHS_C0: ll,ips,iso,cc(2) ...',ll,ips,iso,cc(2)
         write(IFLOG,*) 'BHS_C0: ee(2) - engy     ...',ee(2) - engy(ishell)
         write(IFLOG,*) 'BHS_C0: <w1|w1>          ...',sum(ww1(:)**2*wr(:))
         nrm = nrm_pos(ishell)
         gg = chi_g(nrm,ishell) / ww1(nrm)
         w1rf_sum = 0.d0
         rfrf_sum = 0.d0
         do ir = 1,nmesh
            ff = fn_bhs_cutoff(rpos(ir)/rcut_phi_ps(ips,1))
            rf = rpos(ir)**(ll+1) * ff
            w1rf_sum = w1rf_sum + ww1(ir)*rf*wr(ir)
            rfrf_sum = rfrf_sum + rf*rf*wr(ir)
         end do
         dd = - w1rf_sum + sqrt( &
               w1rf_sum*w1rf_sum - (1.d0 - 1.d0/(gg*gg)) * rfrf_sum )
         dd = dd / rfrf_sum
         do ir = 1,nmesh
            ff = fn_bhs_cutoff(rpos(ir)/rcut_phi_ps(ips,1))
            rf = rpos(ir)**(ll+1) * ff
            ww2(ir) = gg*( ww1(ir) + dd*rf )
         end do
         chi_ps(:,ips,iso) = ww2(:)

! ======================================== modified by K. T. ============ 4.0
!         rho_ps(:) = rho_ps(:) + focc(ishell)*ww2(:)**2
         rho_ps(:,1) = rho_ps(:,1) + focc(ishell)*ww2(:)**2
! ======================================================================== 4.0
         write(IFLOG,*) 'BHS_C0: gamma            ...',gg
         write(IFLOG,*) 'BHS_C0: delta            ...',dd
         write(IFLOG,*) 'BHS_C0: <w2|w2>          ...',sum(ww2(:)**2*wr(:))
         do ir = 1,nmesh
            ff = fn_bhs_cutoff(rpos(ir)/rcut_phi_ps(ips,1))
            rf = rpos(ir)**(ll+1) * ff
            rr = (rpos(ir)/rcut_phi_ps(ips,1))**LAMBDA
            tmp = LAMBDA*LAMBDA*rr*rr - LAMBDA*(2*ll + LAMBDA + 1)*rr
            vv2(ir) = vv1(ir) + dd*rf/ww2(ir) * ( &
               engy(ishell) - vv1(ir) + tmp/(2.d0*rpos(ir)*rpos(ir)) )
         end do
         veff_ps(:,ips,iso) = vv2(:)
         node = 0
         call calc_bound_state_bhs(ier,IFLOG, &
            iord_pc,iord_nec,iord_diff,dx,eps_de, &
            nmesh,rpos,wr,veff_ps(1,ips,iso),ll,node, &
            is_solved,ee_check,ww_check)
         if (ier /= 0) then
            write(IFLOG,*) '### ERROR ### in calc_bound_state_bhs'
            go to 99
         end if
         write(IFLOG,*) 'BHS_C0: engy             ...',engy(ishell)
         write(IFLOG,*) 'BHS_C0: ee_check         ...',ee_check
      end if
   end do
   end do

! =================================== modified by K. T. ================ 4.0
!   rho_ps(:) = rho_ps(:) / (4.d0*PI*rpos(:)**2)
!   write(IFLOG,*) 'BHS_C0: sum of rho_ps(:) ...',sum(4.d0*PI*rpos(:)**2*rho_ps(:)*wr(:))

   rho_ps(:,1) = rho_ps(:,1) / (4.d0*PI*rpos(:)**2)
   write(IFLOG,*) 'BHS_C0: sum of rho_ps(:) ...',sum(4.d0*PI*rpos(:)**2*rho_ps(:,1)*wr(:))
! ======================================================================= 4.0

   if (is_pcc == PCC) then
      select case (is_pcc_method)
      case (BHSPCC)
         write(IFLOG,*) 'PCC: using special PCC of the BHS type'
         write(IFSUM,*) 'PCC: using special PCC of the BHS type'
         do ir = 1,nmesh
            arg = a_bhspcc * rpos(ir) * rpos(ir)
            arg = min(arg,99.d0)
            rho_pcore(ir) = b_bhspcc * exp(-arg) / (4.d0*PI)
         end do
      case (POLYNOMIAL, SBESSEL)
         call calc_rho_pcore_sol(ier)
      end select
      if (ier /= 0) then
         write(IFLOG,*) '### ERROR ### in calc_rho_pcore_sol' ; go to 99
      end if
      !!!call check_rho_pcore_sol(ier)
      !!!call calc_pcc_fourier_sol(ier)
      !if (ier /= 0) then
      !   write(IFLOG,*) '### ERROR ### in calc_pcc_fourier_sol' ; go to 99
      !end if
   end if
  !++++++++++++++++++++++++++++++++++++++++++++++++++++++
   if (is_xc_class == GGA) then

! =================================== modified by K. T. =================== 4.0
!      allocate(drho_ps(nmesh),ddrho_ps(nmesh))
      allocate(drho_ps(nmesh,1),ddrho_ps(nmesh,1))
! ========================================================================= 4.0

      drho_ps = 0.d0 ; ddrho_ps = 0.d0

      allocate(drho_core(nmesh),ddrho_core(nmesh))
         drho_core = 0.d0 ; ddrho_core = 0.d0
      if (is_pcc == PCC) then
         allocate(drho_pcore(nmesh),ddrho_pcore(nmesh))
            drho_pcore = 0.d0 ; ddrho_pcore = 0.d0
      end if
   end if
  !++++++++++++++++++++++++++++++++++++++++++++++++++++++
   if (is_xc_class == GGA) then
      call calc_drho_ddrho_ps(ier)
   end if
   call calc_vh_bhs(ier,nmesh,rpos,rho_ps,vh_ps)
   if (ier /= 0) then
      write(IFLOG,*) '### ERROR ### in calc_vh_bhs' ; go to 99
   end if

! ================================================ modified by K. T. ========= 4.0
!   vx_ps(:) = 0.d0 ; vxpc_ps(:) = 0.d0
!   vc_ps(:) = 0.d0 ; vcpc_ps(:) = 0.d0
!   ex_ps(:) = 0.d0 ; expc_ps(:) = 0.d0
!   ec_ps(:) = 0.d0 ; ecpc_ps(:) = 0.d0
!
   vx_ps = 0.d0 ; vxpc_ps(:) = 0.d0
   vc_ps = 0.d0 ; vcpc_ps(:) = 0.d0
   ex_ps = 0.d0 ; expc_ps(:) = 0.d0
   ec_ps = 0.d0 ; ecpc_ps(:) = 0.d0
! ============================================================================= 4.0

   call calc_vxc_exc_bhs(ier)
   if (ier /= 0) then
      write(IFLOG,*) '### ERROR ### in calc_vxc_exc_bhs' ; go to 99
   end if
   vion_ps(:,:,:) = 0.d0
   do ips = 1,nps
   do iso = 1,num_so_ps(ips)
      vion_ps(:,ips,iso) = veff_ps(:,ips,iso) &
! ================================================ modified by K. T. ========= 4.0
!         - vh_ps(:) - vx_ps(:) - vc_ps(:)
         - vh_ps(:) - vx_ps(:,1) - vc_ps(:,1)
! ============================================================================ 4.0
   end do
   end do
   vscr_bhs(:,:) = 0.d0
   vion_bhs(:,:) = 0.d0
   vso_bhs(:,:)  = 0.d0
   do ips = 1,nps
      do iso = 1,num_so_ps(ips)
         ishell = ishell_ps(ips,iso)
         ll = l_qnum(ishell)
         kk = k_qnum(ishell)
         if (ll == 0) then
            vscr_bhs(:,ips) = veff_ps(:,ips,iso)
            vion_bhs(:,ips) = vion_ps(:,ips,iso)
            vso_bhs (:,ips) = 0.d0
         else if (kk < 0) then
            vscr_bhs(:,ips) = vscr_bhs(:,ips) + veff_ps(:,ips,iso)*dble(ll+1)
            vion_bhs(:,ips) = vion_bhs(:,ips) + vion_ps(:,ips,iso)*dble(ll+1)
            vso_bhs (:,ips) = vso_bhs (:,ips) + vion_ps(:,ips,iso)*2.d0
         else
            vscr_bhs(:,ips) = vscr_bhs(:,ips) + veff_ps(:,ips,iso)*dble(ll)
            vion_bhs(:,ips) = vion_bhs(:,ips) + vion_ps(:,ips,iso)*dble(ll)
            vso_bhs (:,ips) = vso_bhs (:,ips) - vion_ps(:,ips,iso)*2.d0
         end if
      end do
      vscr_bhs(:,ips) = vscr_bhs(:,ips) / dble(2*ll+1)
      vion_bhs(:,ips) = vion_bhs(:,ips) / dble(2*ll+1)
      vso_bhs (:,ips) = vso_bhs (:,ips) / dble(2*ll+1)
   end do

  !+++++++++++++++++++++++++++++++++++++++++
   if (is_xc_class == GGA) then
      deallocate(drho_core,ddrho_core)
      if (is_pcc == PCC) then
         deallocate(drho_pcore,ddrho_pcore)
      end if
   end if
  !+++++++++++++++++++++++++++++++++++++++++
  !+++++++++++++++++++++++++++++++++++++
   deallocate(vv1,vv2,ww1,ww2,ww_check)
  !+++++++++++++++++++++++++++++++++++++
99 continue
   end subroutine calc_bhs_pp_rel
   
!=====================================================================
   subroutine write_param_bhs(ier,ifile,ips,iso)
!=====================================================================
!
!  M. Okamoto
!
!---------------------------------------------------------------------
   use parameters
   implicit none
   integer,intent(in)  :: ifile, ips, iso
   integer,intent(out) :: ier
   integer :: n1, l1, ishell, n2, l2, k2, jj
   real(8) :: psi2_sum, g2_sum, f2_sum, vmax, vmin
   ier = 0
   n1 = n_val_label_ps(ips)
   l1 = l_val_label_ps(ips)
   ishell = ishell_ps(ips,iso)
   n2 = n_qnum(ishell)
   l2 = l_qnum(ishell)
   k2 = k_qnum(ishell)
   jj = j2_qnum(ishell)
   write(ifile,*)
   write(ifile,*) 'ips,iso   ...',ips,iso
   write(ifile,*) 'n1,l1     ...',n1,l1
   write(ifile,*) 'n2,l2,k2  ...',n2,l2,k2
   write(ifile,*) '2*j       ...',jj
   write(ifile,*) 'ishell    ...',ishell
   write(ifile,*) 'focc      ...',focc(ishell)
   write(ifile,*) 'Rcut      ...',rcut_phi_ps(ips,1)
   write(ifile,*) 'Rcut (A)  ...',rcut_phi_ps(ips,1)*BOHR
   write(ifile,*) 'is_gen_ps ...',is_gen_ps(ips,iso)
   write(ifile,*) 'is_solve  ...',is_solve(ishell)
   write(ifile,*) 'E         ...',engy(ishell)
   write(ifile,*) 'E (eV)    ...',engy(ishell)*HARTREE
   g2_sum = sum(chi_g(:,ishell)**2*wr(:))
   f2_sum = sum(chi_f(:,ishell)**2*wr(:))
   psi2_sum = g2_sum + f2_sum
   !write(ifile,*) 'g2_sum    ...',g2_sum
   !write(ifile,*) 'f2_sum    ...',f2_sum
   write(ifile,*) 'psi2_sum  ...',psi2_sum
   write(ifile,*) 'nrm       ...',nrm_pos(ishell)
   write(ifile,*) 'Rm        ...',rpos(nrm_pos(ishell))
   write(ifile,*) 'Rm (A)    ...',rpos(nrm_pos(ishell))*BOHR
   vmax = maxval(veff(:,nspin,lmax_core))
   vmin = minval(veff(:,nspin,lmax_core))
   write(ifile,*) 'Vmax      ...',vmax
   write(ifile,*) 'Vmin      ...',vmin
   end subroutine write_param_bhs

!=====================================================================
   subroutine find_nrc_bhs(ier,nmesh,rpos,rcut,nrc)
!=====================================================================
!
!  M. Okamoto
!
!---------------------------------------------------------------------
   implicit none
   integer,intent(in)  :: nmesh
   real(8),intent(in)  :: rpos(nmesh), rcut
   integer,intent(out) :: ier, nrc
   integer :: ir
   ier = 0
   do ir = nmesh,10,-1
      if (rpos(ir) < rcut) then
         nrc = ir+1 ; exit
      end if
      if (ir == 10) then
         write(*,*) '### ERROR ### nrc was not found.'
         ier = 1 ; go to 99
      end if
   end do
99 continue
   end subroutine find_nrc_bhs

!=====================================================================
   function fn_bhs_cutoff(x)
!=====================================================================
!
!  M. Okamoto
!
!---------------------------------------------------------------------
   implicit none
   real(8) :: fn_bhs_cutoff
   real(8),intent(in) :: x
   real(8) :: arg
   real(8),parameter :: LAMBDA = 3.5d0
   arg = abs(x)**LAMBDA
   if (arg > 99.d0) then
      fn_bhs_cutoff = 0.d0
   else
      fn_bhs_cutoff = exp(-arg)
   end if
   end function fn_bhs_cutoff
   
!=====================================================================
   subroutine calc_bound_state_bhs(ier,IFLOG, &
                 iord_pc,iord_nec,iord_diff,dx,eps_de, &
                 nmesh,rpos,wr,vloc_scr,ll,node, &
                 is_solved,ee_solved,rphi_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, rphi_solved(nmesh)
   real(8),allocatable :: bsum(:), 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),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 ; 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
   is_solved      = 1
   ee_solved      = 0.d0
   rphi_solved(:) = 0.d0
   write(IFLOG,*) 'SOL-BHS: 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-BHS: 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
   bsum = 0.d0
   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)') &
        '### SBHS ### 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_solved(ir) = chi_gl(ir)
      end do
      do ir = nrm,nmesh
         rphi_solved(ir) = chi_gr(ir)
      end do
   else
      rphi_solved(:) = 0.d0
   end if
   if (is_solved /= 0) then
      sum = 0.d0
      do ir = 1,nmesh
         sum = sum + rphi_solved(ir)**2*wr(ir)
      end do
      rphi_solved(:) = rphi_solved(:)/sqrt(sum)*sign_gr
   end if
   do ir = 1,nmesh
      if (abs(rphi_solved(ir)) < 1.d-99) then
         rphi_solved(ir) = 0.d0
      end if
   end do
99 continue
  !++++++++++++++++++++++++++++++++++++++
   deallocate(bsum,wt, &
      chi_gl,chi_fl,dxchi_gl,dxchi_fl, &
      chi_gr,chi_fr,dxchi_gr,dxchi_fr)
  !++++++++++++++++++++++++++++++++++++++
   end subroutine calc_bound_state_bhs

!=====================================================================
   subroutine calc_vh_bhs(ier,nmesh,rpos,rho,vh)
!=====================================================================
!
!  M. Okamoto
!
!---------------------------------------------------------------------
   implicit none
   integer,intent(in)  :: nmesh
   real(8),intent(in)  :: rpos(nmesh), rho(nmesh)
   integer,intent(out) :: ier
   real(8),intent(out) :: vh(nmesh)
   integer :: ir, ii, i0, is, j, jr
   real(8) :: sum1, sum2
   real(8),allocatable :: wt(:)
   real(8),parameter :: &
      PI = 3.1415926535897932384626433832795028d0
   ier = 0
  !++++++++++++++++++++++++++++++++
   allocate(wt(nmesh)) ; wt = 0.d0
  !++++++++++++++++++++++++++++++++
   do ir = 1,nmesh
      sum1 = 0.d0
      sum2 = 0.d0
      if (ir == 1) then
         sum1 = 0.d0
      else if ((ir >= 2).and.(ir <= 5)) then
         do ii = 2,ir
            i0 = ii-1
            is = 1
            call set_open_weight_exp(ier,i0,is,rpos,wt)
            do j = 1,4
               sum1 = sum1 &
                  + rpos(i0+j*is)**2*rho(i0+j*is)*wt(i0+j*is)
            end do
         end do
      else
         call set_weight_exp(ier,1,ir,rpos,wt)
         do jr = 1,ir
            sum1 = sum1 + rpos(jr)**2*rho(jr)*wt(jr)
         end do
      end if
      sum1 = sum1*(4.d0*PI/rpos(ir))
      if (ir == nmesh) then
            sum2 = 0.d0
      else if ((ir <= nmesh-1).and.(ir >= nmesh-4)) then
         do ii = ir,nmesh-1
            i0 = ii+1
            is = -1
            call set_open_weight_exp(ier,i0,is,rpos,wt)
            do j = 1,4
               sum2 = sum2 &
                    - rpos(i0+j*is)**2*rho(i0+j*is)*wt(i0+j*is)
            end do
         end do
      else
         call set_weight_exp(ier,ir,nmesh,rpos,wt)
         do jr = ir,nmesh
            sum2 = sum2 + rpos(jr)*rho(jr)*wt(jr)
         end do
      end if
      sum2 = sum2*(4.d0*PI)
      vh(ir) = sum1 + sum2
   end do
  !+++++++++++++++
   deallocate(wt)
  !+++++++++++++++
99 continue
   end subroutine calc_vh_bhs

!=====================================================================
   subroutine calc_vxc_exc_bhs(ier)
!=====================================================================
!
!  M. Okamoto
!
!---------------------------------------------------------------------
   use parameters
   implicit none
   integer,intent(out) :: ier
  !++++++++++++++++++++++++++++++++++++++++++++++++++++++++++++++++++++

! ================================ modified by K. T. ================== 4.0
!   allocate(rho_sol(nmesh)) ; rho_sol = 0.d0
!   allocate(ex_sol(nmesh),ec_sol(nmesh),vx_sol(nmesh),vc_sol(nmesh))
!
   allocate(rho_sol(nmesh,1)) ; rho_sol = 0.d0
   allocate(ex_sol(nmesh),ec_sol(nmesh),vx_sol(nmesh,1),vc_sol(nmesh,1))
! ======================================================================= 4.0

   ex_sol = 0.d0 ; ec_sol = 0.d0
   vx_sol = 0.d0 ; vc_sol = 0.d0

   allocate( &
      expc_sol(nmesh),ecpc_sol(nmesh),vxpc_sol(nmesh),vcpc_sol(nmesh))
      expc_sol = 0.d0 ; ecpc_sol = 0.d0
      vxpc_sol = 0.d0 ; vcpc_sol = 0.d0

   if (is_xc_class == GGA) then
! ============================================ modified by K. T. ========== 4.0
!      allocate(drho_sol(nmesh),ddrho_sol(nmesh))
      allocate(drho_sol(nmesh,1),ddrho_sol(nmesh,1))
! =========================================================================== 4.0
         drho_sol = 0.d0 ; ddrho_sol = 0.d0
   end if
  !++++++++++++++++++++++++++++++++++++++++++++++++++++++++++++++++++++

! ======================================= modified by K. T. ================ 4.0
!   rho_sol(:) = rho_ps(:)
!  if (is_xc_class == GGA) then
!      drho_sol (:) = drho_ps (:)
!      ddrho_sol(:) = ddrho_ps(:)
!   end if
!
   rho_sol(:,:) = rho_ps(:,:)
   if (is_xc_class == GGA) then
      drho_sol (:,:) = drho_ps (:,:)
      ddrho_sol(:,:) = ddrho_ps(:,:)
   end if
! ============================================================================ 4.0

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

! ========================================= modified by K. T. ============ 4.0
!   vx_ps(:) = vx_sol(:)
!   vc_ps(:) = vc_sol(:)
   vx_ps(:,:) = vx_sol(:,:)
   vc_ps(:,:) = vc_sol(:,:)
! ========================================================================= 4.0

   ex_ps(:) = ex_sol(:)
   ec_ps(:) = ec_sol(:)

   vxpc_ps(:) = vxpc_sol(:)
   vcpc_ps(:) = vcpc_sol(:)
   expc_ps(:) = expc_sol(:)
   ecpc_ps(:) = ecpc_sol(:)
  !++++++++++++++++++++++++++++++++++++++++++++++++
   if (allocated(drho_sol)) then
      deallocate(drho_sol,ddrho_sol)
   end if
   deallocate(expc_sol,ecpc_sol,vxpc_sol,vcpc_sol)
   deallocate(ex_sol,ec_sol,vx_sol,vc_sol)
   deallocate(rho_sol)
  !++++++++++++++++++++++++++++++++++++++++++++++++
99 continue
   end subroutine calc_vxc_exc_bhs

!=====================================================================
   subroutine calc_drho_ddrho_ps(ier)
!=====================================================================
!
!  M. Okamoto
!
!---------------------------------------------------------------------
   use parameters
   implicit none
   integer,intent(out) :: ier
   integer :: ir
   ier = 0
   call calc_ddiff_exp(ier,iord_diff,nmesh,rpos, &
           rho_ps,drho_ps,ddrho_ps)
   call calc_ddiff_rho_origin(ier,iord_diff,nmesh, &
           rpos,rho_ps,drho_ps,ddrho_ps)
   do ir = nmesh-iord_diff*2-1,nmesh
! ========================================================== modified by K. T. ==== 4.0
!        rho_ps(ir) =   rho_ps(nmesh-iord_diff*2-2)
!       drho_ps(ir) =  drho_ps(nmesh-iord_diff*2-2)
!      ddrho_ps(ir) = ddrho_ps(nmesh-iord_diff*2-2)
!
        rho_ps(ir,1) =   rho_ps(nmesh-iord_diff*2-2,1)
       drho_ps(ir,1) =  drho_ps(nmesh-iord_diff*2-2,1)
      ddrho_ps(ir,1) = ddrho_ps(nmesh-iord_diff*2-2,1)
! ================================================================================ 4.0
   end do
99 continue
   end subroutine calc_drho_ddrho_ps

!=====================================================================
   subroutine write_bhspp(ier)
!=====================================================================
!
!  M. Okamoto
!
!---------------------------------------------------------------------
   use parameters
   implicit none
   integer,intent(out) :: ier
   integer :: ips, ishell, ll, ir
   character(1) :: fn_label_orbital
   ier = 0
   do ips = 1,nps
      if (is_gen_ps(ips,1) == 0) then
         cycle
      end if
      ishell = ishell_ps(ips,1)
      ll = l_qnum(ishell)
      bhsppfile = trim(jobname)//'_'//fn_label_orbital(ll)//'.bhspp'
      open(IFBHSPP,file=trim(bhsppfile),status='unknown')
      rewind(IFBHSPP)
      write(IFLOG,*) '   Writing BHSPP for l -->',ll
      write(IFBHSPP,10) 'BHS pseudopotential for valence-orbital ll =',ll
      write(IFBHSPP,20) 'r', 'r*psi', 'r*phi', 'rho_core', 'rho_pc', 'rho_pp', &
                        'vae_scr', 'vpp_scr', 'vpp_ion', 'vpp_so'
      do ir = 1,nmesh
         write(IFBHSPP,21) &
            rpos(ir), &
            chi_g(ir,ishell), &
            !chi_f(ir,ishell), &
            chi_ps(ir,ips,1), &
            !chi_ps(ir,ips,2), &
            rho_core(ir), &
            rho_pcore(ir), &

! ================================================== modified by K. T. ======= 4.0
!            rho_ps(ir), &
            rho_ps(ir,1), &
! =========================================================================== 4.0

            veff(ir,nspin,lmax_core), &
            vscr_bhs(ir,ips), &
            vion_bhs(ir,ips), &
            vso_bhs(ir,ips)
      end do
      write(IFLOG,*) 'BHSPP data have been saved into ... ',trim(bhsppfile)
      write(IFSUM,*) 'BHSPP data have been saved into ... ',trim(bhsppfile)
      close(IFBHSPP)
   end do
10 format('#',1x,a45,i5)
20 format(('#',18x,a1),2(15x,a5),(12x,a8),2(14x,a6),3(13x,a7),(14x,a6))
21 format(12(1pe20.10))
   end subroutine write_bhspp

!=====================================================================
   subroutine calc_rcut_bhs
!=====================================================================
!
!  M. Okamoto
!
!---------------------------------------------------------------------
   use parameters
   implicit none
   integer :: ips, ishell, iso, tt
   real(8) :: rsum
   do ips = 1,nps
      tt = 1
      if (is_gen_ps(ips,1) == 0) then
         cycle
      end if
      rsum = 0.d0
      do iso = 1,num_so_ps(ips)
         ishell = ishell_ps(ips,iso)
         rsum = rsum + rpos(nrm_pos(ishell))
      end do
      rsum = rsum / dble(num_so_ps(ips))
      rcut_phi_ps(ips,tt) = rsum / rcut_phi_ps(ips,tt)
   end do
   end subroutine calc_rcut_bhs

!=====================================================================
   subroutine write_rcut_bhs(ifile)
!=====================================================================
!
!  M. Okamoto
!
!---------------------------------------------------------------------
   use parameters
   implicit none
   integer,intent(in) :: ifile
   integer        :: i, ishell, ips, iso, tt
   real(8)        :: rcut
   character(100) :: line
   do i = 1,100
      line(i:i)='-'
   end do
   write(ifile,*)
   write(ifile,*) 'rcut  Cutoff radii for BHS-PP'
   write(ifile,10) line(1:100)
   write(ifile,11) 'symm','j', &
                   'rcut (Bohr)','   rcut (A)'
   write(ifile,10) line(1:100)
   do ips = 1,nps
      tt = 1
      !if (is_gen_ps(ips,1) == 0) then
      !   cycle
      !end if
      do iso = 1,num_so_ps(ips)
         ishell = ishell_ps(ips,iso)
         rcut = rcut_phi_ps(ips,tt)
         write(ifile,12) state(ishell)(1:2),j2_qnum(ishell), &
            rcut,rcut*BOHR
      end do
   end do
   write(ifile,10) line(1:100)
10 format(1x,'rcut',a55)
11 format(1x,'rcut',(3x,a4),(4x,a1,1x),2(9x,a11))
12 format(1x,'rcut',(4x,a2,1x),(3x,i1,'/2'),2(f20.10))
   end subroutine write_rcut_bhs
