! ************************************************************* 
!
!   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_nonscf_sol, calc_scf_ss, check_conv_ss
!                : mix_rho_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_nonscf_sol(ier)
!=====================================================================
!
!  M. Okamoto
!
!---------------------------------------------------------------------  
   use parameters   
   implicit none
   integer,intent(out) :: ier
   ier = 0
   felec_sol = felec_val

! ============================================ modified by K. T. ========= 4.0
!   vloc_scr_sol(:) = vloc_scr_us(:)
   vloc_scr_sol(:,:) = vloc_scr_us(:,:)
! ======================================================================== 4.0

   call set_focc_sol(ier)
   if (ier /= 0) then
      write(IFLOG,*) '### ERROR ### in set_focc_sol' ; go to 99
   end if
   call calc_bound_state_nonscf_sol(ier)
   if (ier /= 0) then
      write(IFLOG,*) '### ERROR ### in calc_bound_state_nonscf_sol' ; go to 99
   end if
   call sort_engy_sol(ier)
   if (ier /= 0) then
      write(IFLOG,*) '### ERROR ### in sort_engy_sol' ; go to 99
   end if
   call calc_rho_sol(ier)
   if (ier /= 0) then
      write(IFLOG,*) '### ERROR ### in calc_rho_sol' ; go to 99
   end if
   if (is_pcc == PCC) then
      call calc_rho_pcore_sol(ier)
      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
   call check_negative_rho_sol(ier)
   if (ier /= 0) then
      write(IFLOG,*) '### ERROR ### in check_negative_rho_sol' ; go to 99
   end if
   if (is_xc_class == GGA) then
   select case (is_xc)
   case (GGAPBE96_MOMO)
      call calc_drho_ddrho_sol(ier)
      if (ier /= 0) then
         write(IFLOG,*) '### ERROR ### in calc_drho_ddrho_sol' ; go to 99
      end if
      call calc_drho_ddrho_core_sol(ier)
      if (ier /= 0) then
         write(IFLOG,*) '### ERROR ### in calc_drho_ddrho_core' ; go to 99
      end if
      if (is_pcc == PCC) then
         call calc_drho_ddrho_pcore_sol(ier)
         if (ier /= 0) then
            write(IFLOG,*) '### ERROR ### in calc_drho_ddrho_pcore' ; go to 99
         end if
      end if
   case default
      call calc_drho_sol(ier)
      if (ier /= 0) then
         write(IFLOG,*) '### ERROR ### in calc_drho_sol' ; go to 99
      end if
      call calc_drho_core_sol(ier)
      if (ier /= 0) then
         write(IFLOG,*) '### ERROR ### in calc_drho_core' ; go to 99
      end if
      if (is_pcc == PCC) then
         call calc_drho_pcore_sol(ier)
         if (ier /= 0) then
            write(IFLOG,*) '### ERROR ### in calc_drho_pcore' ; go to 99
         end if
      end if
   end select
   end if
   call calc_vloc_ion_sol(ier)
   if (ier /= 0) then
      write(IFLOG,*) '### ERROR ### in calc_vloc_ion_sol' ; go to 99
   end if
99 continue
   end subroutine calc_nonscf_sol

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

  integer,intent(out) :: ier
  ier = 0
  felec_sol = felec_val

  vloc_scr_sol(:,:) = vloc_scr_us(:,:)

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

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

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

!  write(*,*) engy_sol
!  stop

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


  if (is_pcc == PCC) then
     call calc_rho_pcore_sol(ier)
     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

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

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

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

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

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

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

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

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

99 continue
  
end subroutine calc_nonscf_sol_kt
! =============================================================================== 4.0

!=====================================================================
subroutine calc_scf_ss(ier)
!=====================================================================
!
!  M. Okamoto
!
!---------------------------------------------------------------------  
  use parameters   
  implicit none

  integer,intent(out) :: ier
  integer :: loop_scf, is_conv

  ier = 0
  loop_scf = 0

  SCF: do
     loop_scf = loop_scf + 1
     engy_ss_old(:)       = engy_ss(:)
     rho_ss_old(:,:)      = rho_ss(:,:)
     vloc_scr_ss_old(:,:) = vloc_scr_ss(:,:)
     etot_ss_old          = etot_ss

     if (is_xc_class == GGA) then

        select case (is_xc)

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

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

        end select
     end if

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

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

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

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

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

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

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

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

     if (is_conv == YES) then
        exit SCF
     end if

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

  end do SCF

  if (is_xc_class == GGA) then

     select case (is_xc)

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

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

     end select
  end if

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

99 continue

end subroutine calc_scf_ss

