!
!  Software name : CIAO (Code for Investigating Atomic Orbitals)
!  Subroutine(s) : sort_engy_sol, sort_engy_ss, set_focc_sol
!                : set_focc_ss, calc_efermi_ss
!  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 sort_engy_sol(ier)
!=====================================================================
!
!  Sorts energy levels
!
!  M. Okamoto
!
!---------------------------------------------------------------------
   use parameters
   implicit none
   integer,intent(out) :: ier
   integer :: ips, jps, imin
   ier = 0
   do ips = 1,nps
      list_sol(ips) = ips
   end do
   do ips = 1,nps-1
      imin = ips
      do jps = ips+1,nps
         if (engy_sol(list_sol(jps)) < engy_sol(list_sol(imin))) then
            imin = jps
         end if
      end do
      call iswap(list_sol(ips),list_sol(imin))
   end do
99 continue
   end subroutine sort_engy_sol

!=====================================================================
   subroutine sort_engy_ss(ier)
!=====================================================================
!
!  Sorts energy levels
!
!  M. Okamoto
!
!---------------------------------------------------------------------
   use parameters
   implicit none
   integer,intent(out) :: ier
   integer :: iss, jss, imin
   ier = 0
   do iss = 1,nss
      list_ss(iss) = iss
   end do
   do iss = 1,nss-1
      imin = iss
      do jss = iss+1,nss
         if (engy_ss(list_ss(jss)) < engy_ss(list_ss(imin))) then
            imin = jss
         end if
      end do
      call iswap(list_ss(iss),list_ss(imin))
   end do
99 continue
   end subroutine sort_engy_ss

!=====================================================================
   subroutine set_focc_sol(ier)
!=====================================================================
!
!  Sets focc_sol(:)
!
!  M. Okamoto
!
!---------------------------------------------------------------------
   use parameters
   implicit none
   integer,intent(out) :: ier
   integer :: ishell, ips
   ier = 0
   focc_sol(:) = 0.d0
   do ips = 1,nps
      ishell = ishell_ps(ips,1)
      focc_sol(ips) = focc(ishell)
   end do
99 continue
   end subroutine set_focc_sol

!=====================================================================
   subroutine set_focc_ss(ier)
!=====================================================================
!
!  Sets focc_ss(:)
!
!  M. Okamoto
!
!---------------------------------------------------------------------
   use parameters
   implicit none
   integer,intent(out) :: ier
   integer :: ishell, iss, lspin, lss, nn, ll
   real(8) :: ftot, sum, res1, res2
   ier = 0
   select case (is_spin_state_ss)
   case (AUTOMATIC, SPIN_SPECIFIED)
      select case (is_spin_ss)
      case (POLARIZED)
         focc_ss(:) = 0.d0
         res1 = felec1_ss
         res2 = felec2_ss
         do iss = 1,nss
            lss = list_ss(iss)
            ftot = dble(nocc_ss(lss))
            lspin  = (1-spin_ss(lss))/2 + 1
            select case (lspin)
            case (1)
               if (ftot >= res1) then
                  focc_ss(lss) = res1
                  res1 = 0.d0
               else
                  focc_ss(lss) = ftot
                  res1 = res1 - ftot
               end if
            case (2)
               if (ftot >= res2) then
                  focc_ss(lss) = res2
                  res2 = 0.d0
               else
                  focc_ss(lss) = ftot
                  res2 = res2 - ftot
               end if
            end select
            nn = n_qnum(ishell_ss(lss))
            ll = l_qnum(ishell_ss(lss))
            write(IFLOG,*) 'iss,lss,lspin,n,l,isol,focc,e ...', &
               iss,lss,lspin,nn,ll,is_solve_ss(lss),focc_ss(lss),engy_ss(lss)
         end do
      case (RESTRICTED)
         focc_ss(:) = 0.d0
         res1 = felec_ss
         do iss = 1,nss
            lss = list_ss(iss)
            ftot = dble(nocc_ss(lss))
            if (ftot >= res1) then
               focc_ss(lss) = res1
            else
               focc_ss(lss) = ftot
               res1 = res1 - ftot
            end if
         end do
      end select
   case (UD_SPECIFIED)
   case default
      write(IFLOG,*) '### ERROR ### is_spin_state_ss is wrong'
      write(IFLOG,*) '   is_spin_state_ss ...',is_spin_state_ss
      ier = 1 ; go to 99
   end select
   do iss = 1,nss
      if ((focc_ss(iss) > 1.d-10).and.(is_solve_ss(iss) == 0)) then
         ishell = ishell_ss(iss)
         nn = n_qnum(ishell)
         ll = l_qnum(ishell)
         write(IFLOG,*) '### ERROR ### focc_ss != 0 for is_solve_ss = 0'
         write(IFLOG,*) '   iss         ...', iss
         write(IFLOG,*) '   (n,l)       ...', nn,ll
         write(IFLOG,*) '   focc_ss     ...', focc_ss(iss)
         write(IFLOG,*) '   is_solve_ss ...', is_solve_ss(iss)
         ier =1 ; go to 99
      end if
   end do
   sum = 0.d0
   do iss = 1,nss
      if (is_solve_ss(iss) /= 0) then
         sum = sum + focc_ss(iss)
      end if
   end do
   if (abs(sum-felec_ss) > 1.d-6) then
      write(IFLOG,*) '### ERROR ### sum of focc_ss != felec_ss'
      write(IFLOG,*) '   sum of focc_ss ...',sum
      write(IFLOG,*) '   felec_ss       ...',felec_ss
      ier = 1 ; go to 99
   end if
99 continue
   end subroutine set_focc_ss

!=====================================================================
   subroutine calc_efermi_ss(ier)
!=====================================================================
!
!  Calculates Fermi level
!
!  M. Okamoto
!
!---------------------------------------------------------------------
   use parameters
   implicit none
   integer,intent(out) :: ier
   integer :: iss, lss
   ier = 0
   efermi_ss = 0.d0
   do iss = 1,nss
      lss = list_ss(iss)
      if (abs(focc_ss(lss)) > 1.d-10) then
         efermi_ss = engy_ss(lss)
      else
         exit
      end if
   end do
99 continue
   end subroutine calc_efermi_ss
