!=======================================================================
!
!  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_CD_Mag_Moment
! $Id: m_CD_Mag_Moment.f90 266 2012-11-25 11:54:22Z ktagami $
  use m_Control_Parameters,    only : noncol, ndim_magmom, kimg, iprimagmom
  use m_Const_Parameters,     only : DP, PAI4, Bohr

  use m_Ionic_System,         only : ntyp, natm, ityp, pos, cps, &
       &                             magmom_local_now, iatomn
  use m_Crystal_Structure,    only : rltv, altv

  use m_PlaneWaveBasisSet,    only : ngabc, kgp
  use m_Parallelization,      only : ista_kngp, iend_kngp, ierr, npes, mype, &
       &                             mpi_comm_group
  use m_PseudoPotential,      only : dl2p, ilmt

  use m_Charge_Density,       only : chgq_l, hsr

  use m_Files,                only : nfout

  implicit none

  include 'mpif.h'
!  integer istatus(mpi_status_size)

  real(kind=DP), allocatable :: rad_cov(:)
  real(kind=DP), allocatable :: RhoMag_on_atom(:,:)

contains
  
  subroutine m_CD_alloc_rad_cov
    allocate( rad_cov(ntyp) ); rad_cov = 0.0d0
  end subroutine m_CD_alloc_rad_cov

  subroutine m_CD_set_rad_cov_default
    integer :: it, inum
    real(kind=DP) :: rad_cov_default(120)

! -------------------
!  Ref. "Molecular Single-Bond Covalent Radii for Elements 1-118". 
!        Chemistry: A European Journal 15 (2009) 186.
! -------------------

    call set_table_rad_cov(   1,  32,  46, 133, 102,  85,  75,  71,  63,  64,  67 )
    call set_table_rad_cov(  11, 155, 139, 126, 116, 111, 103,  99,  96, 196, 171 )
    call set_table_rad_cov(  21, 148, 136, 134, 122, 119, 116, 111, 110, 112, 118 )
    call set_table_rad_cov(  31, 124, 124, 121, 116, 114, 117, 210, 185, 163, 154 )
    call set_table_rad_cov(  41, 147, 138, 128, 125, 125, 120, 128, 136, 142, 140 )
    call set_table_rad_cov(  51, 140, 136, 133, 131, 232, 196, 180, 163, 176, 174 )
    call set_table_rad_cov(  61, 173, 172, 168, 169, 168, 167, 166, 165, 164, 170 )
    call set_table_rad_cov(  71, 162, 152, 146, 137, 131, 129, 122, 123, 124, 133 )
    call set_table_rad_cov(  81, 144, 144, 151, 145, 147, 142, 223, 201, 186, 175 )
    call set_table_rad_cov(  91, 169, 170, 171, 172, 166, 166, 166, 168, 165, 167 )
    call set_table_rad_cov( 101, 173, 176, 161, 157, 149, 143, 141, 134, 129, 128 )
    call set_table_rad_cov( 111, 121, 122, 136, 143, 162, 175, 165, 157, 500, 500 )

    call convert_unit_to_bohr

    Do it=1, ntyp
       inum = iatomn(it)
       rad_cov(it) = rad_cov_default(inum)
    End do

  contains

    subroutine convert_unit_to_bohr
      rad_cov_default = rad_cov_default / 1.0D2 / Bohr  
                                 ! Note : original data is in the unit of pm.
    end subroutine convert_unit_to_bohr

    subroutine set_table_rad_cov( istart, d1, d2, d3, d4, d5, d6, d7, d8, d9, d10 )
      integer, intent(in) :: istart
      integer, intent(in) :: d1, d2, d3, d4, d5, d6, d7, d8, d9, d10

      rad_cov_default( istart    ) = dble(d1)
      rad_cov_default( istart +1 ) = dble(d2)
      rad_cov_default( istart +2 ) = dble(d3)
      rad_cov_default( istart +3 ) = dble(d4)
      rad_cov_default( istart +4 ) = dble(d5)
      rad_cov_default( istart +5 ) = dble(d6)
      rad_cov_default( istart +6 ) = dble(d7)
      rad_cov_default( istart +7 ) = dble(d8)
      rad_cov_default( istart +8 ) = dble(d9)
      rad_cov_default( istart +9 ) = dble(d10)
    end subroutine set_table_rad_cov

  end subroutine m_CD_set_rad_cov_default

  subroutine m_CD_alloc_RhoMag_on_atom
    allocate( RhoMag_on_atom(natm,ndim_magmom) ); RhoMag_on_atom = 0.0d0
  end subroutine m_CD_alloc_RhoMag_on_atom

  subroutine m_CD_set_rad_cov_now
    integer :: ia, ja, it1, it2
    integer :: nx, ny, nz

    real(kind=DP) :: x1, y1, z1, dist
    real(kind=DP) :: c1, ctmp
    real(kind=DP), allocatable :: dist_min_among_atomtypes(:,:)

    allocate( dist_min_among_atomtypes(ntyp,ntyp) )
    dist_min_among_atomtypes = 10.0d0

    Do ia=1, natm-1
       it1 = ityp(ia)
       Do ja =ia+1, natm
          it2 = ityp(ja)