!================================================ added by K. T. ========== 4.0
subroutine calc_scf_ss_kt(ier)
!=====================================================================
!
!  M. Okamoto
!
!---------------------------------------------------------------------  
  use parameters   
  implicit none

  integer,intent(out) :: ier
  integer :: loop_scf, is_conv

  ier = 0
  loop_scf = 0

  SCF: do
     loop_scf = loop_scf + 1
     engy_ss_old(:)       = engy_ss(:)
     rho_ss_old(:,:)      = rho_ss(:,:)
     vloc_scr_ss_old(:,:) = vloc_scr_ss(:,:)
     etot_ss_old          = etot_ss

     if (is_xc_class == GGA) then

        select case (is_xc)

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

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

        end select
     end if

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

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

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

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

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

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

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

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

     if (is_conv == YES) then
        exit SCF
     end if

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

  end do SCF

  if (is_xc_class == GGA) then

     select case (is_xc)

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

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

     end select
  end if

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

end subroutine calc_scf_ss_kt
! =============================================================================== 4.0


!=====================================================================
   subroutine check_conv_ss(ier,is_conv,loop_scf)
!=====================================================================
!
!  M. Okamoto
!
!---------------------------------------------------------------------  
   use parameters   
   implicit none
   integer,intent(out)   :: ier
   integer,intent(inout) :: is_conv
   integer,intent(in)    :: loop_scf
   integer :: i, iss
   real(8) :: dee_max, de, tmp
   integer,parameter :: nsave_dee_ss = 3
   real(8),parameter :: dee_conv_ss  = 1.d-7
   ier = 0
   is_conv = NO
   do i = nsave_dee_ss-1,1,-1
      dee_save(i+1) = dee_save(i)
   end do
   dee_save(1) = abs((etot_ss-etot_ss_old)/etot_ss_old)
   write(IFLOG,10) '### STOT ### etot,dee ...', &
      loop_scf, etot_ss, dee_save(1)
   dee_max = dee_save(1)
   if ((loop_scf > nsave_dee_ss).and.(nsave_dee_ss >= 2)) then
      do i = 2,nsave_dee_ss
         dee_max = max(dee_save(i),dee_max)
      end do
   end if
   de = abs(engy_ss(1)-engy_ss_old(1))
   do iss = 1,nss
      if (is_solve_ss(iss) /= 0) then
      tmp = abs(engy_ss(iss)-engy_ss_old(iss))
      de  = max(de,tmp)
      end if
   end do
   write(IFLOG,10) '#### DE #### de .........', &
      loop_scf, de
   if ((loop_scf > nsave_dee_ss).and.(dee_max < dee_conv_ss)) then
      is_conv = YES
      write(IFLOG,20) &
        'SCF calculation converged after',loop_scf,'iterations.'
      write(IFSUM,*)
      write(IFSUM,20) &
        'SCF calculation converged after',loop_scf,'iterations.'
   end if
   if (loop_scf > loop_conv) then
      write(IFLOG,30) &
       '### ERROR ### SCF loop count exceeded the limit',loop_conv,'.'
      write(IFSUM,*)
      write(IFSUM,30) &
       '### ERROR ### SCF loop count exceeded the limit',loop_conv,'.'
      ier = 1 ; go to 99
   end if
10 format(1x,a25,i7,2(1pe25.15))
20 format(1x,a31,(1x,i4,1x),a11)
30 format(1x,a47,(1x,i4),a1)
99 continue
   end subroutine check_conv_ss

!=====================================================================
   subroutine mix_rho_ss(ier)
!=====================================================================
!
!  M. Okamoto
!
!---------------------------------------------------------------------
   use parameters   
   implicit none
   integer,intent(out) :: ier
   integer :: ispin
   ier = 0
   ispin = 1
   call adjust_rho(ier,IFLOG, &
        nmesh,rpos,wr,rho_ss(1,ispin),felec1_ss,eps_check)
   if (is_spin_ss == POLARIZED) then
      ispin = 2
      call adjust_rho(ier,IFLOG, &
           nmesh,rpos,wr,rho_ss(1,ispin),felec2_ss,eps_check)
   end if
   rho_ss(:,:) = (1.d0-mix_ss)*rho_ss_old(:,:) + mix_ss*rho_ss(:,:)
   ispin = 1
   call adjust_rho(ier,IFLOG, &
        nmesh,rpos,wr,rho_ss(1,ispin),felec1_ss,eps_check)
   if (is_spin_ss == POLARIZED) then
      ispin = 2
      call adjust_rho(ier,IFLOG, &
           nmesh,rpos,wr,rho_ss(1,ispin),felec2_ss,eps_check)
   end if
99 continue
   end subroutine mix_rho_ss
