!
!  Software name : CIAO (Code for Investigating Atomic Orbitals)
!  Subroutine(s) : calc_energy_kb, write_energy_kb, calc_local_level_kb
!                : check_ghost_states_kb, write_local_level_kb
!                : write_ghost_exists, write_ghost_none
!  Function(s)   : fn_ghost, fn_pm_sign
!  Author(s)     : Masakuni Okamoto (August 25, 2003)
!
!
!  Contact address :  Phase System Consortium
!                     E-mail: phase_system@nims.go.jp URL https://azuma.nims.go.jp
!
!
!  The license of the code and contact address :
!  See the files, COPYRIGHT and LICENSE (or LICENSE_J.pdf)
!
!=====================================================================
   subroutine calc_energy_kb(ier)
!=====================================================================
!
!  Calculates the Kleinman-Bylander energies
!
!  ### CAUTION ### 2006.08.23 M.O.
!  Temporarily, tt = 1 for veff_ps()
!
!  M. Okamoto
!
!---------------------------------------------------------------------
   use parameters
   implicit none
   integer,intent(out) :: ier
   integer :: ir, ips, jps
   real(8) :: sum1, sum2, dv_sl, eps
   real(8),allocatable :: vloc(:)
   ier = 0
   eps = 1.d-12
  !++++++++++++++++++++++++++++++++++++
   allocate(vloc(nmesh)) ; vloc = 0.d0
  !++++++++++++++++++++++++++++++++++++
   engy_kb(:,:) = 0.d0
   do jps = 0,nps
      if (jps == 0) then
! =============================================== modiifed by K. T. ========== 4.0
!         vloc(:) = vloc_scr_us(:)
         vloc(:) = vloc_scr_us(:,1)
! ============================================================================ 4.0
      else
         vloc(:) = veff_ps(:,jps,1)
      end if
      do ips = 1,nps
         sum1 = 0.d0
         sum2 = 0.d0
         do ir = 1,nmesh
            dv_sl = veff_ps(ir,ips,1) - vloc(ir)
            if (abs(dv_sl) < eps) then
               dv_sl = sign(eps,dv_sl)
            end if
            sum1 = sum1 + wr(ir) * chi_ps(ir,ips,1)**2 * dv_sl
            sum2 = sum2 + wr(ir) * chi_ps(ir,ips,1)**2 * dv_sl**2
         end do
         vrms_kb(ips,jps) = sqrt(sum2)
         cos_kb (ips,jps) = sum1 / sqrt(sum2)
         engy_kb(ips,jps) = sum2 / sum1
      end do
   end do
  !+++++++++++++++++
   deallocate(vloc)
  !+++++++++++++++++
99 continue
   end subroutine calc_energy_kb

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

  integer,intent(out) :: ier
  integer :: ir, ips, jps
  integer :: ispin, jspin
  
  real(8) :: sum1, sum2, dv_sl, eps
  real(8),allocatable :: vloc(:)

  ier = 0
  eps = 1.d-12

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

  engy_kb(:,:) = 0.d0
  
  do jps =1, nps+nspin
     
     jspin = 1 + mod(jps-1,nspin)
     if ( jps > nps ) then
        vloc(:) = vloc_scr_us(:,jspin)
     else
        vloc(:) = veff_ps(:,jps,1)
     end if
     
     do ips = 1,nps
        sum1 = 0.d0
        sum2 = 0.d0

        ispin = ( 1 -spin_index_ps(ips) )/2 +1

        if ( ispin /= jspin ) cycle

        do ir = 1,nmesh
           dv_sl = veff_ps(ir,ips,1) - vloc(ir)
           if (abs(dv_sl) < eps) then
              dv_sl = sign(eps,dv_sl)
           end if
           sum1 = sum1 + wr(ir) * chi_ps(ir,ips,1)**2 * dv_sl
           sum2 = sum2 + wr(ir) * chi_ps(ir,ips,1)**2 * dv_sl**2
        end do

        vrms_kb(ips,jps) = sqrt(sum2)
        cos_kb (ips,jps) = sum1 / sqrt(sum2)
        engy_kb(ips,jps) = sum2 / sum1
     end do
  end do

  !+++++++++++++++++
  deallocate(vloc)
  !+++++++++++++++++

