! ************************************************************* 
!
!   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
!
!   Version history: 
!
!     4.0:  2013/03/01
!           codes for spin-polarized pseudopotential generation are added
!     4.1:  2013/11/22 - 
!           Info of core wfns and energy contributions can be added to gncpp2
!     4.2:  2014/07/23 - 
!           gncpp2 can be geregated even when nmesh /= 1501
!
! ************************************************************* 
!
!  Software name : CIAO (Code for Investigating Atomic Orbitals)
!  Subroutine(s) : write_so_atom, read_input_so, calc_spin_orbit
!                : write_energy_level_so, write_etot_so
!  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 write_so_atom(ifile)
!=====================================================================
!
!  M. Okamoto
!
!---------------------------------------------------------------------
   implicit none
   integer,intent(in) :: ifile
   write(ifile,*)
   write(ifile,*) 'oooooooooooooooooooooooooooooooooooooooooo'
   write(ifile,*) 'oooooo                              oooooo'
   write(ifile,*) 'oooooo          Spin-Orbit          oooooo'
   write(ifile,*) 'oooooo          Interaction         oooooo'
   write(ifile,*) 'oooooo                              oooooo'
   write(ifile,*) 'oooooooooooooooooooooooooooooooooooooooooo'
   end subroutine write_so_atom


!=====================================================================
   subroutine read_input_so(ier)
!=====================================================================
!
!  M. Okamoto
!
!---------------------------------------------------------------------
   use parameters
   implicit none
   integer,intent(out) :: ier
   integer :: fn_number_of_words
   character(256) :: &
      buffer, keyword, sub_keyword
   character(50),allocatable :: &
      state_tmpj(:), state_tmpk(:)
   integer :: &
      loop, ishell, jshell, kshell, nn, ll, jj2, ss, &
      nocc_tmp, jjshell, jjspin
   integer,allocatable :: &
      spin_tmpj(:), n_qnum_tmpj(:), l_qnum_tmpj(:), &
      is_solve_tmpj(:), is_valence_tmpj(:), &
      spin_tmpk(:), n_qnum_tmpk(:), l_qnum_tmpk(:), k_qnum_tmpk(:), &
      j2_qnum_tmpk(:), is_solve_tmpk(:), is_valence_tmpk(:)
   real(8) :: &
      sum, res, fe1, fe2
   real(8),allocatable :: &
      focc_tmpj(:), focc_tmpk(:)
   ier = 0
   rewind(IFIN)
   loop = 0