!
          Do nx=-1, 1
             Do ny=-1, 1
                Do nz=-1, 1
                   x1 = cps(ja,1) -cps(ia,1) +altv(1,1)*nx +altv(1,2)*ny +altv(1,3)*nz
                   y1 = cps(ja,2) -cps(ia,2) +altv(2,1)*nx +altv(2,2)*ny +altv(2,3)*nz
                   z1 = cps(ja,3) -cps(ia,3) +altv(3,1)*nx +altv(3,2)*ny +altv(3,3)*nz
!
                   dist = sqrt( x1**2 +y1**2 +z1**2 )
                   if ( dist < dist_min_among_atomtypes(it1,it2) ) then
                      dist_min_among_atomtypes(it1,it2) = dist
                   endif
                End do
             End do
          End do
       End do
    End Do

    Do it1=1, ntyp
       Do it2=1, ntyp
          c1 = rad_cov(it1) + rad_cov(it2)
          if ( dist_min_among_atomtypes(it1,it2) < c1 ) then
             ctmp = dist_min_among_atomtypes(it1,it2) /c1
             rad_cov(it1) = rad_cov(it1) *ctmp
             rad_cov(it2) = rad_cov(it2) *ctmp
          endif
       End do
    End Do

    if ( iprimagmom >= 3 ) then
       write(nfout,*) '! ------ info : Rad_cov ------ '
       write(nfout,*) '  atmo no.   rad_cov '
       Do ia=1, natm
          it1 = ityp(ia)
          write(nfout,'(I7,F15.8)')   ia, rad_cov(it1)
       End do
       write(nfout,*) '! ---------------------------- '
    endif

  end subroutine m_CD_set_rad_cov_now

  subroutine m_CD_calc_ChgMagMom_in_sphere
    integer :: i, ia, is, it, ist
    real(kind=DP) :: rad1, fac1r, fac1i, fac2
    real(kind=DP) :: VecG(3), normG, normG3, gr, d1

    real(kind=DP), allocatable :: zfcos(:), zfsin(:)
    real(kind=DP), allocatable :: RhoMag_on_atom_mpi(:,:)

    RhoMag_on_atom = 0.0d0

    allocate(zfcos(ista_kngp:iend_kngp)); zfcos = 0.d0
    allocate(zfsin(ista_kngp:iend_kngp)); zfsin = 0.d0

    Do ia=1, natm
       it = ityp(ia)
       rad1 = rad_cov(it)

       call calc_phase2( natm, pos, ia, kgp, ngabc, ista_kngp, iend_kngp, &
            &            zfcos, zfsin )

       if ( ista_kngp == 1 ) then
          ist = 2
       else
          ist = ista_kngp
       endif

       Do i=ist, iend_kngp

          VecG(1) = rltv(1,1)*ngabc(i,1) +rltv(1,2)*ngabc(i,2) +rltv(1,3)*ngabc(i,3)
          VecG(2) = rltv(2,1)*ngabc(i,1) +rltv(2,2)*ngabc(i,2) +rltv(2,3)*ngabc(i,3)
          VecG(3) = rltv(3,1)*ngabc(i,1) +rltv(3,2)*ngabc(i,2) +rltv(3,3)*ngabc(i,3)
          
          normG = sqrt( VecG(1)**2 +VecG(2)**2 +VecG(3)**2 )
          normG3 = normG**3

          fac1r = zfcos(i); fac1i = zfsin(i)
