!=======================================================================
!
!  PROGRAM  PHASE/0 2014.01 (rev.375)
!
!  "First-principles Electronic Structure Calculation Program"
!
!  AUTHOR(S): K. Tagami
!  
!  Contact address :  Phase System Consortium
!                     E-mail: phase_system@nims.go.jp URL https://azuma.nims.go.jp
!  
!
!
!=======================================================================
!
!   The original version of this set of the computer programs "PHASE" was developed by 
!  the members of the Theory Group of Joint Research Center for Atom Technology 
!  (JRCAT), based in Tsukuba, in the period 1993-2001.  
!   Since 2002, this program set had been intensively developed as a part of the following 
!  national projects supported by the Ministry of Education, Culture, Sports, Science and 
!  Technology (MEXT) of Japan; "Frontier Simulation Software for Industrial Science 
!  (FSIS)" from 2002 to 2005, "Revolutionary Simulation Software (RSS21)" from 2006 to 
!  2008. "Research and Development of Innovative Simulation Software (RISS)" from 2008 
!  to 2013. These projects is lead by the Center for Research on Innovative Simulation 
!  Software (CISS), the Institute of Industrial Science (IIS), the University of Tokyo.
!   Since 2013, this program set has been further developed centering on PHASE System 
!  Consortium. 
!   The activity of development of this program set has been supervised by Takahisa Ohno.
!
module m_SpinOrbit_RadInt
! $Id: m_SpinOrbit_RadInt.f90 285 2013-01-01 04:33:41Z ktagami $
  use m_Const_Parameters,    only : DP, CMPLDP, PAI4, &
       &                             SphericalHarmonicsExpansion, &
       &                             BUILTIN, ByPawPot, ZeffApprox, yes
  use m_Files,               only : nfout

  use m_Control_Parameters,  only : nspin ,ndim_magmom, noncol, ndim_chgpot, &
       &                            SpinOrbit_MassCorrection, &
       &                            SpinOrbit_Mode

  use m_PseudoPotential,   only : ipaw, nlmt, ilmt, ltp, mtp, taup, &
       &                          lppw, tppw, wf_mnrc, radr_paw, &
       &                          iltpw, psirpw, ival, mmesh, nmesh, xh, &
       &                          lpsmax, nloc, ntau, &
       &                          pot_has_soc, ntyp

  use m_Ionic_System,          only : ityp, natm, iwei, iatomn, &
       &                              scaling_so, magmom_local_now

  use m_PAW_XC_Potential,    only : vxc_ae_k

  use m_PAW_ChargeDensity,    only : paw_dnr, surface_integral_method, &
       &                             m_PAWCD_set_ae_cd_sphex2, &
       &                             m_PAWCD_ae_cd_sphex2_nonclA

  use m_SpinOrbit_Potential,         only : Mat_LS_with_real_ylm_L0, &
       &                             Mat_LS_with_real_ylm_L1, &
       &                             Mat_LS_with_real_ylm_L2, &
       &                             Mat_LS_with_real_ylm_L3, dsoc

  use m_SpinOrbit_Potential,           only :  Mat_SOC_Strength

  use m_PseudoPotential,   only : flg_paw, Mat_SOC_Strength_nonpaw


  implicit none
  include 'mpif.h'

  integer max_sph_expansion
  parameter( max_sph_expansion = 25 )

  real(kind=DP), allocatable :: vtot_rad(:)
  real(kind=DP), allocatable :: dV_rad(:)

!
contains

  subroutine alloc_vtot_and_dV
    allocate( vtot_rad( mmesh ) ); vtot_rad = 0.0d0
    allocate( dV_rad( mmesh ) )  ; dV_rad = 0.0d0
  end subroutine alloc_vtot_and_dV
  
  subroutine dealloc_vtot_and_dV
    deallocate( vtot_rad );  deallocate( dV_rad )
  end subroutine dealloc_vtot_and_dV
    
  subroutine m_SO_calc_SOC_strength_pawpot

    integer :: ia, it, nrc, mesh_t
    real(kind=DP), allocatable :: nae_sph(:,:,:)
    real(kind=DP), allocatable :: rho_00(:)

    call alloc_nae_sph
    call alloc_rho_for_poisson

    call alloc_vtot_and_dV

    Mat_SOC_Strength = 0.0d0

    do ia = 1, natm
       it = ityp(ia)

