! ************************************************************* 
!
!   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
!
!   latest version: 
!
!     4.0:  2013/01/17 
!           codes for spin-polarized pseudopotential generation are added
!
! ************************************************************* 
!
!  Software name : CIAO (Code for Investigating Atomic Orbitals)
!  Subroutine(s) : set_vion, calc_vh, calc_veff
!  Author(s)     : Masakuni Okamoto (August 25, 2003)
!
!  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
   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)
   end do
   end do
99 continue
   end subroutine calc_veff
