! ************************************************************* 
!
!   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) : set_vion, calc_vh, calc_veff
!  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 set_vion(ier)
!=====================================================================
!
!  M. Okamoto
!
!---------------------------------------------------------------------
   use parameters
   implicit none
   integer,intent(out) :: ier
   integer :: ir, ll
   real(8) :: r, fn_patom_poly12, b_ok(0:3)
   ier = 0
   select case (is_core)
   case (NORMAL)
      vion(:,lmax_core) = - fatom / rpos(:)
   case (PATOM)
      do ll = 0,lmax_core
      do ir = 1,nmesh
         r = rpos(ir)
         if (r < rcut_core(ll)) then
            vion(ir,ll) = &
               fn_patom_poly12(r,fatom,rcut_core(ll),vcut_core(ll))
         else
            vion(ir,ll) = - fatom / r
         end if
      end do
      end do
   case (OZAKI_KINO)
      ll = lmax_core
      call calc_coeff_ok_poly3(fatom,rcut_ok,drcl_ok,h_ok,b_ok)
      do ir = 1,nmesh
         r = rpos(ir)
         if (r < rcut_ok - drcl_ok) then
            vion(ir,ll) = - fatom / r
         else if (r < rcut_ok) then
            vion(ir,ll) = &
               b_ok(0) + r*(b_ok(1) + r*(b_ok(2) + r*b_ok(3)))
         else
            vion(ir,ll) = h_ok
         end if
      end do
      do ir = nmesh,1,-1
         r = rpos(ir)
         if (r < rcut_ok) then
            nrcut_ok = ir+1 ; exit
         end if
      end do
   end select
99 continue
   end subroutine set_vion

!=====================================================================
   subroutine calc_vh(ier)
!=====================================================================
!
!  M. Okamoto
!
!---------------------------------------------------------------------
   use parameters
   implicit none
   integer,intent(out) :: ier
   integer :: ir, ii, i0, is, j, jr, ispin
   real(8) :: sum1, sum2
   ier = 0
   do ir = 1,nmesh
      sum1 = 0.d0
      sum2 = 0.d0
      if (ir == 1) then
         sum1 = 0.d0
      else if ((ir >= 2).and.(ir <= 5)) then
         do ii = 2,ir
            i0 = ii-1
            is = 1
            call set_open_weight_exp(ier,i0,is,rpos,wt)
            do ispin = 1,nspin
            do j = 1,4
               sum1 = sum1 &
                    + rpos(i0+j*is)**2*rho(i0+j*is,ispin)*wt(i0+j*is)
            end do
            end do
         end do
      else
         call set_weight_exp(ier,1,ir,rpos,wt)
         do ispin = 1,nspin
         do jr = 1,ir
            sum1 = sum1 + rpos(jr)**2*rho(jr,ispin)*wt(jr)
         end do
         end do
      end if
      sum1 = sum1*(4.d0*PI/rpos(ir))
      if (ir == nmesh) then
            sum2 = 0.d0
      else if ((ir <= nmesh-1).and.(ir >= nmesh-4)) then
         do ii = ir,nmesh-1
            i0 = ii+1
            is = -1
            call set_open_weight_exp(ier,i0,is,rpos,wt)
            do ispin = 1,nspin
            do j = 1,4
               sum2 = sum2 &
                    - rpos(i0+j*is)**2*rho(i0+j*is,ispin)*wt(i0+j*is)
            end do
            end do
         end do
      else
         call set_weight_exp(ier,ir,nmesh,rpos,wt)
         do ispin = 1,nspin
         do jr = ir,nmesh
            sum2 = sum2 + rpos(jr)*rho(jr,ispin)*wt(jr)
         end do
         end do
      end if
      sum2 = sum2*(4.d0*PI)
      vh(ir) = sum1 + sum2
   end do
99 continue
   end subroutine calc_vh

!=====================================================================
   subroutine calc_vxc(ier)
