!
!  Software name : CIAO (Code for Investigating Atomic Orbitals)
!  Subroutine(s) : adjust_rho, calc_rho, calc_rho_core
!                : calc_ddiff_rho_origin, calc_drho_ddrho, 
!                : calc_drho_ddrho_core, calc_drho_ddrho_pcore
!                : calc_drho, calc_drho_core, calc_drho_pcore
!                : write_rho
!  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 adjust_rho(ier,ifile,nmesh,rpos,wr,rho,felec,eps)
!=====================================================================
!
!  M. Okamoto
!
!---------------------------------------------------------------------
   implicit none
   integer,intent(in)    :: ifile, nmesh
   real(8),intent(in)    :: rpos(nmesh), wr(nmesh), felec, eps
   real(8),intent(inout) :: rho(nmesh)
   integer,intent(out)   :: ier
   integer :: ir
   real(8) :: sum, pi4
   ier = 0
   pi4 = 16.d0 * atan(1.d0)
   sum = 0.d0
   do ir = 1,nmesh
      sum = sum + rho(ir) * rpos(ir)**2 * wr(ir)
   end do
   sum = sum * pi4
   if (abs(sum-felec) > eps) then
      write(ifile,*) '### CAUTION ### sum of rho != felec'
      write(ifile,*) '   sum of rho ...',sum
      write(ifile,*) '   felec      ...',felec
      rho(:) = rho(:) * felec/sum
      write(ifile,*) 'rho was adjusted to felec.'
   end if
99 continue
   end subroutine adjust_rho

!=====================================================================
   subroutine calc_rho(ier)
!=====================================================================
!
!  M. Okamoto
!
!---------------------------------------------------------------------
   use parameters
   implicit none
   integer,intent(out) :: ier
   integer :: ir, ishell, ispin
   real(8) :: sum, pi4, fe1, fe2
   real(8),parameter :: RHOMIN = 1.d-99
   ier = 0
   pi4 = 4.d0 * PI
   rho(:,:) = 0.d0
   do ishell = 1,nshell
      ispin = (1-spin(ishell))/2 + 1
      select case (is_calc)
      case (NONREL,SREL)
         do ir = 1,nmesh
            rho(ir,ispin) = rho(ir,ispin) &
             + focc(ishell) * (chi_g(ir,ishell)/rpos(ir))**2 / pi4
         end do
      case (REL)
         do ir = 1,nmesh
            rho(ir,ispin) = rho(ir,ispin) &
             + focc(ishell) * ( (chi_g(ir,ishell)/rpos(ir))**2 &
                               +(chi_f(ir,ishell)/rpos(ir))**2 )/ pi4
         end do
      end select
   end do
   ispin = 1
   fe1 = 0.d0
   do ir = 1,nmesh
      if (rho(ir,ispin) < RHOMIN) then
         rho(ir,ispin) = 0.d0
      end if
      fe1 = fe1 + rho(ir,ispin) * pi4 * rpos(ir)**2 * wr(ir)
   end do
   sum = fe1
   if (is_spin == POLARIZED) then
      ispin = 2
      fe2 = 0.d0
      do ir = 1,nmesh
         if (rho(ir,ispin) < RHOMIN) then
            rho(ir,ispin) = 0.d0
         end if
         fe2 = fe2 + rho(ir,ispin) * pi4 * rpos(ir)**2 * wr(ir)
      end do
      sum = sum + fe2
   else
      fe2 = 0.d0
   end if
   if (is_spin_state == AUTOMATIC) then
      felec1 = fe1
      felec2 = fe2
   end if
   write(IFLOG,'(1x,a25,3f15.10)') &
        '??? charge (f1,f2,rho)...',felec1,felec2,sum
   if (abs(sum-felec) > eps_check) then
      write(IFLOG,*) '### ERROR ### sum of rho != felec'
      write(IFLOG,*) '   sum of rho ...',sum
      write(IFLOG,*) '   felec      ...',felec
      ier = 1 ; go to 99
   end if
99 continue
   end subroutine calc_rho

!=====================================================================
   subroutine calc_rho_core(ier)