INPUT: do while (loop < 1000)
   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')
         exit INPUT
      case ('jobname', 'JOBNAME', 'Jobname')
      case ('atom_number')
         read(buffer,*) keyword, fatom, felec
         zatom = max(nint(fatom),1)
      case ('electron_config')
         select case (fn_number_of_words(buffer))
         case (4)
            read(buffer,*) keyword, nshell_in, calc_type, spin_type
            spin_state_type = 'automatic'
         case (5)
            read(buffer,*) keyword, nshell_in, calc_type, spin_type, &
                           spin_state_type
         end select
         calc_type_explained = 'Relativistic'
         is_calc = REL
         select case (spin_type)
         case ('restricted', 'RESTRICTED', 'Restricted')
            spin_type_explained = 'Restricted'
            is_spin = RESTRICTED
         case ('polarized', 'POLARIZED', 'Polarized')
            write(IFLOG,*) '### CAUTION ### spin_type'
            write(IFLOG,*) '   spin_type ... ',spin_type
            write(IFLOG,*) &
            'spin_type must be RESTRICTED for spin-orbit calculation.'
            ier = -1 ; go to 99
         case default
            write(IFLOG,*) '### ERROR ### spin_type'
            write(IFLOG,*) '   spin_type ... ',spin_type
            ier = 1 ; go to 99
         end select
         is_spin_state = AUTOMATIC
         spin_state_type_explained = 'Automatic'
         felec1 = felec ; felec2 = 0.d0
         nspin = 1
        !++++++++++++++++++++++++++++++++++++++++++++++++++++++
         allocate(state_in(nshell_in),focc_in(nshell_in,2),  &
            is_valence_in(nshell_in),is_solve_in(nshell_in), &
            n_qnum_in(nshell_in),l_qnum_in(nshell_in))
            focc_in    = 0.d0
            is_valence_in = 0 ; is_solve_in = 0
            n_qnum_in     = 0 ; l_qnum_in   = 0
        !++++++++++++++++++++++++++++++++++++++++++++++++++++++
         focc_in(:,:) = 0.d0
         foccnl(:,:,:) = 0.d0
         do ishell = 1,nshell_in
            read(IFIN,*) state_in(ishell), focc_in(ishell,1), &
                         is_solve_in(ishell)
            is_valence_in(ishell) = 0
            read(state_in(ishell)(1:1),*) n_qnum_in(ishell)
            select case (state_in(ishell)(2:2))
            case ('s', 'S')
               l_qnum_in(ishell) = 0
            case ('p', 'P')
               l_qnum_in(ishell) = 1
            case ('d', 'D')
               l_qnum_in(ishell) = 2
            case ('f', 'F')
               l_qnum_in(ishell) = 3
            case default
               write(IFLOG,*) '### ERROR ### state_in(ishell)(2:2)'
               write(IFLOG,*) '   ishell                ...',ishell
               write(IFLOG,*) '   state_in(ishell)(2:2) ...', &
                                  state_in(ishell)(2:2)
               ier = 1 ; go to 99
            end select
            ll = l_qnum_in(ishell)
            nn = n_qnum_in(ishell)
            foccnl(nn,ll,1) = focc_in(ishell,1)
            foccnl(nn,ll,2) = focc_in(ishell,2)
         end do
        !+++++++++++++++++++++++++++++++++++++++++++
         allocate( &
            spin_tmpj      (nshell_in*nspin), &
            state_tmpj     (nshell_in*nspin), &
            n_qnum_tmpj    (nshell_in*nspin), &
            l_qnum_tmpj    (nshell_in*nspin), &
            is_solve_tmpj  (nshell_in*nspin), &
            is_valence_tmpj(nshell_in*nspin), &
            focc_tmpj      (nshell_in*nspin))
            spin_tmpj     = 0
            n_qnum_tmpj   = 0 ; l_qnum_tmpj     = 0
            is_solve_tmpj = 0 ; is_valence_tmpj = 0
            focc_tmpj  = 0.d0
        !+++++++++++++++++++++++++++++++++++++++++++
         fe1 = felec1 ; fe2 = felec2
         jshell = 0
         do ishell = 1,nshell_in
            jshell = jshell + 1
            spin_tmpj      (jshell) = +1
            state_tmpj     (jshell) = state_in     (ishell)
            n_qnum_tmpj    (jshell) = n_qnum_in    (ishell)
            l_qnum_tmpj    (jshell) = l_qnum_in    (ishell)
            is_solve_tmpj  (jshell) = is_solve_in  (ishell)
            is_valence_tmpj(jshell) = is_valence_in(ishell)
            focc_tmpj      (jshell) = focc_in      (ishell,1)
            if (is_spin == POLARIZED) then
               jshell = jshell + 1
               spin_tmpj      (jshell) = -1
               state_tmpj     (jshell) = state_in     (ishell)
               n_qnum_tmpj    (jshell) = n_qnum_in    (ishell)
               l_qnum_tmpj    (jshell) = l_qnum_in    (ishell)
               is_solve_tmpj  (jshell) = is_solve_in  (ishell)
               is_valence_tmpj(jshell) = is_valence_in(ishell)
               nocc_tmp = 2*l_qnum_in(ishell) + 1
               if (focc_in(ishell,1) > dble(nocc_tmp)) then
                  focc_tmpj(jshell-1) = dble(nocc_tmp)
                  focc_tmpj(jshell)   = focc_in(ishell,1) &
                                      - dble(nocc_tmp)
               else
                  focc_tmpj(jshell)   = 0.d0
               end if
                  if ((n_qnum_tmpj(jshell) == 1).and. &
                      (l_qnum_tmpj(jshell) == 0).and. &
                      (focc_tmpj  (jshell) <  1.d-10)) then
                     is_solve_tmpj(jshell) = 0
                  end if
            end if
         end do
         do jjshell = 1,jshell
            nn = n_qnum_tmpj(jjshell)
            ll = l_qnum_tmpj(jjshell)
            ss = spin_tmpj  (jjshell)
            jjspin = 2 - (ss+1)/2
            foccnls(nn,ll,jjspin) = focc_tmpj(jjshell)
         end do
        !+++++++++++++++++++++++++++++++++++++++++++
         allocate( &
            spin_tmpk      (jshell*2), &
            state_tmpk     (jshell*2), &
            n_qnum_tmpk    (jshell*2), &
            l_qnum_tmpk    (jshell*2), &
            k_qnum_tmpk    (jshell*2), &
            j2_qnum_tmpk   (jshell*2), &
            is_solve_tmpk  (jshell*2), &
            is_valence_tmpk(jshell*2), &
            focc_tmpk      (jshell*2))
            spin_tmpk     = 0 ; n_qnum_tmpk     = 0
            l_qnum_tmpk   = 0 ; k_qnum_tmpk     = 0
            j2_qnum_tmpk  = 0
            is_solve_tmpk = 0 ; is_valence_tmpk = 0
            focc_tmpk  = 0.d0
        !+++++++++++++++++++++++++++++++++++++++++++
         kshell = 0
         do ishell = 1,jshell
            nn = n_qnum_tmpj(ishell)
            ll = l_qnum_tmpj(ishell)
            ss = spin_tmpj  (ishell)
            if (ll > 0) then
               kshell = kshell + 1
               spin_tmpk      (kshell) = ss
               state_tmpk     (kshell) = state_tmpj(ishell)
               n_qnum_tmpk    (kshell) = nn
               l_qnum_tmpk    (kshell) = ll
               k_qnum_tmpk    (kshell) = ll
               j2_qnum_tmpk   (kshell) = 2*ll-1
               is_solve_tmpk  (kshell) = is_solve_tmpj  (ishell)
               is_valence_tmpk(kshell) = is_valence_tmpj(ishell)
               jj2 = j2_qnum_tmpk(kshell)
               if (focc_tmpj(ishell) > dble(jj2+1)) then
                  focc_tmpk(kshell) = dble(jj2+1)
                  res = focc_tmpj(ishell) - dble(jj2+1)
               else
                  focc_tmpk(kshell) = focc_tmpj(ishell)
                  res = 0.d0
               end if
            end if
               kshell = kshell + 1
               spin_tmpk      (kshell) = ss
               state_tmpk     (kshell) = state_tmpj(ishell)
               n_qnum_tmpk    (kshell) = nn
               l_qnum_tmpk    (kshell) = ll
               k_qnum_tmpk    (kshell) = -ll-1
               j2_qnum_tmpk   (kshell) = 2*ll+1
               is_solve_tmpk  (kshell) = is_solve_tmpj  (ishell)
               is_valence_tmpk(kshell) = is_valence_tmpj(ishell)
               if (ll == 0) then
                  focc_tmpk(kshell) = focc_tmpj(ishell)
               else
                  focc_tmpk(kshell) = res
               end if
         end do
         nshell = kshell
        !++++++++++++++++++++++++++++++++++++++++++++++++++++++++++
         allocate(state(nshell),spin_label(nshell),spin(nshell), &
            focc(nshell),is_valence(nshell),is_solve(nshell),    &
            n_qnum(nshell),l_qnum(nshell),k_qnum(nshell),        &
            j2_qnum(nshell),list_shell(nshell),nocc(nshell),     &
            nrm_pos(nshell),nrt_pos(nshell),nmm_pos(nshell))
            spin       = 0 ; focc  = 0.d0
            is_valence = 0 ; is_solve = 0
            n_qnum     = 0 ; l_qnum   = 0
            k_qnum     = 0 ; j2_qnum  = 0
            list_shell = 0 ; nocc     = 0
            nrm_pos    = 0 ; nrt_pos  = 0
            nmm_pos    = 0
        !++++++++++++++++++++++++++++++++++++++++++++++++++++++++++
         do ishell = 1,nshell
            spin      (ishell) = spin_tmpk      (ishell)
            if (spin(ishell) == 1) then
               spin_label(ishell) = '+'
            else
               spin_label(ishell) = '-'
            end if
            state     (ishell) = state_tmpk     (ishell)
            n_qnum    (ishell) = n_qnum_tmpk    (ishell)
            l_qnum    (ishell) = l_qnum_tmpk    (ishell)
            k_qnum    (ishell) = k_qnum_tmpk    (ishell)
            j2_qnum   (ishell) = j2_qnum_tmpk   (ishell)
            is_solve  (ishell) = is_solve_tmpk  (ishell)
            is_valence(ishell) = is_valence_tmpk(ishell)
            focc      (ishell) = focc_tmpk      (ishell)
            nocc(ishell) = (j2_qnum(ishell) + 1)/nspin
         end do
        !+++++++++++++++++++++++++++++++++++++++++++++++++++
         deallocate( &
            spin_tmpj,state_tmpj,n_qnum_tmpj,l_qnum_tmpj, &
            is_solve_tmpj,is_valence_tmpj,focc_tmpj,      &
            spin_tmpk,state_tmpk,n_qnum_tmpk,l_qnum_tmpk, &
            k_qnum_tmpk,j2_qnum_tmpk,                     &
            is_solve_tmpk,is_valence_tmpk,focc_tmpk)
        !+++++++++++++++++++++++++++++++++++++++++++++++++++
         fe1 = 0.d0 ; fe2 = 0.d0
         do ishell = 1,nshell
            fe1 = fe1 + focc(ishell)
         end do
         if (abs(fe1 - felec) > 1.d-8) then
            write(IFLOG,*) '### ERROR ### fe1 != felec'
            write(IFLOG,*) '   fe1   ...',fe1
            write(IFLOG,*) '   felec ...',felec
            ier = 3 ; go to 99
         end if
      case ('core_potential')
         read(buffer,*) keyword, core_type
         select case (core_type)
         case ('normal', 'NORMAL', 'Normal')
            core_type_explained = '-Z/r'
            is_core = NORMAL
            lmax_core = 0
         case ('patom', 'PATOM', 'Patom')
            core_type_explained = 'Pseudo-atom (Poly-12)'
            is_core = PATOM
            read(IFIN,*) keyword, sub_keyword
            select case (sub_keyword)
            case ('s', 'S')
               lmax_core = 0
            case ('p', 'P')
               lmax_core = 1
            case ('d', 'D')
               lmax_core = 2
            case ('f', 'F')
               lmax_core = 3
            case default
               write(IFLOG,*) '### ERROR ### lmax_core'
               ier = 1 ; go to 99
            end select
           !+++++++++++++++++++++++++++++++++++++++
            allocate(rcut_core(0:lmax_core), &
                     vcut_core(0:lmax_core))
               rcut_core = 0.d0 ; vcut_core = 0.d0
           !+++++++++++++++++++++++++++++++++++++++
            rcut_core(:) = 0.d0 ; vcut_core(:) = 0.d0
            do ll = 0,lmax_core
              read(IFIN,*) keyword, rcut_core(ll), vcut_core(ll)
            end do
         case default
            write(IFLOG,*) '### ERROR ### core_type'
            write(IFLOG,*) '   core_type ... ',core_type
            ier = 1 ; go to 99
         end select
      case ('xc_potential')
         select case (fn_number_of_words(buffer))
         case (2)
            read(buffer,*) keyword, xc_type
            xc_approx = 'momo'
         case (3)
            read(buffer,*) keyword, xc_type, xc_approx
         end select
         select case (xc_type)
         case ('pz81', 'ldapz81', 'ldapz', &
               'PZ81', 'LDAPZ81', 'LDAPZ')
            is_xc_class = LDA
            xc_type_explained = 'LDA (PZ81)'
            is_xc = LDAPZ81
         case ('pw92', 'ldapw92', 'pw91', 'ldapw91', &
               'PW92', 'LDAPW92', 'PW91', 'LDAPW91')
            is_xc_class = LDA
            select case (xc_approx)
            case ('none')
               xc_type_explained = 'LDA (PW92-MOMO)'
               is_xc = LDAPW92_MOMO
            case ('momo', 'MOMO')
               xc_type_explained = 'LDA (PW92-MOMO)'
               is_xc = LDAPW92_MOMO
            case ('momo2', 'MOMO2')
               xc_type_explained = 'LDA (PW92-MOMO2)'
               is_xc = LDAPW92_MOMO2
            case ('jrcat', 'JRCAT', 'gncpp', 'GNCPP')
               xc_type_explained = 'LDA (PW92-GNCPP)'
               is_xc = LDAPW92_GNCPP
            case default
               write(IFLOG,*) '### ERROR ### xc_approx'
               write(IFLOG,*) '   xc_type   ... ',xc_type
               write(IFLOG,*) '   xc_approx ... ',xc_approx
               ier = 1 ; go to 99
            end select
         case ('pbe96', 'ggapbe96', 'ggapbe', &
               'PBE96', 'GGAPBE96', 'GGAPBE')
            is_xc_class = GGA
            select case (xc_approx)
            case ('none')
               xc_type_explained = 'GGA (PBE96-MOMO)'
               is_xc = GGAPBE96_MOMO
            case ('momo', 'MOMO')
               xc_type_explained = 'GGA (PBE96-MOMO)'
               is_xc = GGAPBE96_MOMO
            case ('momo2', 'MOMO2')
               xc_type_explained = 'GGA (PBE96-MOMO2)'
               is_xc = GGAPBE96_MOMO2
            case ('jrcat', 'JRCAT', 'gncpp', 'GNCPP')
               xc_type_explained = 'GGA (PBE96-GNCPP)'
               is_xc = GGAPBE96_GNCPP
            case ('kato', 'Kato', 'KATO')
               xc_type_explained = 'GGA (PBE96-KATO)'
               is_xc = GGAPBE96_KATO
            case default
               write(IFLOG,*) '### ERROR ### xc_approx'
               write(IFLOG,*) '   xc_type   ... ',xc_type
               write(IFLOG,*) '   xc_approx ... ',xc_approx
               ier = 1 ; go to 99
            end select
         case ('revpbe', 'ggarevpbe', &
               'revPBE', 'ggarevPBE', &
               'REVPBE', 'GGAREVPBE')
            is_xc_class = GGA
            xc_type_explained = 'GGA (revPBE)'
            is_xc = REVPBE
         case ('xlda', 'XLDA')
            is_xc_class = LDA
            xc_type_explained = 'LDA (Exchange only)'
            is_xc = XLDA
         case ('xgga', 'XGGA')
            is_xc_class = GGA
            xc_type_explained = 'GGA (Exchange only)'
            is_xc = XGGA
         case ('none', 'NONE')
            is_xc_class = LDA
            xc_type_explained = 'None'
            is_xc = NONE
         case default
            write(IFLOG,*) '### ERROR ### xc_type'
            write(IFLOG,*) '   xc_type ... ',xc_type
            ier = 1 ; go to 99
         end select
      case ('rmesh', 'mesh')
         read(buffer,*) keyword, mesh_type
         select case (mesh_type)
         case ('manual', 'MANUAL', 'Manual')
            mesh_type_explained   = 'Logarithmic (Manual)'
            weight_type_explained = 'Extended rule'
            is_mesh   = MANUAL
            is_weight = EXTENDED
            read(IFIN,*) keyword, nmesh
            read(IFIN,*) keyword, rmin, rmax
            dx = log(rmax/rmin) / dble(nmesh-1)
         case ('standard', 'STANDARD', 'Standard', &
               'jrcat', 'JRCAT')
            mesh_type_explained   = 'Logarithmic (Standard)'
            weight_type_explained = 'Extended rule'
            is_mesh   = JRCAT
            is_weight = EXTENDED
            nmesh = 1501  ;  xh = 96.d0  ;  rmax = 60.d0
            rmin = rmax * exp(dble(1-nmesh)/xh)
            dx   = 1.d0/xh
         case default
            write(IFLOG,*) '### ERROR ### mesh_type'
            write(IFLOG,*) '   mesh_type ... ',mesh_type
            ier = 1 ; go to 99
         end select
      case ('mixing')
         read(buffer,*) keyword, mix1, mix2
      case ('anderson')
         read(buffer,*) keyword, n_anderson
      case ('conv')
         read(buffer,*) keyword
            read(IFIN,*) keyword, loop_conv
            read(IFIN,*) keyword, dee_conv
      case ('order_pc')
         read(buffer,*) keyword, iord_pc
      case ('order_diff')
         read(buffer,*) keyword, iord_diff
      case ('order_nec')
         read(buffer,*) keyword, iord_nec
      case ('order_coeff')
         read(buffer,*) keyword, iord_coeff
      case ('eps_check')
         read(buffer,*) keyword, eps_check
      case ('eps_de')
         read(buffer,*) keyword, eps_de
      case default
         cycle INPUT
      end select