99 continue
end subroutine calc_energy_kb_kt
! ============================================================================ 4.0

!=====================================================================
   subroutine write_energy_kb(ifile)
!=====================================================================
!
!  Writes the Kleinman-Bylander energies
!
!  M. Okamoto
!
!---------------------------------------------------------------------
   use parameters
   implicit none
   integer,intent(in) :: ifile
   integer :: ips, jps
   character(1) :: fn_label_orbital
   write(ifile,*)
   write(ifile,*) 'Kleinman-Bylander energies : E[KB](l,loc)'
   write(ifile,10) &
      (fn_label_orbital(l_qnum(ishell_ps(ips,1))),ips=1,nps)
   do jps = 1,nps
      write(ifile,20) &
         fn_label_orbital(l_qnum(ishell_ps(jps,1))), &
         (engy_kb(ips,jps),ips=1,nps)
   end do
   write(ifile,21) 'present',(engy_kb(ips,0),ips=1,nps)
   write(ifile,*)
   write(ifile,*) 'Kleinman-Bylander RMS : Vrms[KB](l,loc)'
   write(ifile,10) &
      (fn_label_orbital(l_qnum(ishell_ps(ips,1))),ips=1,nps)
   do jps = 1,nps
      write(ifile,20) &
         fn_label_orbital(l_qnum(ishell_ps(jps,1))), &
         (vrms_kb(ips,jps),ips=1,nps)
   end do
   write(ifile,21) 'present',(vrms_kb(ips,0),ips=1,nps)
   write(ifile,*)
   write(ifile,*) 'Kleinman-Bylander cosines : C[KB](l,loc)'
   write(ifile,10) &
      (fn_label_orbital(l_qnum(ishell_ps(ips,1))),ips=1,nps)
   do jps = 1,nps
      write(ifile,20) &
         fn_label_orbital(l_qnum(ishell_ps(jps,1))), &
         (cos_kb(ips,jps),ips=1,nps)
   end do
   write(ifile,21) 'present',(cos_kb(ips,0),ips=1,nps)
10 format(1x,7x,4(10x,a1,5x))
20 format(1x,3x,a1,3x,4f16.6)
21 format(1x,a7,4f16.6)
   end subroutine write_energy_kb

!================================== added by K. T ============================= 4.0
subroutine write_energy_kb_kt(ifile)
  use parameters

  implicit none
  integer,intent(in) :: ifile

  integer :: ips, jps, ispin
  character(1) :: fn_label_orbital

  write(ifile,*)
  write(ifile,*) 'Kleinman-Bylander energies : E[KB](l,loc)'

  Do ispin=1, nspin

     if ( nspin == 2 ) then
        write(ifile,*)

        if ( ispin == 1 ) then
           write(ifile,*) 'spin component : up'
        else if ( ispin ==2 ) then
           write(ifile,*) 'spin component : down'
        endif
     endif

     write(ifile,10) &
          (fn_label_orbital(l_qnum(ishell_ps(ips,1))),ips=ispin,nps,nspin )

     do jps =ispin, nps, nspin
        write(ifile,20) &
             fn_label_orbital(l_qnum(ishell_ps(jps,1))), &
             (engy_kb(ips,jps),ips=ispin,nps,nspin)
     end do

     write(ifile,21) 'present',(engy_kb(ips,nps+ispin),ips=ispin,nps,nspin)

  End do

  write(ifile,*)
  write(ifile,*) 'Kleinman-Bylander RMS : Vrms[KB](l,loc)'
  
  Do ispin=1, nspin

     if ( nspin == 2 ) then
        write(ifile,*)

        if ( ispin == 1 ) then
           write(ifile,*) 'spin component : up'
        else if ( ispin ==2 ) then
           write(ifile,*) 'spin component : down'
        endif
     endif

     write(ifile,10) &
          (fn_label_orbital(l_qnum(ishell_ps(ips,1))),ips=ispin,nps,nspin)

     do jps =ispin, nps, nspin
        write(ifile,20) &
             fn_label_orbital(l_qnum(ishell_ps(jps,1))), &
             (vrms_kb(ips,jps),ips=ispin,nps,nspin)
     end do

     write(ifile,21) 'present',(vrms_kb(ips,nps+ispin),ips=ispin,nps,nspin)

  End do

  write(ifile,*)
  write(ifile,*) 'Kleinman-Bylander cosines : C[KB](l,loc)'

  Do ispin=1, nspin

     if ( nspin == 2 ) then
        write(ifile,*)

        if ( ispin == 1 ) then
           write(ifile,*) 'spin component : up'
        else if ( ispin ==2 ) then
           write(ifile,*) 'spin component : down'
        endif

     endif

     write(ifile,10) &
          (fn_label_orbital(l_qnum(ishell_ps(ips,1))),ips=ispin,nps,nspin)

     do jps = ispin, nps, nspin
        write(ifile,20) &
             fn_label_orbital(l_qnum(ishell_ps(jps,1))), &
             (cos_kb(ips,jps),ips=ispin,nps,nspin)
     end do
     write(ifile,21) 'present',(cos_kb(ips,nps+ispin),ips=ispin,nps,nspin)
  End do