!       if( ipaw(it)/=1 .or. &
!              & surface_integral_method(it).ne.SphericalHarmonicsExpansion) cycle

       call calc_radial_charge_Y00( ia, it, nrc, rho_00 )

       call set_rho_for_poisson_eq( it, nrc, rho_00 ) 

       call set_size_mesht( it, nrc, rho_00, mesh_t )
       call calc_Hartree_pot_Y00( 5, mesh_t, radr_paw(:,it), rho_00, vtot_rad )    
!
       call calc_total_potential_Y00( ia, it, vtot_rad )
!
       call calc_central_potential( it, nrc, vtot_rad, dV_rad )

       call integrate_central_potential2( it, nrc, dV_rad, Mat_SOC_Strength(:,:,:,ia) )

    End Do

    call dealloc_nae_sph
    call dealloc_rho_for_poisson

    call dealloc_vtot_and_dV

  contains

    subroutine alloc_nae_sph
      if ( noncol ) then
         allocate( nae_sph(mmesh,ndim_magmom,max_sph_expansion) )
      else
         allocate( nae_sph(mmesh,nspin,max_sph_expansion) )
      endif
      nae_sph = 0.0d0
    end subroutine alloc_nae_sph
    
    subroutine dealloc_nae_sph
      deallocate( nae_sph )
    end subroutine dealloc_nae_sph
    
    subroutine alloc_rho_for_poisson
      allocate( rho_00( mmesh ) ); rho_00 = 0.0d0
    end subroutine alloc_rho_for_poisson
    
    subroutine dealloc_rho_for_poisson
      deallocate( rho_00 ) 
    end subroutine dealloc_rho_for_poisson


    subroutine calc_central_potential( it, nrc, vtot_rad, dV_rad )        !  dV/dr *1/r
      integer, intent(in) :: it, nrc
      real(kind=DP), intent(in) :: vtot_rad(mmesh)
      real(kind=DP), intent(out) :: dV_rad(mmesh)
!
      real(kind=DP), parameter :: InvHyperFineConst = 137.035999679D0
      real(kind=DP) :: HyperFineConst
      real(kind=DP) :: fac1, fac2
      integer :: ir, ier
!
      HyperFineConst = 1.0d0 / InvHyperFineConst
!
      dV_rad = 0.0d0
      call calc_diff_exp( ier, 4, nrc, radr_paw(:,it), vtot_rad, dV_rad )
!
      fac1 = 0.5d0 * HyperFineConst**2
!
      if ( SpinOrbit_MassCorrection == 0 ) then
         Do ir=1, nrc
            dV_rad(ir) = fac1 *dV_rad(ir) / radr_paw(ir,it)
         End do

      else if ( SpinOrbit_MassCorrection == 1 ) then
         Do ir=1, nrc
            fac2 = 1.0d0 - vtot_rad(ir) *HyperFineConst **2
            dV_rad(ir) = fac1 *dV_rad(ir) / radr_paw(ir,it) /fac2
         End do

      else if ( SpinOrbit_MassCorrection == 2 ) then
         Do ir=1, nrc
            fac2 = 1.0d0 - vtot_rad(ir) *HyperFineConst **2 /2.0d0
            dV_rad(ir) = fac1 *dV_rad(ir) / radr_paw(ir,it) /fac2
         End do
      endif
!
      dV_rad(:) = dV_rad(:) *scaling_so(it)
!
    end subroutine calc_central_potential

    subroutine calc_total_potential_Y00( ia, it, vtot_rad )
      integer, intent(in) :: ia, it
      real(kind=DP) :: vtot_rad(mmesh)

      integer :: ir
      real(kind=DP) :: factor, c1, c2, c3

      factor = sqrt(PAI4)

!      Do ir=1, nrc
      Do ir=1, nmesh(it)
         if ( nspin==2 ) then
            c1 = vxc_ae_k( ir,1,1,ia ) + vxc_ae_k( ir,2,1,ia )
            c1 = c1 / 2.0d0
         else
            c1 = vxc_ae_k( ir,1,1,ia )
         endif
!
         c2 = -dble(iatomn(it)) / radr_paw(ir,it)
         c3 = ( c2 + vtot_rad(ir) ) *factor

         vtot_rad(ir) = c1 + c3
      End do
      vtot_rad = vtot_rad /factor