!=====================================================================
!
!  M. Okamoto
!
!---------------------------------------------------------------------
   use parameters
   implicit none
   integer,intent(out) :: ier
   integer :: imode
   ier = 0
   select case (is_xc)
   case(LDAPZ81)
      call calc_xc_lda_pz81(ier)
      if (ier /= 0) then
         write(IFLOG,*) '### ERROR ### in calc_xc_lda_pz81'
         write(IFLOG,*) '   ier ...',ier ; go to 99
      end if
   case(LDAPW92_MOMO, LDAPW92_MOMO2)
      call calc_xc_lda_pw92(ier)
      if (ier /= 0) then
         write(IFLOG,*) '### ERROR ### in calc_xc_lda_pw92'
         write(IFLOG,*) '   ier ...',ier ; go to 99
      end if
   case(LDAPW92_GNCPP, GGAPBE96_GNCPP, GGAPBE96_KATO)
      ier = 1 ! call calc_xc_gga_gncpp(ier)
      if (ier /= 0) then
         write(IFLOG,*) '### ERROR ### in calc_xc_gga_gncpp'
         write(IFLOG,*) '   ier ...',ier ; go to 99
      end if
   case(GGAPW91_F90, GGAPW91_F77)
      ier = 1 ! call calc_xc_gga_gncpp(ier)
      if (ier /= 0) then
         write(IFLOG,*) '### ERROR ### in calc_xc_gga_gncpp(gga)'
         write(IFLOG,*) '   ier ...',ier ; go to 99
      end if
   case(GGAPBE96_MOMO)
      imode = 0
      call calc_xc_gga_pbe96(ier,imode)
      if (ier /= 0) then
         write(IFLOG,*) '### ERROR ### in calc_xc_gga_pbe96'
         write(IFLOG,*) '   ier   ...',ier
         write(IFLOG,*) '   imode ...',imode
         go to 99
      end if
   case(GGAPBE96_MOMO2)
      imode = 0
      call calc_xc_gga_pbe96_rad(ier,imode)
      if (ier /= 0) then
         write(IFLOG,*) '### ERROR ### in calc_xc_gga_pbe96_rad'
         write(IFLOG,*) '   ier   ...',ier
         write(IFLOG,*) '   imode ...',imode
         go to 99
      end if
   case(REVPBE)
      imode = 1
      call calc_xc_gga_pbe96(ier,imode)
      if (ier /= 0) then
         write(IFLOG,*) '### ERROR ### in calc_xc_gga_pbe96'
         write(IFLOG,*) '   ier   ...',ier
         write(IFLOG,*) '   imode ...',imode
         go to 99
      end if
   case(GGAPW91_MOMO, GGAPW91_MOMO2)
      call calc_xc_gga_pw91_rad(ier)
      if (ier /= 0) then
         write(IFLOG,*) '### ERROR ### in calc_xc_gga_pw91_rad'
         write(IFLOG,*) '   ier   ...',ier
         go to 99
      end if
   case(XLDA)
      call calc_x_lda(ier)
      if (ier /= 0) then
         write(IFLOG,*) '### ERROR ### in calc_x_lda'
         write(IFLOG,*) '   ier ...',ier ; go to 99
      end if
   case(XGGA)
      call calc_x_gga(ier)
      if (ier /= 0) then
         write(IFLOG,*) '### ERROR ### in calc_x_gga'
         write(IFLOG,*) '   ier ...',ier ; go to 99
      end if
   case(NONE)
      call calc_xc_none(ier)
      if (ier /= 0) then
         write(IFLOG,*) '### ERROR ### in calc_xc_none'
         write(IFLOG,*) '   ier ...',ier ; go to 99
      end if
   end select
99 continue
end subroutine calc_vxc

!=====================================================================
   subroutine calc_veff(ier)