end do INPUT
   sum = 0.d0
   do ishell = 1,nshell
      sum = sum + focc(ishell)
   end do
   if (abs(sum-felec) > 1.d-15) then
      write(IFLOG,*) '### ERROR ### sum of focc != felec'
      write(IFLOG,*) '   sum of focc ...',sum
      write(IFLOG,*) '   felec       ...',felec
      ier = 1 ; go to 99
   end if
   go to 99
98 continue
   ier = 100
99 continue
   end subroutine read_input_so

!=====================================================================
   subroutine calc_spin_orbit(ier)
!=====================================================================
!
!  M. Okamoto
!
!---------------------------------------------------------------------
   use parameters
   implicit none
   integer,intent(out) :: ier
   rewind(IFIN)
   call read_input_so(ier)
   if (ier /= 0) then
      write(IFLOG,*) '### ERROR ### in read_input_so' ; go to 99
   end if
  !+++++++++++++++++++++++++++++++++++++++++++++
   allocate(atom_label(NATOM),atom_name(NATOM))
  !+++++++++++++++++++++++++++++++++++++++++++++
   call set_atom_label_name(NATOM,is_core,zatom,atom_label,atom_name)
  !++++++++++++++++++++++++++++++++++++++++++++++++++++++
   allocate(rpos(nmesh),xpos(nmesh),wr(nmesh),wt(nmesh))
      rpos = 0.d0 ; xpos = 0.d0 ; wr = 0.d0 ; wt = 0.d0
  !++++++++++++++++++++++++++++++++++++++++++++++++++++++
   call generate_rmesh(ier,nmesh,rmin,rmax,xmin,xmax,dx,xpos,rpos,wr)
   if (ier /= 0) then
      write(IFLOG,*) '### ERROR ### in generate_rmesh' ; go to 99
   end if
  !+++++++++++++++++++++++++++++++++++++++++++++++++++++++++++++++++
   allocate(chi_gl(nmesh),chi_gr(nmesh),chi_fl(nmesh),        &
      chi_fr(nmesh),dxchi_gl(nmesh),dxchi_gr(nmesh),          &
      dxchi_fl(nmesh),dxchi_fr(nmesh),                        &
      rho(nmesh,nspin),rho_old(nmesh,nspin),rho_zeta(nmesh),  &
      engy(nshell),engy_old(nshell),vh(nmesh),                &
      ex(nmesh),ec(nmesh),vx(nmesh,nspin),vc(nmesh,nspin),    &
      chi_g(nmesh,nshell),dxchi_g(nmesh,nshell),              &
      vcoeff(-1:iord_coeff,nspin,0:lmax_core),                &
      vion(nmesh,0:lmax_core),veff(nmesh,nspin,0:lmax_core),  &
      veff_old(nmesh,nspin,0:lmax_core),dee_save(nsave_dee))
      chi_gl   = 0.d0 ; chi_gr   = 0.d0
      chi_fl   = 0.d0 ; chi_fr   = 0.d0
      dxchi_gl = 0.d0 ; dxchi_gr = 0.d0
      dxchi_fl = 0.d0 ; dxchi_fr = 0.d0
      rho      = 0.d0 ; rho_old  = 0.d0 ; rho_zeta = 0.d0
      engy     = 0.d0 ; engy_old = 0.d0 ; vh       = 0.d0
      ex       = 0.d0 ; ec       = 0.d0
      vx       = 0.d0 ; vc       = 0.d0
      chi_g    = 0.d0 ; dxchi_g  = 0.d0 ; vcoeff   = 0.d0
      vion     = 0.d0 ; veff     = 0.d0 ; veff_old = 0.d0
      dee_save = 0.d0
   if (is_calc == REL) then
      allocate(chi_f(nmesh,nshell))   ; chi_f = 0.d0
      allocate(dxchi_f(nmesh,nshell)) ; dxchi_f = 0.d0
   end if
   if (is_xc_class == GGA) then
      allocate(drho(nmesh,nspin))  ; drho = 0.d0
      allocate(ddrho(nmesh,nspin)) ; ddrho = 0.d0
   end if
   if (is_xc == GGAPBE96_MOMO2) then
      allocate( &
         rho1_rad(nmesh),rho2_rad(nmesh),                      &
         drho1_rad(nmesh),drho2_rad(nmesh),drho_rad(nmesh),    &
         fx_rad(nmesh),fc_rad(nmesh),dfx_rad(nmesh,2),         &
         dfc_rad(nmesh,2),dfxda_rad(nmesh,2),dfcda_rad(nmesh), &
         vx_rad(nmesh,2),vc_rad(nmesh,2))
      rho1_rad = 0.d0 ; rho2_rad = 0.d0 ; drho1_rad = 0.d0
      drho2_rad = 0.d0 ; drho_rad = 0.d0
      fx_rad = 0.d0 ; fc_rad = 0.d0
      dfx_rad = 0.d0 ; dfc_rad = 0.d0
      dfxda_rad = 0.d0 ; dfcda_rad = 0.d0
      vx_rad = 0.d0 ; vc_rad = 0.d0
   end if
   if (n_anderson > 0) then
      allocate(rho_p(nmesh,nspin,0:n_anderson),                   &
         rho_old_p(nmesh,nspin,0:n_anderson),coeff_p(n_anderson), & 
         mat_p(n_anderson,n_anderson),vec_p(n_anderson,1))
         rho_p = 0.d0 ; rho_old_p = 0.d0 ; coeff_p = 0.d0
         mat_p = 0.d0 ; vec_p = 0.d0
   end if
  !+++++++++++++++++++++++++++++++++++++++++++++++++++++++++++++++++
   call set_vion(ier)
   if (ier /= 0) then
      write(IFLOG,*) '### ERROR ### in set_vion' ; go to 99
   end if
   call set_init_state(ier)
   if (ier /= 0) then
      write(IFLOG,*) '### ERROR ### in set_init_state' ; go to 99
   end if
   call calc_scf(ier)
   if (ier /= 0) then
      write(IFLOG,*) '### ERROR ### in calc_scf' ; go to 99
   end if
   nshell_so = nshell
  !+++++++++++++++++++++++++++++++++++++++++++++++++++++++++
   allocate(state_so(nshell_so),spin_label_so(nshell_so), &
      spin_so(nshell_so),focc_so(nshell_so),              &
      is_valence_so(nshell_so),is_solve_so(nshell_so),    &
      n_qnum_so(nshell_so),l_qnum_so(nshell_so),          &
      k_qnum_so(nshell_so),j2_qnum_so(nshell_so),         &
      list_shell_so(nshell_so),nocc_so(nshell_so),        &
      nrm_pos_so(nshell_so),nrt_pos_so(nshell_so),        &
      nmm_pos_so(nshell_so),engy_so(nshell_so))
      spin_so       = 0 ; focc_so  = 0.d0
      is_valence_so = 0 ; is_solve_so = 0
      n_qnum_so     = 0 ; l_qnum_so   = 0
      k_qnum_so     = 0 ; j2_qnum_so  = 0
      list_shell_so = 0 ; nocc_so     = 0
      nrm_pos_so    = 0 ; nrt_pos_so  = 0
      nmm_pos_so    = 0 ; engy_so  = 0.d0
  !+++++++++++++++++++++++++++++++++++++++++++++++++++++++++
   state_so(:)      = state(:)      ; spin_label_so(:) = spin_label(:)
   spin_so(:)       = spin(:)       ; focc_so(:)       = focc(:)
   is_valence_so(:) = is_valence(:) ; is_solve_so(:)   = is_solve(:)
   n_qnum_so(:)     = n_qnum(:)     ; l_qnum_so(:)     = l_qnum(:)
   k_qnum_so(:)     = k_qnum(:)     ; j2_qnum_so(:)    = j2_qnum(:)
   list_shell_so(:) = list_shell(:) ; nocc_so(:)       = nocc(:)
   nrm_pos_so(:)    = nrm_pos(:)    ; nrt_pos_so(:)    = nrt_pos(:)
   nmm_pos_so(:)    = nmm_pos(:)    ; engy_so(:)       = engy(:)
   felec_so         = felec         ; ekin_sum_so      = ekin_sum
   eion_sum_so      = eion_sum      ; eh_sum_so        = eh_sum
   exc_sum_so       = exc_sum       ; vxc_sum_so       = vxc_sum
   ex_sum_so        = ex_sum        ; ec_sum_so        = ec_sum
   vx_sum_so        = vx_sum        ; vc_sum_so        = vc_sum
   eband_sum_so     = eband_sum     ; etot_sum_so      = etot_sum
  !++++++++++++++++++++++++++++++++++++++++++++++++++++++++++++++
   deallocate(atom_label,atom_name)
   deallocate(rpos,xpos,wr,wt)
   deallocate(chi_gl,chi_gr,chi_fl,chi_fr,dxchi_gl,dxchi_gr,   &
      dxchi_fl,dxchi_fr,rho,rho_old,rho_zeta,engy,engy_old,vh, &
      ex,ec,vx,vc,chi_g,dxchi_g,vcoeff,vion,veff,              &
      veff_old,dee_save)
   if (allocated(chi_f)) then
      deallocate(chi_f,dxchi_f)
   end if
   if (allocated(drho)) then
      deallocate(drho,ddrho)
   end if
   if (allocated(rho1_rad)) then
      deallocate(rho1_rad,rho2_rad,drho1_rad, &
         drho2_rad,drho_rad,fx_rad,fc_rad,    &
         dfx_rad,dfc_rad,dfxda_rad,dfcda_rad, &
         vx_rad,vc_rad)
   end if   
   if (allocated(rho_p)) then
      deallocate(rho_p,rho_old_p,coeff_p,mat_p,vec_p)
   end if
   deallocate(state_in,focc_in,is_valence_in,is_solve_in, &
      n_qnum_in,l_qnum_in)
   deallocate(state,spin_label,spin,focc,is_valence,is_solve, &
      n_qnum,l_qnum,k_qnum,j2_qnum,list_shell,nocc, &
      nrm_pos,nrt_pos,nmm_pos)
   if (allocated(rcut_core)) then
      deallocate(rcut_core,vcut_core)
   end if
  !++++++++++++++++++++++++++++++++++++++++++++++++++++++++++++++
