!
!  Software name : CIAO (Code for Investigating Atomic Orbitals)
!  Subroutine(s) : calc_dvxc_ddvxc, calc_de_srel, write_de_srel
!                : write_ee_srel
!  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_dvxc_ddvxc(ier)
!=====================================================================
!
!  M. Okamoto
!
!---------------------------------------------------------------------
   use parameters
   implicit none
   integer,intent(out) :: ier
   integer :: ispin, ll, ll_core
   ier = 0
   do ispin = 1,nspin
      call calc_ddiff_exp(ier,iord_diff,nmesh,rpos(1),vx(1,ispin), &
                          dvx(1,ispin),ddvx(1,ispin))
      call calc_ddiff_exp(ier,iord_diff,nmesh,rpos(1),vc(1,ispin), &
                          dvc(1,ispin),ddvc(1,ispin))
      do ll = 0,lmax
         if (is_core == PATOM) then
            ll_core = ll
         else
            ll_core = lmax_core
         end if
         call calc_ddiff_exp(ier,iord_diff,nmesh,rpos(1), &
                             veff(1,ispin,ll_core), &
                             dveff(1,ispin,ll_core), &
                             ddveff(1,ispin,ll_core))
      end do
   end do
99 continue
   end subroutine calc_dvxc_ddvxc

!=====================================================================
   subroutine calc_de_srel(ier)
!=====================================================================
!
!  M. Okamoto
!
!---------------------------------------------------------------------
   use parameters
   implicit none
   integer,intent(out) :: ier
   integer :: ir, ispin, ishell, jshell, n1, l1, ll_core, n2, l2, &
              is_order_perturbation, is_order_alpha, ir_min
   real(8) :: sum, aa, a4, de_core, de_h, de_xc, de_e2, de_a4, &
              de_o2, tmp, sum_m
   ier = 0
   is_order_perturbation = 1 ; is_order_alpha = 2
   ir_min = 10
   aa = ALPHA * ALPHA ; a4 = aa * aa
   de_srel(:) = 0.d0
   write(IFLOG,*)
   write(IFLOG,*) 'Energy shifts (in eV) by 1st and 2nd order perturbation'
   write(IFLOG,10) 'n','l','core','h','xc','e2','a4','o2','dE[SREL]'
   do ishell = 1,nshell
      ispin = (1-spin(ishell))/2 + 1
      n1 = n_qnum(ishell) ; l1 = l_qnum(ishell)
      if (is_core == PATOM) then
         ll_core = l1
      else
         ll_core = lmax_core
      end if
      if ((is_order_perturbation >= 1).and.(is_order_alpha >= 2)) then
         de_core = aa*dble(zatom)/8.d0 &
                   * (chi_g(ir_min,ishell)/rpos(ir_min))**2
         sum = 0.d0
         do ir = 1,nmesh
            sum = sum + wr(ir) * chi_g(ir,ishell)**2 * rho(ir,ispin)
         end do
         de_h = -aa*PI/2.d0*sum
         sum = 0.d0
         do ir = 1,nmesh
            sum = sum + wr(ir) * chi_g(ir,ishell)**2 &
               * (ddvx(ir,ispin) + 2.d0/rpos(ir)*dvx(ir,ispin) &
                + ddvc(ir,ispin) + 2.d0/rpos(ir)*dvc(ir,ispin))
         end do
         de_xc = aa*sum/8.d0
         sum = 0.d0
         do ir = 1,nmesh
            sum = sum + wr(ir) * chi_g(ir,ishell)**2 &
               * (engy(ishell) - veff(ir,ispin,ll_core))**2
         end do
         de_e2 = -aa*sum/2.d0
      else
         de_core = 0.d0 ; de_h = 0.d0 ; de_xc = 0.d0 ; de_e2 = 0.d0
      end if
      if ((is_order_perturbation >= 1).and.(is_order_alpha >= 4)) then
         de_a4 = 0.d0
         sum = 0.d0
         do ir = 1,nmesh
            sum = sum + wr(ir) * chi_g(ir,ishell)**2 &
               * dveff(ir,ispin,ll_core)**2
         end do
         tmp = a4*sum*3.d0/32.d0
         de_a4 = de_a4 + tmp
         tmp = -a4*dble(zatom)/16.d0 &
            * (chi_g(ir_min,ishell)/rpos(ir_min))**2 &
            * (engy(ishell) - veff(ir_min,ispin,ll_core))
         de_a4 = de_a4 + tmp
         sum = 0.d0
         do ir = 1,nmesh
            sum = sum + wr(ir) * chi_g(ir,ishell)**2 * rho(ir,ispin) &
               * (engy(ishell) - veff(ir,ispin,ll_core))
         end do
         tmp = a4*PI/4.d0*sum
         de_a4 = de_a4 + tmp
         sum = 0.d0
         do ir = 1,nmesh
            sum = sum + wr(ir) * chi_g(ir,ishell)**2 &
               * (ddvx(ir,ispin) + 2.d0/rpos(ir)*dvx(ir,ispin) &
                + ddvc(ir,ispin) + 2.d0/rpos(ir)*dvc(ir,ispin)) &
               * (engy(ishell) - veff(ir,ispin,ll_core))
         end do
         tmp = -a4*sum/16.d0
         de_a4 = de_a4 + tmp
      else
         de_a4 = 0.d0
      end if
      if ((is_order_perturbation >= 2).and.(is_order_alpha >= 4)) then
         de_o2 = 0.d0
         do jshell = 1,nshell
            n2 = n_qnum(jshell) ; l2 = l_qnum(jshell)
            if ((n1 /= n2).and.(l1 == l2)) then
               sum_m = 0.d0
               tmp = aa*dble(zatom)/8.d0 &
                  * (chi_g(ir_min,jshell)/rpos(ir_min)) &
                  * (chi_g(ir_min,ishell)/rpos(ir_min))
               sum_m = sum_m + tmp
               sum = 0.d0
               do ir = 1,nmesh
                  sum = sum + wr(ir) * rho(ir,ispin) &
                            * chi_g(ir,jshell) * chi_g(ir,ishell)
               end do
               tmp = -aa*PI/2.d0*sum
               sum_m = sum_m + tmp
               sum = 0.d0
               do ir = 1,nmesh
                  sum = sum + wr(ir) &
                     * chi_g(ir,jshell) * chi_g(ir,ishell) &
                     * (ddvx(ir,ispin) + 2.d0/rpos(ir)*dvx(ir,ispin) &
                      + ddvc(ir,ispin) + 2.d0/rpos(ir)*dvc(ir,ispin))
               end do
               tmp = aa*sum/8.d0
               sum_m = sum_m + tmp
               sum = 0.d0
               do ir = 1,nmesh
                  sum = sum + wr(ir) &
                     * chi_g(ir,jshell) * chi_g(ir,ishell) &
                     * (engy(ishell) - veff(ir,ispin,ll_core))**2
               end do
               tmp = -aa*sum/2.d0
               sum_m = sum_m + tmp
               de_o2 = de_o2 + sum_m**2/(engy(ishell) - engy(jshell))
            end if
         end do
      else
         de_o2 = 0.d0
      end if
      de_srel(ishell) = de_core + de_h + de_xc + de_e2 + de_a4 + de_o2
      write(IFLOG,11) &
         n1, l1, de_core*HARTREE, de_h*HARTREE, de_xc*HARTREE, &
         de_e2*HARTREE, de_a4*HARTREE, de_o2*HARTREE, &
         de_srel(ishell)*HARTREE
   end do
   ee_srel(:) = engy(:) + de_srel(:)