!=====================================================================
!
!  M. Okamoto
!
!---------------------------------------------------------------------
   use parameters
   implicit none
   integer,intent(out) :: ier
   integer :: ispin, ll

   integer :: ir

   ier = 0
   call calc_vh(ier)
   if (ier /= 0) then
      write(IFLOG,*) '### ERROR ### in calc_vh'
      write(IFLOG,*) '   ier ...',ier ; go to 99
   end if
   call calc_vxc(ier)
   if (ier /= 0) then
      write(IFLOG,*) '### ERROR ### in calc_vxc'
      write(IFLOG,*) '   ier ...',ier ; go to 99
   end if
   do ll = 0,lmax_core
   do ispin = 1,nspin
      veff(:,ispin,ll) = vion(:,ll) + vh(:) &
                        + vx(:,ispin) + vc(:,ispin)
#if 0
      Do ir=1, nmesh
         write(900,*) rpos(ir), veff(ir,ispin,ll)
      End Do
#endif

   end do
   end do
99 continue
   end subroutine calc_veff


! ===== KT_add ==== 4.2
subroutine calc_veff_sol( veff_sol )
  use parameters
  implicit none
!
  real(8) :: veff_sol( nmesh, nspin )

  integer :: ispin

  do ispin = 1,nspin
     veff_sol(:,ispin) = vloc_ion_us(:,ispin) + vh_sol(:) &
          &            + vx_sol(:,ispin) + vc_sol(:,ispin)
  end do
end subroutine calc_veff_sol

subroutine calc_soc_valence_kt
  use parameters
  implicit none
  
  real(8), parameter :: InvHyperFineConst = 137.035999679D0
  real(8) :: HyperFineConst

! -------
  logical :: use_MassCorrection = .true.
!  logical :: use_MassCorrection = .false.
!
  logical :: use_rphi_Hsoc_rphi = .true.
! -------

  integer :: ispin, ir, ier, count
  integer :: lt1, lt2, n1, n2, l1, l2, t1, t2
  real(8) :: fac1, fac2, r
  real(8) :: c1, c2, c3, c4, sum1, sum2

  integer :: nrc1, nrc2, nrc
  real(8), allocatable :: d_veff(:,:), wght(:)
  real(8), allocatable :: d_veff_us(:,:), veff_sol(:,:)

! ---------
!!  if ( nspin == 2 ) stop "nspin = 2 is not supported"
  if ( lmax_core > 0 ) stop "lmax_core >0 is not supported"

  allocate( d_veff(nmesh,nspin) ); d_veff = 0.0d0
!
  if ( use_rphi_Hsoc_rphi ) then
     allocate( veff_sol(nmesh,nspin) ); veff_sol = 0.d0
     allocate( d_veff_us(nmesh,nspin) ); d_veff_us = 0.0d0
     call calc_veff_sol( veff_sol ) 
  endif

! ---------
  HyperFineConst = 1.0d0 / InvHyperFineConst
  fac1 = 0.5d0 * HyperFineConst**2

  write(IFGNCPP2,'(A)') 'SOC-VALENCE [ASMS extension]'

  Do ispin=1, nspin
     call calc_diff_exp( ier,iord_diff, nmesh, rpos(1), veff(1,ispin,lmax_core), &
          &              d_veff(1,ispin) )
     do ir = nmesh-iord_diff*2-1,nmesh
        d_veff(ir,ispin)    = d_veff(    nmesh-iord_diff*2-2,ispin )
     end do

     if ( use_massCorrection ) then
        Do ir=1, nmesh
           r = rpos(ir)
           fac2 = 1.0d0 - veff(ir,ispin,lmax_core) *HyperFineConst **2
           d_veff(ir,ispin)    = fac1 *d_veff(ir,ispin)    /r /fac2
        End do
     else
        Do ir=1, nmesh
           r = rpos(ir)
           d_veff(ir,ispin)    = fac1 *d_veff(ir,ispin) /r
        End do
     endif
  End do

  if ( use_rphi_Hsoc_rphi ) then
     Do ispin=1, nspin
        call calc_diff_exp( ier,iord_diff, nmesh, rpos(1), veff_sol(1,ispin), &
             &              d_veff_us(1,ispin) )
        do ir = nmesh-iord_diff*2-1,nmesh
           d_veff_us(ir,ispin) = d_veff_us( nmesh-iord_diff*2-2,ispin )
        end do

        if ( use_massCorrection ) then
           Do ir=1, nmesh
              r = rpos(ir)
              fac2 = 1.0d0 - veff(ir,ispin,lmax_core) *HyperFineConst **2
              d_veff_us(ir,ispin) = fac1 *d_veff_us(ir,ispin) /r /fac2
           End do
        else
           Do ir=1, nmesh
              r = rpos(ir)
              d_veff_us(ir,ispin) = fac1 *d_veff_us(ir,ispin) /r
           End do
        endif
     End do
  endif