!=====================================================================
!
!  M. Okamoto
!
!---------------------------------------------------------------------
   use parameters
   implicit none
   integer,intent(out) :: ier
   integer :: ir, ishell
   real(8) :: sum, pi4
   real(8),parameter :: RHOMIN = 1.d-99
   ier = 0
   pi4 = 4.d0 * PI
   rho_core(:) = 0.d0
   felec_core = 0.d0
   do ishell = 1,nshell
      if ((is_solve(ishell) /= 0).and.(is_valence(ishell) == 0)) then
      select case (is_calc)
      case (NONREL,SREL)
         do ir = 1,nmesh
            rho_core(ir) = rho_core(ir) &
             + focc(ishell) * (chi_g(ir,ishell)/rpos(ir))**2 / pi4
         end do
      case (REL)
         do ir = 1,nmesh
            rho_core(ir) = rho_core(ir) &
             + focc(ishell) * ( (chi_g(ir,ishell)/rpos(ir))**2 &
                               +(chi_f(ir,ishell)/rpos(ir))**2 )/ pi4
         end do
      end select
      felec_core = felec_core + focc(ishell)
      end if
   end do
   sum = 0.d0
   do ir = 1,nmesh
      if (rho_core(ir) < RHOMIN) then
         rho_core(ir) = 0.d0
      end if
      sum = sum + rho_core(ir) * pi4 * rpos(ir)**2 * wr(ir)
   end do
   write(IFLOG,'(1x,a25,3f15.10)') &
        '??? charge (felec_core,rho_core)...',felec_core,sum
   if (abs(sum - felec_core) > eps_check) then
      write(IFLOG,*) '### ERROR ### sum of rho_core != felec_core'
      write(IFLOG,*) '   sum of rho_core ...',sum
      write(IFLOG,*) '   felec_core      ...',felec_core
      ier = 1 ; go to 99
   end if
99 continue
   end subroutine calc_rho_core

!=====================================================================
   subroutine calc_ddiff_rho_origin(ier,np,nmesh,rpos,rho,drho,ddrho)
!=====================================================================
!
!  M. Okamoto
!
!---------------------------------------------------------------------
   implicit none
   integer,intent(out) :: ier
   integer :: np, nmesh, ip, np_lsq
   real(8) :: rpos(nmesh), rho(nmesh), drho(nmesh), ddrho(nmesh), &
              det, sum_x, sum_y, sum_xx, sum_xy, &
              ave_x, ave_y, ave_xx, ave_xy, a, b, c, &
              xi, yi
   ier    = 0
   np_lsq = 10
   sum_x  = 0.d0 ; sum_y  = 0.d0
   sum_xx = 0.d0 ; sum_xy = 0.d0
   do ip = 1,np_lsq
      xi = log(rpos(ip)) ; yi = log( max(rho(ip),1.d-30) )
      sum_x  = sum_x  + xi
      sum_y  = sum_y  + yi
      sum_xx = sum_xx + xi*xi
      sum_xy = sum_xy + xi*yi
   end do
   ave_x  = sum_x  / dble(np_lsq) ; ave_y  = sum_y  / dble(np_lsq)
   ave_xx = sum_xx / dble(np_lsq) ; ave_xy = sum_xy / dble(np_lsq)
   det = ave_xx - ave_x*ave_x
   a = (ave_xy       - ave_x*ave_y ) / det
   b = (ave_xx*ave_y - ave_x*ave_xy) / det
   c = exp(b)
   do ip = 1,np
       drho(ip) =         a/rpos(ip) *  rho(ip)
      ddrho(ip) = -(1.d0-a)/rpos(ip) * drho(ip)
   end do
99 continue
   end subroutine calc_ddiff_rho_origin

!=====================================================================
   subroutine calc_diff_rho_origin(ier,np,nmesh,rpos,rho,drho)