!
          gr = normG *rad1
          fac2 = -gr *cos(gr) + sin(gr)
          fac2 = fac2 *PAI4 /normG3
!
          Do is=1, ndim_magmom
             d1 = chgq_l(i,1,is)*fac1r -chgq_l(i,kimg,is)*fac1i
             RhoMag_on_atom(ia,is) = RhoMag_on_atom(ia,is) + d1 *fac2
          End do

       End do

       if ( mype == 0 ) then
          fac2 = PAI4 /3.0d0 *rad1**3
             
          Do is=1, ndim_magmom
             d1 = chgq_l(1,1,is)
             RhoMag_on_atom(ia,is) = RhoMag_on_atom(ia,is) + d1 *fac2
          End do
       endif
       
    End Do
!
    deallocate( zfcos, zfsin )

    if ( npes > 1 ) then
       allocate( RhoMag_on_atom_mpi(natm,ndim_magmom) ); RhoMag_on_atom_mpi = 0.0d0
       call mpi_allreduce( RhoMag_on_atom, RhoMag_on_atom_mpi, natm*ndim_magmom, &
            &              mpi_double_precision, mpi_sum, mpi_comm_group, ierr )
       RhoMag_on_atom = RhoMag_on_atom_mpi
       deallocate( RhoMag_on_atom_mpi )
    endif
    
  end subroutine m_CD_calc_ChgMagMom_in_sphere

  subroutine m_CD_print_ChgMagmom_on_atom( nfout )
    integer, intent(in) :: nfout

    integer :: ia, it

    if ( iprimagmom < 2 ) return

    write(nfout,*) &
         & '! ------------ Local Magnetic Momemnt (soft+hard) at this scf step --- '
    write(nfout,*) &
         & '!   id   atom no.        tot            mx             my             mz'
    
    Do ia=1, natm
       it = ityp(ia)
       write(nfout,'(I7,F10.4,4F15.8)') ia, iatomn(it), &
            &                          RhoMag_on_atom(ia,1), &
            &                          RhoMag_on_atom(ia,2), &
            &                          RhoMag_on_atom(ia,3), &
            &                          RhoMag_on_atom(ia,4)
    End Do
    write(nfout,*) '! ---------------------------------------------'

  end subroutine m_CD_print_ChgMagmom_on_atom

! ------------------------------------------
  subroutine m_CD_estim_magmom_local( nfout )
    integer, intent(in) :: nfout

    integer :: ia, it, lmt1, lmt2, is
    real(kind=DP) :: sum, fac

!--
    Do ia=1, natm
       it = ityp(ia)

       Do is=2, ndim_magmom
          sum = 0.0d0
          Do lmt1=1, ilmt(it)
             Do lmt2=lmt1, ilmt(it)
                fac=2.d0;if(lmt1.eq.lmt2) fac=1.d0
                sum = sum + fac *hsr( ia, lmt1, lmt2, is )*dl2p(lmt1,lmt2,1,it)
             End do
          End do
!
          magmom_local_now(ia,is-1) = sum
       End do
    End Do

  end subroutine m_CD_estim_magmom_local

  subroutine m_CD_print_magmom_local( nfout )
    integer, intent(in) :: nfout

    integer :: ia, it

    if ( iprimagmom < 3 ) return

    write(nfout,*) &
         & '! ------------ Local Magnetic Momemnt ( hard part ) at this scf step --- '
    write(nfout,*) '!   id   atom no.        mx             my             mz  '
    Do ia=1, natm
       it = ityp(ia)
       write(nfout,'(I7,F10.4,3F15.8)') ia, iatomn(it), &
            &                         magmom_local_now(ia,1), &
            &                         magmom_local_now(ia,2), &
            &                         magmom_local_now(ia,3)
    End Do
    write(nfout,*) '! ---------------------------------------------'

  end subroutine m_CD_print_magmom_local

end module m_CD_Mag_Moment