! ---------

#if 0
  Do ir=1, nmesh
     c1 = 0.0d0;  c2 = 0.0d0;  c3 = 0.0d0;  c4 = 0.0d0
     Do ispin=1, nspin
        c1 = c1 +  veff(ir,ispin,lmax_core)
        c2 = c2 +d_veff(ir,ispin)

        c3 = c3 +  veff_sol(ir,ispin)
        c4 = c4 +d_veff_us(ir,ispin)
     End do
     c1 = c1 /dble(nspin);  c2 = c2 /dble(nspin)
     c3 = c3 /dble(nspin);  c4 = c4 /dble(nspin)

     write(900,*) rpos(ir), c1, c2
     write(901,*) rpos(ir), c3, c4
  End Do
#endif
  
  count = 0

  Do ispin=1, nspin
     do lt1 = 1,num_ltx_us
        do lt2 = 1,num_ltx_us
           n1 = n_lt_us(lt1) ; n2 = n_lt_us(lt2)
           l1 = l_lt_us(lt1) ; l2 = l_lt_us(lt2)
           t1 = t_lt_us(lt1) ; t2 = t_lt_us(lt2)

           if ( l1 /= l2 ) cycle
           if ( l1 == 0 ) cycle

           count = count +1
        End do
     end do
  end Do

  write(IFGNCPP2,*) count

  Do ispin=1, nspin
     MAIN1:do lt1 = 1,num_ltx_us
        MAIN2:do lt2 = 1,num_ltx_us
           n1 = n_lt_us(lt1) ; n2 = n_lt_us(lt2)
           l1 = l_lt_us(lt1) ; l2 = l_lt_us(lt2)
           t1 = t_lt_us(lt1) ; t2 = t_lt_us(lt2)

           if ( l1 /= l2 ) cycle
           if ( l1 == 0 ) cycle

#if 0
           sum1 = 0.0d0;       sum2 = 0.0d0
           Do ir=1, nmesh
              sum1 = sum1 +wr(ir) *rpsi_us(ir,lt1) *rpsi_us(ir,lt2) &
                   &              *d_veff(ir,ispin)
              sum2 = sum2 +wr(ir) *rpsi_us(ir,lt1) *rpsi_us(ir,lt2)
           End do
           write(IFGNCPP2,'(6I4,e18.10)') n1, l1, t1, n2, l2, t2, sum1
#else
           nrc1 = nrcut_phi_us(lt1);    nrc2 = nrcut_phi_us(lt2)
           nrc = max( nrc1, nrc2 )
!
           allocate( wght(nrc) ); wght = 0.0d0
           call set_weight_exp(ier,1,nrc,rpos,wght)

           if ( use_rphi_Hsoc_rphi ) then
              sum1 = 0.0d0; sum2 = 0.0d0
              Do ir=1, nrc
                 sum1 = sum1 +wght(ir) *rpsi_us(ir,lt1) *rpsi_us(ir,lt2) &
                      &                *d_veff(ir,ispin)
                 sum2 = sum2 +wght(ir) *rphi_us(ir,lt1) *rphi_us(ir,lt2) &
                      &                *d_veff_us(ir,ispin)
              End do
              write(IFGNCPP2,'(6I4,e18.10)') n1, l1, t1, n2, l2, t2, sum1-sum2
           else
              sum1 = 0.0d0
              Do ir=1, nrc
                 sum1 = sum1 +wght(ir) *rpsi_us(ir,lt1) *rpsi_us(ir,lt2) &
                      &                *d_veff(ir,ispin)
              End do
              write(IFGNCPP2,'(6I4,e18.10)') n1, l1, t1, n2, l2, t2, sum1
           endif

           deallocate( wght )