!
    end subroutine calc_total_potential_Y00

    subroutine calc_radial_charge_Y00( ia, it, nrc, rho_00 )
      integer, intent(in) :: ia, it
      integer, intent(out) :: nrc
      real(kind=DP), intent(out) :: rho_00(mmesh)

      real(kind=DP) :: wos(mmesh), factor

      integer :: ier, ir
      integer :: nrc0, dnr, zz
      
      integer :: msphmx, msph
      integer :: msphmx_chg
      integer :: num_isph_chg, isph_chg(max_sph_expansion)
      integer        :: id_sname = -1
!
      real(kind=DP), allocatable :: dummy1(:,:)
      real(kind=DP), allocatable :: dummy2(:,:,:)
!
      
      factor = sqrt(PAI4)

      dnr = paw_dnr(it)
!      dnr = 1

      rho_00 = 0.0d0

      if (dnr.gt.1) then
         nrc0 = wf_mnrc(it)
         nrc = 1 +int((nrc0-1)/dnr)*dnr
         zz = dble(nrc0-nrc)/dble(dnr)
         nrc = nrc +2*dnr                                                 ! 3rd
         call set_weight_exp3(ier,1,nrc,dnr,radr_paw(:,it),zz,wos)     !  3rd
      else
         nrc=wf_mnrc(it)
         call set_weight_exp(ier,1,nrc,radr_paw(:,it),wos)
      end if
      
      do ir=1,nrc,dnr
         wos(ir) = wos(ir)*radr_paw(ir,it)**2
      end do
      wos = wos*iwei(ia)

      msphmx_chg = 0
      msph = max_sph_expansion


      if ( noncol ) then
         allocate( dummy1(3,msph) );  allocate( dummy2(nrc,ndim_magmom,msph) )

         call m_PAWCD_ae_cd_sphex2_nonclA( ia, nspin, nrc, dnr, &
              &                           msph, nae_sph(1:nrc,:,:), msphmx_chg, &
              &                           num_isph_chg, isph_chg, wos, &
              &                           1, &
              &                           dummy1, dummy2 )

         deallocate( dummy1 );  deallocate( dummy2 )
      else
         call m_PAWCD_set_ae_cd_sphex2( ia, nspin, nrc, dnr, &
              &                         msph, nae_sph(1:nrc,:,:), msphmx_chg, &
              &                         num_isph_chg, isph_chg )
      endif
         
      if ( noncol ) then
         rho_00(:) = nae_sph( :,1,1 ) + nae_sph(:,2,1)
      else
         if ( nspin==1 ) then
            rho_00(:) = nae_sph(:,1,1)
         else if ( nspin==2 ) then
            rho_00(:) = nae_sph(:,1,1) + nae_sph(:,2,1)
         endif
      end if
!  ---------
!      if ( SpinOrbit_MassCorrection == 2 ) then
!!!         rho_00 = rho_00 *factor
!      endif
! ---
    end subroutine calc_radial_charge_Y00

    subroutine set_rho_for_poisson_eq( it, nrc, rho ) 
                                     ! 4 *pi *r**2 *rho_lm( r,l=0,ispin=1 )
      integer, intent(in) :: it, nrc
      real(kind=DP), intent(inout) :: rho(mmesh)

      integer :: ir
      Do ir=1, nrc
         rho(ir) = PAI4 *radr_paw(ir,it)**2 * rho(ir)
      End Do
    end subroutine set_rho_for_poisson_eq

    subroutine set_size_mesht( it, nrc, rho, mesh_t )
      integer, intent(in) :: it, nrc
      integer, intent(out) :: mesh_t
      real(kind=DP), intent(in) :: rho(mmesh)

      integer     :: i
      real(kind=DP), parameter :: CRDAMP = 1.d0
      real(kind=DP), parameter :: CRDIST = 10.d0

      mesh_t = nrc
      return

      do i = 10, nmesh(it)-1
         if ( rho(i) - rho(i+1) > CRDAMP .and. radr_paw(i,it) < CRDIST) then
            mesh_t = i