99 continue
   end subroutine calc_spin_orbit

!=====================================================================
   subroutine write_energy_level_so(ifile)
!=====================================================================  
!
!  M. Okamoto
!
!---------------------------------------------------------------------
   use parameters
   implicit none
   integer,intent(in) :: ifile
   integer        :: i, nn, ll, ishell, lshell
   character(100) :: line
   do i = 1,100
      line(i:i)='-'
   end do
   write(ifile,*)
   write(ifile,*) 'eng  Energy levels [All-electron]'
   write(ifile,10) line(1:100)
   write(ifile,11) 'symm','j', &
                   'Energy (Ha)','Energy (eV)','nocc','focc'
   write(ifile,10) line(1:100)
   do ishell = 1,nshell_so
      lshell = list_shell_so(ishell)
      if (is_solve_so(lshell) == 0) then
         cycle
      end if
      nn = n_qnum_so(lshell)
      ll = l_qnum_so(lshell)
      write(ifile,12) state_so(lshell)(1:2),j2_qnum_so(lshell), &
         engy_so(lshell),engy_so(lshell)*HARTREE, &
         nocc_so(lshell),focc_so(lshell)
   end do
   write(ifile,10) line(1:100)
   write(ifile,13) 'Total number of electrons',felec_so
   write(ifile,10) line(1:100)