!=====================================================================
!
!  M. Okamoto
!
!---------------------------------------------------------------------
   implicit none
   integer,intent(in)  :: np, nmesh
   real(8),intent(in)  :: rpos(nmesh), rho(nmesh)
   integer,intent(out) :: ier
   real(8),intent(out) :: drho(nmesh)
   integer :: ip, np_lsq
   real(8) :: det, sum_x, sum_y, sum_xx, sum_xy, &
              ave_x, ave_y, ave_xx, ave_xy, a, b, c, &
              xi, yi
   ier    = 0
   np_lsq = 10
   sum_x  = 0.d0 ; sum_y  = 0.d0
   sum_xx = 0.d0 ; sum_xy = 0.d0
   do ip = 1,np_lsq
      xi = log(rpos(ip)) ; yi = log( max(rho(ip),1.d-30) )
      sum_x  = sum_x  + xi
      sum_y  = sum_y  + yi
      sum_xx = sum_xx + xi*xi
      sum_xy = sum_xy + xi*yi
   end do
   ave_x  = sum_x  / dble(np_lsq) ; ave_y  = sum_y  / dble(np_lsq)
   ave_xx = sum_xx / dble(np_lsq) ; ave_xy = sum_xy / dble(np_lsq)
   det = ave_xx - ave_x*ave_x
   a = (ave_xy       - ave_x*ave_y ) / det
   b = (ave_xx*ave_y - ave_x*ave_xy) / det
   c = exp(b)
   do ip = 1,np
      drho(ip) = a/rpos(ip) * rho(ip)
   end do
99 continue
   end subroutine calc_diff_rho_origin

!=====================================================================
   subroutine calc_drho_ddrho(ier)
!=====================================================================
!
!  M. Okamoto
!
!---------------------------------------------------------------------
   use parameters
   implicit none
   integer,intent(out) :: ier
   integer :: ir, ispin
   ier = 0
   do ispin = 1,nspin
      call calc_ddiff_exp(ier,iord_diff,nmesh,rpos(1),rho(1,ispin), &
                          drho(1,ispin),ddrho(1,ispin))
      call calc_ddiff_rho_origin(ier,iord_diff,nmesh, &
               rpos(1),rho(1,ispin),drho(1,ispin),ddrho(1,ispin))
      do ir = nmesh-iord_diff*2-1,nmesh
           rho(ir,ispin) =   rho(nmesh-iord_diff*2-2,ispin)
          drho(ir,ispin) =  drho(nmesh-iord_diff*2-2,ispin)
         ddrho(ir,ispin) = ddrho(nmesh-iord_diff*2-2,ispin)
      end do
   end do
99 continue
   end subroutine calc_drho_ddrho

!=====================================================================
   subroutine calc_drho_ddrho_core(ier)
!=====================================================================
!
!  M. Okamoto
!
!---------------------------------------------------------------------
   use parameters
   implicit none
   integer,intent(out) :: ier
   integer :: ir
   ier = 0
   call calc_ddiff_exp(ier,iord_diff,nmesh,rpos, &
                       rho_core,drho_core,ddrho_core)
   call calc_ddiff_rho_origin(ier,iord_diff,nmesh, &
                              rpos,rho_core,drho_core,ddrho_core)
   do ir = nmesh-iord_diff*2-1,nmesh
        rho_core(ir) =   rho_core(nmesh-iord_diff*2-2)
       drho_core(ir) =  drho_core(nmesh-iord_diff*2-2)
      ddrho_core(ir) = ddrho_core(nmesh-iord_diff*2-2)
   end do
99 continue
   end subroutine calc_drho_ddrho_core

!=====================================================================
   subroutine calc_drho_ddrho_pcore(ier)
!=====================================================================
!
!  M. Okamoto
!
!---------------------------------------------------------------------
   use parameters
   implicit none
   integer,intent(out) :: ier
   integer :: ir
   ier = 0
   call calc_ddiff_exp(ier,iord_diff,nmesh,rpos, &
                       rho_pcore,drho_pcore,ddrho_pcore)
   call calc_ddiff_rho_origin(ier,iord_diff,nmesh, &
                              rpos,rho_pcore,drho_pcore,ddrho_pcore)
   do ir = nmesh-iord_diff*2-1,nmesh
        rho_pcore(ir) =   rho_pcore(nmesh-iord_diff*2-2)
       drho_pcore(ir) =  drho_pcore(nmesh-iord_diff*2-2)
      ddrho_pcore(ir) = ddrho_pcore(nmesh-iord_diff*2-2)
   end do
99 continue
   end subroutine calc_drho_ddrho_pcore

!=====================================================================
   subroutine calc_drho(ier)