!            if(iprippex>=1) write(nfout,'(" LMTO pot. r_ws=",i5,f12.6)') i, radr(i)

            write(*,*) 'mesht nrc = ', mesh_t, nrc, nmesh(it)

            return
         end if
      enddo
      mesh_t = nmesh(it)

    end subroutine set_size_mesht

    subroutine calc_Hartree_pot_Y00( nsize, mesh_t, radr, rhvr, vvv )    
      integer, intent(in) :: nsize, mesh_t
      real(kind=DP), intent(in) :: radr( mmesh )
      real(kind=DP), intent(in) :: rhvr( mmesh )
      real(kind=DP), intent(out) :: vvv( mmesh )

      real(kind=DP)       :: s2, rhs, rhs1, bm
      real(kind=DP),allocatable,dimension(:) :: da, db ! d(nsize)
      real(kind=DP), allocatable :: wkx(:), wky(:), wkz(:)

      integer             :: i

      real(kind=DP) ::   hh

      hh = 1.0 / xh(it)
      allocate(wkx(mmesh)); wkx = 0.d0
      allocate(wky(mmesh)); wky = 0.d0
      allocate(wkz(mmesh)); wkz = 0.d0

     !+++++++++++++++++++++++++++++++
      allocate(da(nsize)); da = 0.d0
      allocate(db(nsize)); db = 0.d0
     !+++++++++++++++++++++++++++++++
      s2 = dlog(rhvr(2)/rhvr(1))/ hh
      rhs = rhvr(1)
      wkx(1)  = rhs*radr(1)/(s2+1)
      wky(1)  = rhs/s2
      db(1)   = hh*rhs*3.d0
      da(1)   = db(1)*radr(1)
      rhs1    = rhs
      do i = 2,3
         rhs     = rhvr(i)
         wkx(i)  = wkx(i-1) + hh *(rhs*radr(i)+rhs1*radr(i-1))*0.5d0
         wky(i)  = wky(i-1) + hh *(rhs        +rhs1          )*0.5d0
         db(i)   = hh *rhs*3.d0
         da(i)   = db(i)*radr(i)
         rhs1    = rhs
      enddo
      do i = 4,mesh_t
         rhs    = rhvr(i)
         db(4)  = hh *rhs*3.d0
         da(4)  = db(4)*radr(i)
         wkx(i)=(9*wkx(i-1)-wkx(i-3)+da(4)+2.d0*da(3)-da(2))/8.d0
         wky(i)=(9*wky(i-1)-wky(i-3)+db(4)+2.d0*db(3)-db(2))/8.d0
         da(1)  = da(2)
         db(1)  = db(2)
         da(2)  = da(3)
         db(2)  = db(3)
         da(3)  = da(4)
         db(3)  = db(4)
      enddo
      bm               = wky(mesh_t)
     !C--*--COULOMB POTENTIAL RVC
      vvv = 0.d0
      do i = 1,mesh_t
!!!         vvv(i) = wkx(i) + radr(i)*(bm-wky(i))        ! r *Vh(r)
         vvv(i) = wkx(i) + (bm-wky(i))                   ! Vh(r)
      enddo
     !+++++++++++++++++++++++++++++++
      deallocate(da); deallocate(db)
      deallocate(wkx)
      deallocate(wky)
      deallocate(wkz)
     !+++++++++++++++++++++++++++++++

    end subroutine Calc_Hartree_pot_Y00

  end subroutine m_SO_calc_SOC_strength_pawpot

  subroutine integrate_central_potential2( it, nrc, dV_rad, Mat )
    integer, intent(in) :: nrc, it
    real(kind=DP), intent(in) :: dV_rad(mmesh)
    real(kind=DP), intent(out) :: Mat( nloc, ntau, ntau )
    
    integer :: ier, ir
    integer :: ilt1, ilt2
    integer :: il1, il2, it1, it2
    real(kind=DP) :: csum, tmp1
    real(kind=DP) :: wos(mmesh)
    
    call set_weight_exp( ier, 1, nrc, radr_paw(:,it), wos )

!      write(*,*) "ilmt, iltpw, nlmt = ", ilmt(it), iltpw(it), nlmt
!      stop

    Mat = 0.0d0
    
    Do ilt1=1, iltpw(it)
       il1 = lppw(ilt1,it)
       it1 = tppw(ilt1,it)
       Do ilt2=1, iltpw(it)
          il2 = lppw(ilt2,it)
          it2 = tppw(ilt2,it)
          
          if ( il1 /= il2 ) cycle
          
          csum = 0.0d0
          Do ir=1, nrc
             tmp1 = dV_rad(ir) *psirpw( ir, il1, it1, it )  &
                  &            *psirpw( ir, il2, it2, it )  &
                  &            *wos(ir)
             
             csum  = csum + tmp1
          End do
          Mat( il1, it1, it2 ) = csum
       End do
    End Do

  end subroutine integrate_central_potential2

  subroutine m_SO_check_mode_Builtin
    integer it