10 format(1x,7x,4(10x,a1,5x))
20 format(1x,3x,a1,3x,4f16.6)
21 format(1x,a7,4f16.6)

end subroutine write_energy_kb_kt
! ========================================================================= 4.0

!=====================================================================
   subroutine calc_local_level_kb(ier)
!=====================================================================
!
!  Calculates the Kleinman-Bylander local energy levels
!
!  M. Okamoto
!
!---------------------------------------------------------------------
   use parameters
   implicit none
   integer,intent(out) :: ier
   integer :: ips, node, ie, ishell, ll
   ier = 0
   do ips = 1,nps
      ishell = ishell_ps(ips,1)
      ll = l_qnum(ishell)
      do ie = 1,ne_kb
         node = ie - 1
         if (ie > 1) then
            if (is_solved_kb(ie-1,ips) == 0) then
               is_solved_kb(ie,ips) = 0
               ee_local_kb(ie,ips) = 0.d0
               cycle
            end if
         end if
         call calc_bound_state_loc(ier,IFLOG, &
              iord_pc,iord_nec,iord_diff,dx,eps_de, &
              nmesh,rpos,wr,vloc_scr_us,ll,node,ee_local_kb(ie,ips), &
              is_solved_kb(ie,ips))
         if (ier /= 0) then
            write(IFLOG,*) '### ERROR ### in calc_bound_state_loc'
            go to 99
         end if
      end do
   end do
99 continue
   end subroutine calc_local_level_kb

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

  integer,intent(out) :: ier

  integer :: ips, node, ie, ishell, ll
  integer :: ispin
  ier = 0

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

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

     do ie = 1,ne_kb
        node = ie - 1
        if (ie > 1) then
           if (is_solved_kb(ie-1,ips) == 0) then
              is_solved_kb(ie,ips) = 0
              ee_local_kb(ie,ips) = 0.d0
              cycle
           end if
        end if

        call calc_bound_state_loc(ier, IFLOG, &
             & iord_pc, iord_nec, iord_diff, dx, eps_de, &
             & nmesh, rpos, wr, vloc_scr_us(:,ispin), ll, node, &
             & ee_local_kb(ie,ips), is_solved_kb(ie,ips) )

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

     end do
  end do

99 continue

end subroutine calc_local_level_kb_kt
! ======================================================================== 4.0
   
!=====================================================================
   subroutine check_ghost_states_kb(ier)