10 format(1x,'eng',a71)
11 format(1x,'eng',(3x,a4),(4x,a1,1x),2(9x,a11),(2x,a4),(6x,a4))
12 format(1x,'eng',(4x,a2,1x),(3x,i1,'/2'),2(f20.10),i6,f10.5)
13 format(1x,'eng',2x,a25,32x,f10.5)
   end subroutine write_energy_level_so

!=====================================================================
   subroutine write_etot_so(ifile)
!=====================================================================
!
!  M. Okamoto
!
!---------------------------------------------------------------------
   use parameters
   implicit none
   integer,intent(in) :: ifile
   integer        :: i
   character(100) :: line
   do i = 1,100
      line(i:i) = '-'
   end do
   write(ifile,*)
   write(ifile,*)  'etot  Total energy [All-electron]'
   write(ifile,10) line(1:100)
   write(ifile,11) 'Energy (Ha)','Energy (eV)'
   write(ifile,10) line(1:100)
   write(ifile,20) 'Ekin  ',ekin_sum_so ,ekin_sum_so *HARTREE
   write(ifile,20) 'Eion  ',eion_sum_so ,eion_sum_so *HARTREE
   write(ifile,20) 'Eh    ',eh_sum_so   ,eh_sum_so   *HARTREE
   write(ifile,20) 'Exc   ',exc_sum_so  ,exc_sum_so  *HARTREE
   write(ifile,10) line(1:100)
   write(ifile,20) 'Ex    ',ex_sum_so   ,ex_sum_so   *HARTREE
   write(ifile,20) 'Ec    ',ec_sum_so   ,ec_sum_so   *HARTREE
   write(ifile,20) 'Vx    ',vx_sum_so   ,vx_sum_so   *HARTREE
   write(ifile,20) 'Vc    ',vc_sum_so   ,vc_sum_so   *HARTREE
   write(ifile,20) 'Vxc   ',vxc_sum_so  ,vxc_sum_so  *HARTREE
   write(ifile,20) 'Eband ',eband_sum_so,eband_sum_so*HARTREE
   write(ifile,10) line(1:100)
   write(ifile,20) 'Etot  ',etot_sum_so ,etot_sum_so *HARTREE
   write(ifile,10) line(1:100)
   write(ifile,*)  'etot  Ekin = Eband - Veff = Eband - Eion - 2Eh - Vxc'
   write(ifile,*)  'etot  Etot = Eband - Eh + (Exc - Vxc)'
10 format(1x,'etot',a50)
11 format(1x,'etot',2x,6x,2(9x,a11))
20 format(1x,'etot',2x,a6,2(f20.10))
   end subroutine write_etot_so

