! ************************************************************* 
!
!   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) : calc_rho_pcore_sol, check_rho_pcore_sol
!                  write_checked_pcc_sol, calc_pcc_fourier_sol
!                  write_pcc_sol
!  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 calc_rho_pcore_sol(ier)
!=====================================================================
!
!  M. Okamoto
!
!---------------------------------------------------------------------
  use parameters
  implicit none

  integer,intent(out) :: ier
  integer :: ir, isdiff, n1, n2

! ============================= added by K. T. =================== 4.0
  real(8) :: rho_tmp
! ================================================================ 4.0

  ier = 0

  select case (is_pcc_rad)

  case (PCC_RATIO)

     do ir = 1,nmesh

! ============================= added by K. T. ===================== 4.0
        if ( nspin == 1 ) then
           rho_tmp = rho_ps(ir,1)
        else if ( nspin == 2 ) then
           rho_tmp = rho_ps(ir,1) +rho_ps(ir,2)
        endif
! ================================================================== 4.0

! ========================================== modified by K. T. ================ 4.0
!         if (rho_core(ir) < r0_pcc*rho_ps(ir)) then
        if (rho_core(ir) < r0_pcc*rho_tmp ) then
! ============================================================================== 4.0
           nr0_pcc = ir-1 ; r0_pcc = rpos(ir)
           exit
        end if

        if (ir == nmesh) then
           write(IFLOG,*) '### ERROR ### r0_pcc cannot be found'
           ier = 1 ; go to 99
        end if

     end do

  case (PCC_RC)

     do ir = nmesh,1,-1
        if (rpos(ir) < r0_pcc) then
           nr0_pcc = ir ; r0_pcc = rpos(ir)
           exit
        end if

        if (ir == 1) then
           write(IFLOG,*) '### ERROR ### r0_pcc cannot be found'
           ier = 1 ; go to 99
        end if
     end do

  end select

  nk_pcc = 2

!  write(*,*) 'r0_pcc = ', r0_pcc
!  write(*,*) 'nr0_pcc = ', nr0_pcc
!  write(450,*) 'rho_core = ', rho_core

   !+++++++++++++++++++++++++++++++++++++++++++++++++++++++++
  allocate(rho_core0_pcc(0:nk_pcc)) ; rho_core0_pcc = 0.d0
   !+++++++++++++++++++++++++++++++++++++++++++++++++++++++++

  isdiff = nk_pcc
  n1 = nr0_pcc - 10
  n2 = nr0_pcc + 10
  r0_pcc = rpos(nr0_pcc)
  
  call diff_exp(ier,isdiff,n1,n2,rpos,rho_core,r0_pcc, &
       rho_core0_pcc(0),rho_core0_pcc(1),rho_core0_pcc(2))
  rho_core0_pcc(0) = rho_core(nr0_pcc)
  
  select case (is_pcc_method)
     
  case (POLYNOMIAL)
     call opt_poly_fn(ier,IFLOG,0,0, &
          nmesh,rpos,rho_core,nk_pcc,nr0_pcc,rho_core0_pcc, &
          ng_pcc,gmin_pcc,gmax_pcc,ncoeff_pcc,coeff_pcc)

     if (ier /= 0) then
        write(IFLOG,*) '### ERROR ### in opt_poly_fn'
        go to 99
     end if
     
     rho_pcore(:) = rho_core(:)
     call calc_poly_fn(1,nr0_pcc,rpos,0,ncoeff_pcc,coeff_pcc,rho_pcore)
     
  case (SBESSEL)
     call opt_sbessel_fn(ier,IFLOG, &
          nr0_pcc,r0_pcc,rho_core0_pcc(0),rho_core0_pcc(1), &
          a_pcc,b_pcc)
     if (ier /= 0) then
        write(IFLOG,*) '### ERROR ### in opt_sbessel_fn'
        go to 99
     end if
     rho_pcore(:) = rho_core(:)
     call calc_sbessel_fn(1,nr0_pcc,rpos,a_pcc,b_pcc,rho_pcore)
     
  end select

99 continue

end subroutine calc_rho_pcore_sol

!=====================================================================
   subroutine check_rho_pcore_sol(ier)