!=====================================================================
!
!  Checks if ghost states exist or not.
!
!  M. Okamoto
!
!---------------------------------------------------------------------
   use parameters
   implicit none
   integer,intent(out) :: ier
   integer :: ips
   real(8) :: e1, e2, ekb, ee, eps = 1.d-4
   ier = 0
   do ips = 1,nps
      ekb = engy_kb(ips,0)
      e1  = ee_local_kb(1,ips)
      e2  = ee_local_kb(2,ips)
      ee  = engy(ishell_ps(ips,1))
      if (ekb > eps) then
         if (e1 > -eps) then
            is_ghost_kb(ips) = -1
         else
            if (ee > e2) then
               is_ghost_kb(ips) = 1
            else
               is_ghost_kb(ips) = 0
            end if
         end if
      else if (ekb < -eps) then
         if (e1 > -eps) then
            is_ghost_kb(ips) = -1
         else
            if (ee > e1) then
               is_ghost_kb(ips) = 1
            else
               is_ghost_kb(ips) = 0
            end if
         end if
      else
         if (abs(ee-e1) > eps) then
            is_ghost_kb(ips) = 1
         else
            is_ghost_kb(ips) = 0
         end if
      end if
   end do
   have_ghost_kb = 0
   do ips = 1,nps
      if (is_ghost_kb(ips) == -1) then
         have_ghost_kb = -1
      end if
   end do
   do ips = 1,nps
      if (is_ghost_kb(ips) == 1) then
         have_ghost_kb = 1
      end if
   end do
99 continue
   end subroutine check_ghost_states_kb

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

  integer,intent(out) :: ier

  integer :: ips, ispin
  real(8) :: e1, e2, ekb, ee, eps = 1.d-4

  ier = 0

  do ips = 1,nps

     ispin = ( 1 -spin_index_ps(ips) )/2 +1

     ekb = engy_kb(ips,nps+ispin)

     e1  = ee_local_kb(1,ips)
     e2  = ee_local_kb(2,ips)
     ee  = engy(ishell_ps(ips,1))

     if (ekb > eps) then
        if (e1 > -eps) then
           is_ghost_kb(ips) = -1
        else
           if (ee > e2) then
              is_ghost_kb(ips) = 1
           else
              is_ghost_kb(ips) = 0
           end if
        end if

     else if (ekb < -eps) then
        if (e1 > -eps) then
           is_ghost_kb(ips) = -1
        else
           if (ee > e1) then
              is_ghost_kb(ips) = 1
           else
              is_ghost_kb(ips) = 0
           end if
        end if

     else
        if (abs(ee-e1) > eps) then
           is_ghost_kb(ips) = 1
        else
           is_ghost_kb(ips) = 0
        end if
     end if
  end do

  have_ghost_kb = 0

  do ips = 1,nps
     if (is_ghost_kb(ips) == -1) then
        have_ghost_kb = -1
     end if
  end do

  do ips = 1,nps
     if (is_ghost_kb(ips) == 1) then
        have_ghost_kb = 1
     end if
  end do

99 continue

end subroutine check_ghost_states_kb_kt
! ======================================================================== 4.0

!=====================================================================
   subroutine write_local_level_kb(ifile)
!=====================================================================
!
!  Writes the Kleinman-Bylander local energy levels
!
!  M. Okamoto
!
!---------------------------------------------------------------------
   use parameters
   implicit none
   integer,intent(in) :: ifile
   integer :: ips, ie
   character(1) :: fn_label_orbital, fn_pm_sign
   character(7) :: fn_ghost
   write(ifile,*)
   write(ifile,*) &
      'Kleinman-Bylander local energy levels : Eloc[KB](i,l)'
   write(ifile,10) &
      (fn_label_orbital(l_qnum(ishell_ps(ips,1))),ips=1,nps)
   do ie = 1,ne_kb
      write(ifile,20) ie,(ee_local_kb(ie,ips),ips=1,nps)
   end do
   write(ifile,21) (fn_pm_sign(engy_kb(ips,0)),ips=1,nps)
   write(ifile,22) (engy(ishell_ps(ips,1)),ips=1,nps)
   write(ifile,23) (fn_ghost(is_ghost_kb(ips)),ips=1,nps)