10 format(2(2x,a1),(10x,a4,1x),(10x,a1,4x),4(10x,a2,3x),(7x,a8))
11 format(2i3,7f15.5)
99 continue
   end subroutine calc_de_srel

!=====================================================================
   subroutine write_de_srel(ifile)
!=====================================================================  
!
!  M. Okamoto
!
!---------------------------------------------------------------------
   use parameters
   implicit none
   integer,intent(in) :: ifile
   integer        :: i, nn, ll, ishell, lshell
   character(100) :: line, buffer
   do i = 1,100
      line(i:i)='-'
   end do
   write(ifile,*)
   write(ifile,*) 'eng  SREL correction dE [All-electron]'
      read(atom_label(zatom),*) buffer
   write(ifile,*) 'eng  Element ---> ',buffer(1:3)
   select case (is_spin)
   case (RESTRICTED)
   write(ifile,10) line(1:100)
   write(ifile,11) 'symm', &
                   'dE (Ha)','dE (eV)','nocc','focc'
   write(ifile,10) line(1:100)
   do ishell = 1,nshell
      lshell = list_shell(ishell)
      if (is_solve(lshell) == 0) then
         cycle
      end if
      nn = n_qnum(lshell)
      ll = l_qnum(lshell)
      write(ifile,12) state(lshell)(1:2), &
         de_srel(lshell),de_srel(lshell)*HARTREE,nocc(lshell),focc(lshell)
   end do
   write(ifile,10) line(1:100)
   write(ifile,13) 'Total number of electrons',felec
   write(ifile,10) line(1:100)
10 format(1x,'eng',a65)
11 format(1x,'eng',(3x,a4),2(13x,a7),(2x,a4),(6x,a4))
12 format(1x,'eng',(4x,a2,1x),2(f20.10),i6,f10.5)
13 format(1x,'eng',2x,a25,26x,f10.5)
   end select
   end subroutine write_de_srel

!=====================================================================
   subroutine write_ee_srel(ifile)
!=====================================================================  
!
!  M. Okamoto
!
!---------------------------------------------------------------------
   use parameters
   implicit none
   integer,intent(in) :: ifile
   integer        :: i, nn, ll, ishell, lshell
   character(100) :: line, buffer
   do i = 1,100
      line(i:i)='-'
   end do
   write(ifile,*)
   write(ifile,*) 'eng  SREL corrected energy levels [All-electron]'
      read(atom_label(zatom),*) buffer
   write(ifile,*) 'eng  Element ---> ',buffer(1:3)
   select case (is_spin)
   case (RESTRICTED)
   write(ifile,10) line(1:100)
   write(ifile,11) 'symm', &
                   'Energy (Ha)','Energy (eV)','nocc','focc'
   write(ifile,10) line(1:100)
   do ishell = 1,nshell
      lshell = list_shell(ishell)
      if (is_solve(lshell) == 0) then
         cycle
      end if
      nn = n_qnum(lshell)
      ll = l_qnum(lshell)
      write(ifile,12) state(lshell)(1:2), &
         ee_srel(lshell),ee_srel(lshell)*HARTREE,nocc(lshell),focc(lshell)
   end do
   write(ifile,10) line(1:100)
   write(ifile,13) 'Total number of electrons',felec
   write(ifile,10) line(1:100)
10 format(1x,'eng',a65)
11 format(1x,'eng',(3x,a4),2(9x,a11),(2x,a4),(6x,a4))
12 format(1x,'eng',(4x,a2,1x),2(f20.10),i6,f10.5)
13 format(1x,'eng',2x,a25,26x,f10.5)
   end select
   end subroutine write_ee_srel