!
    Do it=1, 1
       if ( pot_has_soc(it) ) then
          
          if ( SpinOrbit_Mode /= BUILTIN ) then
             SpinOrbit_Mode = BUILTIN
             write(nfout,*) '** ------------------------- **'
             write(nfout,*) '** SpinOrbit mode is force to set to BUILTIN'
          endif
       else
          if ( SpinOrbit_Mode == BUILTIN ) then
             write(nfout,*) '** ------------------------- **'
             write(nfout,*) &
                  & '** Please use the spin-orbit splitted pseudopotential '
             write(nfout,*) &
                  & '** for atom type ', it
             stop
          endif
       endif
    End do

    if ( SpinOrbit_Mode == BUILTIN ) then
       Do it=2, ntyp
          if ( .not. pot_has_soc(it) ) then
             write(nfout,*) '** ------------------------- **'
             write(nfout,*) &
                  & '** Please use the spin-orbit splitted pseudopotential '
             write(nfout,*) &
                  & '** for atom type ', it
             stop
          endif
       End do
    end if
!
  end subroutine m_SO_check_mode_Builtin

  subroutine m_SO_check_mode_Pawpot
    integer it
!
    if ( SpinOrbit_Mode == BUILTIN ) return
    if ( SpinOrbit_Mode == ByPawPot ) then
       Do it=1, ntyp
          if ( ipaw(it) /= yes ) then
             write(nfout,*) '** ------------------------- **'
             write(nfout,*) &
                  & '** Please use the paw pseudopotential for atom type ', it
             write(nfout,*) '*** and confirm that "paw = off" is commeted out in the accuracy tag '
             stop
          endif
       End Do
    endif
!
  end subroutine m_SO_check_mode_Pawpot

  subroutine m_SO_check_mode_Zeff
    integer it
!
    if ( SpinOrbit_Mode == BUILTIN ) return
    if ( SpinOrbit_Mode == ByPawPot ) return

    if ( SpinOrbit_Mode == ZeffApprox ) then

    endif
!
  end subroutine m_SO_check_mode_Zeff

  subroutine m_SO_calc_SOC_strength_zeff
    integer :: ia, it, nrc

    Mat_SOC_Strength = 0.0d0

    if ( flg_paw ) then
       call alloc_vtot_and_dV

       do ia = 1, natm
          it = ityp(ia)
          nrc = wf_mnrc(it)
          call calc_central_pot_zeff( it, nrc, dV_rad )
          call integrate_central_potential2( it, nrc, dV_rad, &
               &                              Mat_SOC_Strength(:,:,:,ia) )
       End Do

       call dealloc_vtot_and_dV
    else
       Do ia=1, natm
          it = ityp(ia)
          Mat_SOC_Strength(:,:,:,ia) = Mat_SOC_Strength_nonpaw(:,:,:,it)  &
               &                       * scaling_so(it)
       End do
    endif 

  contains

    subroutine calc_central_pot_zeff( it, nrc, dV_rad )        !  dV/dr *1/r
      integer, intent(in) :: it, nrc
      real(kind=DP), intent(out) :: dV_rad(mmesh)
!
      real(kind=DP), parameter :: InvHyperFineConst = 137.035999679D0
      real(kind=DP) :: HyperFineConst
      real(kind=DP) :: fac1, fac2
      integer :: ir, ier
!
      HyperFineConst = 1.0d0 / InvHyperFineConst
!
      dV_rad = 0.0d0
      fac1 = 0.5d0 * HyperFineConst**2

      if ( SpinOrbit_MassCorrection == 0 ) then
         Do ir=1, nrc
            dV_rad(ir) = fac1 *dble(iatomn(it)) / radr_paw(ir,it)**3
         End do

      else if ( SpinOrbit_MassCorrection == 1 ) then
         Do ir=1, nrc
            fac2 = 1.0d0 + HyperFineConst**2 &
                 &         *dble(iatomn(it))/ radr_paw(ir,it) 
            dV_rad(ir) = fac1 *dble(iatomn(it)) / radr_paw(ir,it)**3 /fac2
         End do

      else if ( SpinOrbit_MassCorrection == 2 ) then
         Do ir=1, nrc
            fac2 = 1.0d0 + HyperFineConst**2 /2.0d0 &
                 &         *dble(iatomn(it))/ radr_paw(ir,it) 
            dV_rad(ir) = fac1 *dble(iatomn(it)) / radr_paw(ir,it)**3 /fac2
         End do

      end if
!
      dV_rad(:) = dV_rad(:) * scaling_so(it)
!
    end subroutine calc_central_pot_zeff

  end subroutine m_SO_calc_SOC_strength_zeff

end module m_SpinOrbit_RadInt