!=====================================================================
!
!  M. Okamoto
!
!---------------------------------------------------------------------
   use parameters
   implicit none
   integer,intent(out) :: ier
   integer :: ir1, ir2, ll, n1, n2, isdiff
   real(8) :: f0_anal(0:2), f0_num(0:2), f_tmp(nmesh)
   ier = 0
   f0_anal(:) = 0.d0
   ir1 = nr0_pcc
   ir2 = nr0_pcc
   ll  = 0
   call calc_poly_fn( &
      ir1,ir2,rpos,ll,ncoeff_pcc,coeff_pcc,f_tmp)
   f0_anal(0) = f_tmp(nr0_pcc)
   call calc_dpoly_fn( &
      ir1,ir2,rpos,ll,ncoeff_pcc,coeff_pcc,f_tmp)
   f0_anal(1) = f_tmp(nr0_pcc)
   call calc_ddpoly_fn( &
      ir1,ir2,rpos,ll,ncoeff_pcc,coeff_pcc,f_tmp)
   f0_anal(2) = f_tmp(nr0_pcc)
   f0_num(:)  = 0.d0
   isdiff = nk_pcc
   n1 = nr0_pcc - 10
   n2 = nr0_pcc + 10
   r0_pcc = rpos(nr0_pcc)
   call diff_exp(ier,isdiff,n1,n2,rpos,rho_pcore,r0_pcc, &
           f0_num(0),f0_num(1),f0_num(2))
   f0_num(0) = rho_pcore(nr0_pcc)
   call write_checked_pcc_sol(IFLOG, &
           nr0_pcc,r0_pcc,ncoeff_pcc,coeff_pcc, &
           nk_pcc,rho_core0_pcc,f0_anal,f0_num)
   call write_checked_pcc_sol(IFSUM, &
           nr0_pcc,r0_pcc,ncoeff_pcc,coeff_pcc, &
           nk_pcc,rho_core0_pcc,f0_anal,f0_num)
99 continue
   end subroutine check_rho_pcore_sol

!=====================================================================
   subroutine write_checked_pcc_sol(ifile, &
      nr0,r0,ncoeff,coeff,nk,f0_exact,f0_anal,f0_num)
!=====================================================================
!
!  M. Okamoto
!
!---------------------------------------------------------------------
   implicit none
   integer,intent(in) :: ifile, nr0, ncoeff, nk
   real(8),intent(in) :: f0_exact(0:*), f0_anal(0:*), f0_num(0:*), &
                         coeff(0:*), r0
   integer :: icoeff, ik
   write(ifile,*)
   write(ifile,*)  'PCC (polynomial) [Solved]'
   write(ifile,10) 'r0, nr0  :', r0, nr0
   write(ifile,11) 'ncoeff,nk:', ncoeff, nk
   do icoeff=0,ncoeff
   write(ifile,12) 'coeff(',2*icoeff,'):', coeff(icoeff)
   end do
   write(ifile,13) 'rho_pc(rc)','rho_pc''(rc)','rho_pc"(rc)'
   write(ifile,14) 'Exact    :',(f0_exact(ik),ik=0,nk)
   write(ifile,14) 'Analytic :',(f0_anal (ik),ik=0,nk)
   write(ifile,14) 'Numerical:',(f0_num  (ik),ik=0,nk)
10 format(1x,a10,f20.10,i20)
11 format(1x,a10,2(i20))
12 format(1x,(a6,i2,a2),f20.10)
13 format(1x,7x,1x,2x,(8x,a10,2x),(8x,a11,1x),(8x,a11,1x))
14 format(1x,a10,5(f20.10))
   end subroutine write_checked_pcc_sol

!=====================================================================
subroutine calc_pcc_fourier_sol(ier)
!=====================================================================
!
!  M. Okamoto
!
!---------------------------------------------------------------------
  use parameters
  implicit none

  integer,intent(out) :: ier
  integer :: ir, ig
  real(8) :: r, g

  ier = 0

  !+++++++++++++++++++++++++++++++++++++++++++++++++++++++
  allocate(gg_rho_core(ng_mesh),gg_rho_pcore(ng_mesh), &
       gg_rho_val(ng_mesh))
  gg_rho_core = 0.d0 ; gg_rho_pcore = 0.d0
  gg_rho_val  = 0.d0
  !+++++++++++++++++++++++++++++++++++++++++++++++++++++++
  gg_rho_core(:)  = 0.d0
  gg_rho_pcore(:) = 0.d0
  gg_rho_val(:)   = 0.d0
  g = gpos(1)

  do ir = 1,nmesh
     r = rpos(ir)
     gg_rho_core(1)  = gg_rho_core(1)  &
          + 4.d0*PI*r*r*wr(ir) * rho_core(ir) * g*g
     gg_rho_pcore(1) = gg_rho_pcore(1) &
          + 4.d0*PI*r*r*wr(ir) * rho_pcore(ir) * g*g
     
