!
!  Software name : CIAO (Code for Investigating Atomic Orbitals)
!  Subroutine(s) : find_ishell_core_hole, reset_felec_ss
!  Author(s)     : Masakuni Okamoto (January 20, 2005)
!
!
!  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 find_ishell_core_hole(ier)
!=====================================================================
!
!  Find ishell_core_hole(:) for unscreened core holes.
!
!  M. Okamoto
!
!---------------------------------------------------------------------
   use parameters
   implicit none
   integer,intent(out) :: ier
   integer :: ishell, n1, l1, n2, l2, icore, &
              is_found, ishell_found
   ier = 0
   ftot_core_hole = 0.d0
if (num_core_hole > 0) then
   do icore = 1,num_core_hole
      n1 = n_val_label_core_hole(icore)
      l1 = l_val_label_core_hole(icore)
      is_found = 0
      do ishell = 1,nshell
         n2 = n_qnum(ishell)
         l2 = l_qnum(ishell)
         if ((n1 == n2).and.(l1 == l2)) then
            ishell_found = ishell
            ishell_core_hole(icore) = ishell_found
            is_found = 1
            exit
         end if
      end do
      if (is_found == 0) then
         write(IFLOG,*) '### ERROR ### ishell was not found'
         write(IFLOG,*) &
            'Core hole state specified by PP input was not found.'
         write(IFLOG,*) '   (n,l) ...',n1,l1
         ier = 1 ; go to 99
      end if
      if (focc_core_hole(icore) > focc(ishell_found)) then
         write(IFLOG,*) '### ERROR ### number of core holes was wrong.'
         write(IFLOG,*) &
            'Number of core holes exceeds the occupation number.'
         write(IFLOG,*) '   (n,l)                ...',n1,l1
         write(IFLOG,*) '   number of core holes ...', &
            focc_core_hole(icore)
         write(IFLOG,*) '   occupation number    ...', &
            focc(ishell_found)
         ier = 1 ; go to 99
      end if
      ftot_core_hole = ftot_core_hole + focc_core_hole(icore)
   end do
else
   write(IFLOG,*) &
      'find_ishell_core_hole was not done, because num_core_hole = 0.'
   write(IFLOG,*) &
      'therefore, unscreened core holes are not considered.'
end if
99 continue
   end subroutine find_ishell_core_hole

!=====================================================================
   subroutine reset_felec_ss(ier)
!=====================================================================
!
!  Reset felec_ss
!
!  M. Okamoto
!
!---------------------------------------------------------------------
   use parameters
   implicit none
   integer,intent(out) :: ier
   character(256) :: &
      buffer, keyword
   integer :: &
      loop, ishell, nn, ll, ips, iss
   real(8) :: &
      res, res1, res2, ftot
   ier = 0
   felec_ss = felec_val
   call open_infile
   rewind(IFIN)
   loop = 0