#endif
        End do MAIN2
     end do MAIN1
  end Do

  deallocate( d_veff )
  if ( use_rphi_Hsoc_rphi ) then
     deallocate( d_veff_us )
     deallocate( veff_sol )
  endif

end subroutine calc_soc_valence_kt

subroutine calc_soc_core_kt
  use parameters
  implicit none
  
  real(8), parameter :: InvHyperFineConst = 137.035999679D0
  real(8) :: HyperFineConst

  logical :: use_MassCorrection = .true.
!  logical :: use_MassCorrection = .false.

  integer :: ispin, ir, ier, ishell, count
  integer :: lt1, lt2, n1, n2, l1, l2, t1, t2
  real(8) :: fac1, fac2, sum1, r
  real(8) :: sum2, sum3, sum4

  real(8), allocatable :: d_veff(:,:)

! ---------
  if ( nspin == 2 ) stop "nspin = 2 is not supported"
  if ( lmax_core > 0 ) stop "lmax_core >0 is not supported"

  allocate( d_veff(nmesh,nspin) ); d_veff = 0.0d0

! ---------
  HyperFineConst = 1.0d0 / InvHyperFineConst
  fac1 = 0.5d0 * HyperFineConst**2

  write(IFGNCPP2,'(A)') 'SOC-CORE [ASMS extension]'

  Do ispin=1, nspin
     call calc_diff_exp( ier,iord_diff, nmesh, rpos(1), veff(1,ispin,lmax_core), &
          &              d_veff(1,ispin) )

     do ir = nmesh-iord_diff*2-1,nmesh
        d_veff(ir,ispin) = d_veff( nmesh-iord_diff*2-2,ispin )
     end do

     if ( use_massCorrection ) then
        Do ir=1, nmesh
           r = rpos(ir)
           fac2 = 1.0d0 - veff(ir,ispin,lmax_core) *HyperFineConst **2
           d_veff(ir,ispin) = fac1 *d_veff(ir,ispin) /r /fac2
        End do
     else
        Do ir=1, nmesh
           r = rpos(ir)
           d_veff(ir,ispin) = fac1 *d_veff(ir,ispin) /r
        End do
     endif
  End do
! ---------
  count = 0

  do ishell = 1,nshell
     if ( is_core_states(ishell) == 0 ) cycle

     n1 = n_qnum(ishell);  l1 = l_qnum(ishell)
     if ( l1 == 0 ) cycle
!
     count = count +1
  End do

  write(IFLOG,*) 
  write(IFLOG,*) '### Estimation of SO splitting of core states [asms]'

  write(IFGNCPP2,*) count

  do ishell = 1,nshell
     if ( is_core_states(ishell) == 0 ) cycle

     n1 = n_qnum(ishell);  l1 = l_qnum(ishell)
     if ( l1 == 0 ) cycle

     sum1 = 0.0d0;  
     do ir = 1,nmesh
        sum1 = sum1 + wr(ir) *chi_g(ir,ishell)**2 * d_veff(ir,1)
     end do
     sum3 = sum1 *( 2.d0*l1 +1.d0 )/2.d0

     write(IFGNCPP2,'(2I4,e18.10)') n1, l1, sum1 
     write(IFLOG,'(2I4,e18.10)') n1, l1, sum3 
  end Do

  write(IFLOG,*) 

  deallocate( d_veff )

end subroutine calc_soc_core_kt
! ================= 4.2