! ================================================== modified by K. T. ======= 4.0
!      gg_rho_val(1)   = gg_rho_val(1) &
!                      + 4.d0*PI*r*r*wr(ir) * rho_sol(ir) * g*g
!
     if ( nspin == 1 ) then
        gg_rho_val(1)   = gg_rho_val(1) &
             + 4.d0*PI*r*r*wr(ir) * rho_sol(ir,1) *g*g
     else if ( nspin == 2 ) then
        gg_rho_val(1)   = gg_rho_val(1) &
             + 4.d0*PI*r*r*wr(ir) * ( rho_sol(ir,1) +rho_sol(ir,2) ) *g*g
     endif
! ============================================================================ 4.0
  end do

  do ig = 2,ng_mesh
     g = gpos(ig)
     do ir = 1,nmesh
        r = rpos(ir)
        gg_rho_core(ig) = gg_rho_core(ig)  &
             + 4.d0*PI*r*wr(ir) * rho_core(ir) * sin(g*r)*g
        gg_rho_pcore(ig) = gg_rho_pcore(ig) &
             + 4.d0*PI*r*wr(ir) * rho_pcore(ir) * sin(g*r)*g
        
! ================================== modified by K. T. =============== 4.0
!         gg_rho_val(ig) = gg_rho_val(ig) &
!            + 4.d0*PI*r*wr(ir) * rho_sol(ir) * sin(g*r)*g
!
        if ( nspin == 1 ) then
           gg_rho_val(ig) = gg_rho_val(ig) &
                + 4.d0*PI*r*wr(ir) * rho_sol(ir,1) * sin(g*r)*g
        else if ( nspin ==2 ) then
           gg_rho_val(ig) = gg_rho_val(ig) &
                + 4.d0*PI*r*wr(ir) * ( rho_sol(ir,1)+rho_sol(ir,2) ) *sin(g*r)*g
        endif
! ============================================================================= 4.0
     end do
  end do

99 continue

end subroutine calc_pcc_fourier_sol

!=====================================================================
subroutine write_pcc_sol(ier)
!=====================================================================
!
!  M. Okamoto
!     
!---------------------------------------------------------------------
  use parameters
  implicit none

  integer,intent(out) :: ier
  integer :: ir, ig

  ier = 0
  open(IFPCC,file=trim(pccfile),status='unknown')
  write(IFPCC,*) 'PCC electron density and its fourier transform'
  call write_file_header(IFPCC)
  write(IFPCC,*)
  write(IFPCC,31) rpos(nr0_pcc), 'rcut  '
  write(IFPCC,31) gmin_pcc,      'gcut  '
  write(IFPCC,*)
  write(IFPCC,*) 'rpos, rho_core, rho_pcc, rho_val'

  do ir = 1,nmesh
! ============================================ modified y K. T, ================= 4.0
!      write(IFPCC,10) rpos(ir),rho_core(ir),rho_pcore(ir),rho_sol(ir)
!
     if ( nspin == 1 ) then
        write(IFPCC,10) rpos(ir),rho_core(ir),rho_pcore(ir),rho_sol(ir,1)
     else if ( nspin ==2 ) then
        write(IFPCC,10) rpos(ir),rho_core(ir),rho_pcore(ir),rho_sol(ir,1)+rho_sol(ir,2)
     endif
! =============================================================================== 4.0
  end do

  write(IFPCC,*)
  write(IFPCC,*) 'gpos, gg_rho_core, gg_rho_pcc, gg_rho_val'

  do ig = 1,ng_mesh
     write(IFPCC,10) gpos(ig),gg_rho_core(ig),gg_rho_pcore(ig), &
          gg_rho_val(ig)
  end do

10 format(10(1pe20.10))
31 format(1x,f20.10, 5x,':',1x,a6)

  close(IFPCC)

end subroutine write_pcc_sol