!=====================================================================
!
!  M. Okamoto
!
!---------------------------------------------------------------------
   use parameters
   implicit none
   integer,intent(out) :: ier
   integer :: ir, ispin
   ier = 0
   do ispin = 1,nspin
      call calc_diff_exp(ier,iord_diff,nmesh,rpos(1),rho(1,ispin), &
                          drho(1,ispin))
      call calc_diff_rho_origin(ier,iord_diff,nmesh, &
               rpos(1),rho(1,ispin),drho(1,ispin))
      do ir = nmesh-iord_diff*2-1,nmesh
           rho(ir,ispin) =   rho(nmesh-iord_diff*2-2,ispin)
          drho(ir,ispin) =  drho(nmesh-iord_diff*2-2,ispin)
      end do
   end do
99 continue
   end subroutine calc_drho

!=====================================================================
   subroutine calc_drho_core(ier)
!=====================================================================
!
!  M. Okamoto
!
!---------------------------------------------------------------------
   use parameters
   implicit none
   integer,intent(out) :: ier
   integer :: ir
   ier = 0
   call calc_diff_exp(ier,iord_diff,nmesh,rpos, &
                       rho_core,drho_core)
   call calc_diff_rho_origin(ier,iord_diff,nmesh, &
                              rpos,rho_core,drho_core)
   do ir = nmesh-iord_diff*2-1,nmesh
        rho_core(ir) =   rho_core(nmesh-iord_diff*2-2)
       drho_core(ir) =  drho_core(nmesh-iord_diff*2-2)
   end do
99 continue
   end subroutine calc_drho_core

!=====================================================================
   subroutine calc_drho_pcore(ier)
!=====================================================================
!
!  M. Okamoto
!
!---------------------------------------------------------------------
   use parameters
   implicit none
   integer,intent(out) :: ier
   integer :: ir
   ier = 0
   call calc_diff_exp(ier,iord_diff,nmesh,rpos, &
                       rho_pcore,drho_pcore)
   call calc_diff_rho_origin(ier,iord_diff,nmesh, &
                              rpos,rho_pcore,drho_pcore)
   do ir = nmesh-iord_diff*2-1,nmesh
        rho_pcore(ir) =   rho_pcore(nmesh-iord_diff*2-2)
       drho_pcore(ir) =  drho_pcore(nmesh-iord_diff*2-2)
   end do
99 continue
   end subroutine calc_drho_pcore

!=====================================================================
   subroutine write_rho(ier)
!=====================================================================
!
!  M. Okamoto
!     
!---------------------------------------------------------------------
   use parameters
   implicit none
   integer,intent(out) :: ier
   integer :: ir, ll_core
   real(8) :: zeta
   ier = 0
   open(IFRHO,file=trim(rhofile),status='unknown')
   write(IFRHO,*) 'All-electron density and potentials'
   call write_file_header(IFRHO)
   write(IFRHO,*)
   if (is_core == PATOM) then
      ll_core = 0
   else
      ll_core = lmax_core
   end if
   select case (nspin)
   case (1)
      write(IFRHO,*) 'rpos, rho, vion, vh, vx, vc'
      do ir = 1,nmesh
         write(IFRHO,10) rpos(ir),rho(ir,1), &
            vion(ir,ll_core),vh(ir),vx(ir,1),vc(ir,1)
      end do
   case (2)
      write(IFRHO,*) &
         'rpos, rho, vion, vh, <vx>, <vc>'
      do ir = 1,nmesh
         write(IFRHO,10) rpos(ir),rho(ir,1)+rho(ir,2), &               
            vion(ir,ll_core),vh(ir),(vx(ir,1)+vx(ir,2))*0.5d0, &
            (vc(ir,1)+vc(ir,2))*0.5d0                          
      end do
      write(IFRHO,*)
      write(IFRHO,*) 'rpos, rho1, rho2, zeta'
      do ir = 1,nmesh
         zeta = (rho(ir,1)-rho(ir,2))/(rho(ir,1)+rho(ir,2))
         write(IFRHO,10) rpos(ir),rho(ir,1),rho(ir,2),zeta
      end do
      write(IFRHO,*)
      write(IFRHO,*) 'rpos, vx1, vx2, vc1, vc2'
      do ir = 1,nmesh
         write(IFRHO,10) rpos(ir),vx(ir,1),vx(ir,2), &
                         vc(ir,1),vc(ir,2)
      end do
   end select
10 format(10(1pe20.10))
   close(IFRHO)
   end subroutine write_rho