10 format(1x,7x,4(10x,a1,5x))
20 format(1x,'local-',i1,4f16.6)
21 format(1x,'E[KB]',2x,4(10x,a1,5x))
22 format(1x,'eigen',2x,4f16.6)
23 format(1x,'ghost',2x,4(9x,a7))
   end subroutine write_local_level_kb

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

  integer,intent(in) :: ifile

  integer :: ips, ie, ispin
  character(1) :: fn_label_orbital, fn_pm_sign
  character(7) :: fn_ghost

  write(ifile,*)
  write(ifile,*) &
       'Kleinman-Bylander local energy levels : Eloc[KB](i,l)'

  Do ispin=1, nspin

     if ( nspin == 2 ) then
        write(ifile,*)
        
        if ( ispin == 1 ) then
           write(ifile,*) 'spin component : up'
        else if ( ispin ==2 ) then
           write(ifile,*) 'spin component : down'
        endif
     endif

     write(ifile,10) &
          (fn_label_orbital(l_qnum(ishell_ps(ips,1))),ips=ispin,nps,nspin)

     do ie = 1,ne_kb
        write(ifile,20) ie,(ee_local_kb(ie,ips),ips=ispin,nps,nspin)
     end do

     write(ifile,21) (fn_pm_sign(engy_kb(ips,nps+ispin)),ips=ispin,nps,nspin)

     write(ifile,22) (engy(ishell_ps(ips,1)),ips=ispin,nps,nspin)
     write(ifile,23) (fn_ghost(is_ghost_kb(ips)),ips=ispin,nps,nspin)

  End do

10 format(1x,7x,4(10x,a1,5x))
20 format(1x,'local-',i1,4f16.6)
21 format(1x,'E[KB]',2x,4(10x,a1,5x))
22 format(1x,'eigen',2x,4f16.6)
23 format(1x,'ghost',2x,4(9x,a7))

end subroutine write_local_level_kb_kt
! ========================================================================== 4.0


!=====================================================================
   function fn_ghost(is_ghost)
!=====================================================================
!
!  M. Okamoto
!
!---------------------------------------------------------------------
   implicit none
   integer,intent(in) :: is_ghost
   character(7) :: fn_ghost
   select case (is_ghost)
   case (1)
      fn_ghost = 'exists '
   case (0)
      fn_ghost = ' none  '
   case (-1)
      fn_ghost = 'unknown'
   end select
   end function fn_ghost

!=====================================================================
   function fn_pm_sign(x)
!=====================================================================
!
!  M. Okamoto
!
!---------------------------------------------------------------------
   implicit none
   real(8),intent(in) :: x
   real(8) :: eps = 1.d-6
   character(1) :: fn_pm_sign
   if (x > eps) then
      fn_pm_sign = '+'
   else if (x < -eps) then
      fn_pm_sign = '-'
   else
      fn_pm_sign = '0'
   end if
   end function fn_pm_sign

!=====================================================================
   subroutine write_ghost_exists(ifile)
!=====================================================================
!
!  M. Okamoto
!
!---------------------------------------------------------------------
   implicit none
   integer,intent(in) :: ifile
   write(ifile,*) '##############################'
   write(ifile,*) '###  A ghost state exists  ###'
   write(ifile,*) '##############################'
   end subroutine write_ghost_exists

!=====================================================================
   subroutine write_ghost_none(ifile)
!=====================================================================
!
!  M. Okamoto
!
!---------------------------------------------------------------------
   implicit none
   integer,intent(in) :: ifile
   write(ifile,*) 'ooooooooooooooooooooooooooooooo'
   write(ifile,*) 'ooo  No ghost states exist  ooo'
   write(ifile,*) 'ooooooooooooooooooooooooooooooo'
   end subroutine write_ghost_none

!=====================================================================
   subroutine write_ghost_unknown(ifile)
!=====================================================================
!
!  M. Okamoto
!
!---------------------------------------------------------------------
   implicit none
   integer,intent(in) :: ifile
   write(ifile,*) '??????????????????????????????????????'
   write(ifile,*) '???  Ghost states analysis failed  ???'
   write(ifile,*) '??????????????????????????????????????'
   end subroutine write_ghost_unknown