INPUT: do while (loop < 10000)
   loop = loop + 1
      read(IFIN,'(a)',end=98) buffer
      if (buffer == '') cycle INPUT
      read(buffer,*) keyword
      select case (keyword(1:1))
      case ('#', '!')
         cycle INPUT
      end select
      select case (keyword)
      case ('#', '!')
         cycle INPUT
      case ('end', 'END', 'End')
         write(IFLOG,*) '### ERROR ### solve_pp_spin was not found.'
         ier = 1
         exit INPUT
      case ('solve_pp_spin', 'solve_spin_pp', 'solve_pp')
         read(IFIN,'(a)',end=98) buffer
            focc_ss     = 0.d0
            n_val_label_ss = 0 ; l_val_label_ss = 0
            spin_ss        = 0 ; nocc_ss        = 0
            ishell_ss      = 0
         focc_ss(:) = 0.d0
         select case (is_spin_state_ss)
         case (AUTOMATIC)
            felec_ss = felec_val
            iss = 0
            felec1_ss = 0.d0
            felec2_ss = 0.d0
            res = felec_ss
            do ips = 1,nps
               iss = iss + 1
               ishell = ishell_ps(ips,1)
               nn = n_qnum(ishell)
               ll = l_qnum(ishell)
               spin_ss(iss) = +1
               ishell_ss(iss) = ishell
               n_val_label_ss(iss) = nn
               l_val_label_ss(iss) = ll
               select case (is_spin_ss)
               case (RESTRICTED)
                  nocc_ss(iss) = 2*(2*ll+1)
               case (POLARIZED)
                  nocc_ss(iss)   = 2*ll+1
                  nocc_ss(iss+1) = 2*ll+1
               end select
               ftot = dble(nocc_ss(iss))
               if (ftot >= res) then
                  focc_ss(iss) = res
                  res = 0.d0
               else
                  focc_ss(iss) = ftot
                  res = res - ftot
               end if
               felec1_ss = felec1_ss + focc_ss(iss)
               if (is_spin_ss == POLARIZED) then
                  iss = iss + 1
                  spin_ss(iss) = -1
                  ishell_ss(iss) = ishell
                  n_val_label_ss(iss) = nn
                  l_val_label_ss(iss) = ll
                  ftot = dble(nocc_ss(iss))
                  if (ftot >= res) then
                     focc_ss(iss) = res
                     res = 0.d0
                  else
                     focc_ss(iss) = ftot
                     res = res - ftot
                  end if
                  felec2_ss = felec2_ss + focc_ss(iss)
               end if
            end do
            select case (is_spin_ss)
            case (POLARIZED)
               fspin_ss = felec1_ss - felec2_ss
            case (RESTRICTED)
               fspin_ss = 0.d0
            end select
         case (UD_SPECIFIED)
            iss = 0
            felec1_ss = 0.d0
            felec2_ss = 0.d0
            do ips = 1,nps
               iss = iss + 1
               select case (is_spin_ss)
               case (RESTRICTED)
                  read(IFIN,*) val_label_ss(iss),focc_ss(iss)
                  spin_ss(iss) = +1
                  felec1_ss = felec1_ss + focc_ss(iss)
               case (POLARIZED)
                  read(IFIN,*) val_label_ss(iss),focc_ss(iss), &
                                                 focc_ss(iss+1)
                  if (focc_ss(iss) < focc_ss(iss+1)) then
                     call swap(focc_ss(iss),focc_ss(iss+1))
                  end if
                  spin_ss(iss) = +1
                  felec1_ss = felec1_ss + focc_ss(iss)
                  spin_ss(iss+1) = -1
                  felec2_ss = felec2_ss + focc_ss(iss+1)
                  val_label_ss(iss+1) = val_label_ss(iss)
               end select
               read(val_label_ss(iss)(1:1),*) n_val_label_ss(iss)
               select case (val_label_ss(iss)(2:2))
               case ('s', 'S')
                  l_val_label_ss(iss) = 0
               case ('p', 'P')
                  l_val_label_ss(iss) = 1
               case ('d', 'D')
                  l_val_label_ss(iss) = 2
               case ('f', 'F')
                  l_val_label_ss(iss) = 3
               case default
                  write(IFLOG,*) '### ERROR ### val_label_ss'
                  write(IFLOG,*) '   iss          ...',iss
                  write(IFLOG,*) '   val_label_ss ... ', &
                                     val_label_ss(iss)
                  ier = 1 ; go to 99
               end select
               nn = n_val_label_ss(iss)
               ll = l_val_label_ss(iss)
               call find_ishell_ss(nshell,n_qnum,l_qnum,nn,ll, &
                                   ishell)
               if (ishell == 0) then
                  write(IFLOG,*) '### ERROR ### ishell_ss was not found'
                  write(IFLOG,*) &
                    'Valence state specified by PP input was not found.'
                  write(IFLOG,*) '   (n,l) ...',nn,ll
                  ier = 1 ; go to 99
               end if
               ishell_ss(iss) = ishell
               select case (is_spin_ss)
               case (RESTRICTED)
                  nocc_ss(iss) = 2*(2*ll+1)
               case (POLARIZED)
                  nocc_ss(iss)   = 2*ll+1
                  nocc_ss(iss+1) = 2*ll+1
                  n_val_label_ss(iss+1) = n_val_label_ss(iss)
                  l_val_label_ss(iss+1) = l_val_label_ss(iss)
                  ishell_ss(iss+1) = ishell_ss(iss)
                  iss = iss + 1
               end select
            end do
            felec_ss = felec1_ss + felec2_ss
            select case (is_spin_ss)
            case (POLARIZED)
               fspin_ss = felec1_ss - felec2_ss
            case (RESTRICTED)
               fspin_ss = 0.d0
            end select
            if (iss /= nss) then
               write(IFLOG,*) '### ERROR ### iss != nss'
               write(IFLOG,*) '   iss ...',iss
               write(IFLOG,*) '   nss ...',nss
               ier = 1 ; go to 99
            end if
         case (SPIN_SPECIFIED)
            felec_ss = felec_val
            select case (is_spin_ss)
            case (POLARIZED)
               if (fspin_ss < 0.d0) then
                  fspin_ss = -fspin_ss
               end if
               felec1_ss = 0.5d0 * (felec_ss + fspin_ss)
               felec2_ss = 0.5d0 * (felec_ss - fspin_ss)
               res1 = felec1_ss
               res2 = felec2_ss
               iss = 0
               do ips = 1,nps
                  iss = iss + 1
                  spin_ss(iss) = +1
                  ishell = ishell_ps(ips,1)
                  nn = n_qnum(ishell)
                  ll = l_qnum(ishell)
                  ishell_ss(iss) = ishell
                  n_val_label_ss(iss) = nn
                  l_val_label_ss(iss) = ll
                  nocc_ss(iss) = 2*ll+1
                  ftot = dble(nocc_ss(iss))
                  if (ftot >= res1) then
                     focc_ss(iss) = res1
                     res1 = 0.d0
                  else
                     focc_ss(iss) = ftot
                     res1 = res1 - ftot
                  end if
                  iss = iss + 1
                  spin_ss(iss) = -1
                  ishell_ss(iss) = ishell
                  n_val_label_ss(iss) = nn
                  l_val_label_ss(iss) = ll
                  nocc_ss(iss) = 2*ll+1
                  ftot = dble(nocc_ss(iss))
                  if (ftot >= res2) then
                     focc_ss(iss) = res2
                     res2 = 0.d0
                  else
                     focc_ss(iss) = ftot
                     res2 = res2 - ftot
                  end if
               end do
            case (RESTRICTED)
               felec1_ss = felec_ss ; felec2_ss = 0.d0
               fspin_ss = 0.d0
               res1 = felec1_ss
               iss = 0
               do ips = 1,nps
                  iss = iss + 1
                  spin_ss(iss) = +1
                  ishell = ishell_ps(ips,1)
                  nn = n_qnum(ishell)
                  ll = l_qnum(ishell)
                  ishell_ss(iss) = ishell
                  n_val_label_ss(iss) = nn
                  l_val_label_ss(iss) = ll
                  nocc_ss(iss) = 2*(2*ll+1)
                  ftot = dble(nocc_ss(iss))
                  if (ftot >= res1) then
                     focc_ss(iss) = res1
                     res1 = 0.d0
                  else
                     focc_ss(iss) = ftot
                     res1 = res1 - ftot
                  end if
               end do
            end select
         end select
         exit INPUT
      case default
         cycle INPUT
      end select
end do INPUT
   close(IFIN)
   go to 99
98 continue
   ier = 100
99 continue
   end subroutine reset_felec_ss
