! ************************************************************* 
!
!   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) : set_hubbard_b, calc_hubbard_i, calc_hubbard_u
!                : write_hubbard_u
!  Function(s)   : fn_hubbard_g1, fn_hubbard_g2
!  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 set_hubbard_b(ier)
!=====================================================================
!
!  M. Okamoto
!
!---------------------------------------------------------------------
   use parameters
   implicit none
   integer,intent(out) :: ier
   integer :: ll, mm
   ier = 0
   hubbard_b(:,:,:) = 0.d0
   ll = 0 ; mm = 0
   hubbard_b(ll,mm,0) =  1.d0
   ll = 1 ; mm = -1
   hubbard_b(ll,mm,0) =  1.d0/6.d0
   hubbard_b(ll,mm,2) = -1.d0/6.d0
   ll = 1 ; mm =  0
   hubbard_b(ll,mm,0) =  1.d0/3.d0
   hubbard_b(ll,mm,2) =  2.d0/3.d0
   ll = 1 ; mm = +1
   hubbard_b(ll,mm,0) =  2.d0/3.d0
   hubbard_b(ll,mm,2) = -2.d0/3.d0
   ll = 2 ; mm = -2
   hubbard_b(ll,mm,0) =   1.d0/120.d0
   hubbard_b(ll,mm,2) =  -1.d0/ 84.d0
   hubbard_b(ll,mm,4) =   1.d0/280.d0
   ll = 2 ; mm = -1
   hubbard_b(ll,mm,0) =   1.d0/ 30.d0
   hubbard_b(ll,mm,2) =   1.d0/ 42.d0
   hubbard_b(ll,mm,4) =  -2.d0/ 35.d0
   ll = 2 ; mm =  0
   hubbard_b(ll,mm,0) =   1.d0/  5.d0
   hubbard_b(ll,mm,2) =   2.d0/  7.d0
   hubbard_b(ll,mm,4) =  18.d0/ 35.d0
   ll = 2 ; mm = +1
   hubbard_b(ll,mm,0) =   6.d0/  5.d0
   hubbard_b(ll,mm,2) =   6.d0/  7.d0
   hubbard_b(ll,mm,4) = -72.d0/ 35.d0
   ll = 2 ; mm = +2
   hubbard_b(ll,mm,0) =  24.d0/  5.d0
   hubbard_b(ll,mm,2) = -48.d0/  7.d0
   hubbard_b(ll,mm,4) =  72.d0/ 35.d0
   ll = 3 ; mm = -3
   hubbard_b(ll,mm,0) =     1.d0/ 5040.d0
   hubbard_b(ll,mm,2) =    -1.d0/ 3024.d0
   hubbard_b(ll,mm,4) =     1.d0/ 6160.d0
   hubbard_b(ll,mm,6) =    -1.d0/33264.d0
   ll = 3 ; mm = -2
   hubbard_b(ll,mm,0) =     1.d0/  840.d0
   hubbard_b(ll,mm,2) =     0.d0
   hubbard_b(ll,mm,4) =    -1.d0/  440.d0
   hubbard_b(ll,mm,6) =     1.d0/  924.d0
   ll = 3 ; mm = -1
   hubbard_b(ll,mm,0) =     1.d0/   84.d0
   hubbard_b(ll,mm,2) =     1.d0/   84.d0
   hubbard_b(ll,mm,4) =     1.d0/  308.d0
   hubbard_b(ll,mm,6) =   -25.d0/  924.d0
   ll = 3 ; mm =  0
   hubbard_b(ll,mm,0) =     1.d0/    7.d0
   hubbard_b(ll,mm,2) =     4.d0/   21.d0
   hubbard_b(ll,mm,4) =    18.d0/   77.d0
   hubbard_b(ll,mm,6) =   100.d0/  231.d0
   ll = 3 ; mm = +1
   hubbard_b(ll,mm,0) =    12.d0/    7.d0
   hubbard_b(ll,mm,2) =    12.d0/    7.d0
   hubbard_b(ll,mm,4) =    36.d0/   77.d0
   hubbard_b(ll,mm,6) =  -300.d0/   77.d0
   ll = 3 ; mm = +2
   hubbard_b(ll,mm,0) =   120.d0/    7.d0
   hubbard_b(ll,mm,2) =     0.d0
   hubbard_b(ll,mm,4) =  -360.d0/   11.d0
   hubbard_b(ll,mm,6) =  1200.d0/   77.d0
   ll = 3 ; mm = +3
   hubbard_b(ll,mm,0) =   720.d0/    7.d0
   hubbard_b(ll,mm,2) = -1200.d0/    7.d0
   hubbard_b(ll,mm,4) =  6480.d0/   77.d0
   hubbard_b(ll,mm,6) = -1200.d0/   77.d0
   end subroutine set_hubbard_b

!=====================================================================
   subroutine calc_hubbard_i(ier)
!=====================================================================
!
!  M. Okamoto
!
!---------------------------------------------------------------------
   use parameters
   implicit none
   integer,intent(out) :: ier
   integer :: ir, ishell, jshell, ll, llp
   real(8) :: sum1, sum2, fn_hubbard_g1, fn_hubbard_g2
   ier = 0
   hubbard_i(:,:,:) = 0.d0
LI:do ishell = 1,nshell
LJ:do jshell = ishell,nshell
      if ((is_solve(ishell) == 0).or.(is_solve(jshell) == 0)) then
         cycle LJ
      end if
      ll = min(l_qnum(ishell),l_qnum(jshell))
      do llp = 0,2*ll
         sum1 = 0.d0
         do ir = 1,nmesh
            sum1 = sum1 + chi_g(ir,ishell)**2 / rpos(ir)**(llp+1) &
                        * fn_hubbard_g1(ier,ir,jshell,llp) * wr(ir)
         end do
         sum2 = 0.d0
         do ir = 1,nmesh
            sum2 = sum2 + chi_g(ir,ishell)**2 * rpos(ir)**(llp) &
                        * fn_hubbard_g2(ier,ir,jshell,llp) * wr(ir)
         end do
         hubbard_i(ishell,jshell,llp) = (sum1 + sum2) / 2.d0
         hubbard_i(jshell,ishell,llp) = hubbard_i(ishell,jshell,llp)
      end do
   end do LJ
   end do LI
   end subroutine calc_hubbard_i

!=====================================================================
   function fn_hubbard_g1(ier,ir,ishell,llp)
!=====================================================================
!
!  M. Okamoto
!
!---------------------------------------------------------------------
   use parameters
   implicit none
   integer,intent(out) :: ier
   integer,intent(in)  :: ir, ishell, llp
   integer :: nn, ll, jr, ii, i0, is, j
   real(8) :: fn_hubbard_g1, sum
   ier = 0
   nn = n_qnum(ishell)
   ll = l_qnum(ishell)
   sum = 0.d0
   if (ir == 1) then
      sum = 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 j = 1,4
            sum = sum + chi_g(i0+j*is,ishell)**2 &
                      * rpos(i0+j*is)**(llp) * wt(i0+j*is)
         end do
      end do
   else
      call set_weight_exp(ier,1,ir,rpos,wt)
      do jr = 1,ir
         sum = sum + chi_g(jr,ishell)**2 * rpos(jr)**(llp) * wt(jr)
      end do
   end if
   fn_hubbard_g1 = sum
   end function fn_hubbard_g1

!=====================================================================
   function fn_hubbard_g2(ier,ir,ishell,llp)
!=====================================================================
!
!  M. Okamoto
!
!---------------------------------------------------------------------
   use parameters
   implicit none
   integer,intent(out) :: ier
   integer,intent(in)  :: ir, ishell, llp
   integer :: nn, ll, jr, ii, i0, is, j
   real(8) :: fn_hubbard_g2, sum
   ier = 0
   nn = n_qnum(ishell)
   ll = l_qnum(ishell)
   sum = 0.d0
   if (ir == nmesh) then
      sum = 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 j = 1,4
            sum = sum + chi_g(i0+j*is,ishell)**2 &
                      / rpos(i0+j*is)**(llp+1) * wt(i0+j*is)
         end do
      end do
   else
      call set_weight_exp(ier,ir,nmesh,rpos,wt)
      do jr = ir,nmesh
         sum = sum + chi_g(jr,ishell)**2 / rpos(jr)**(llp+1) * wt(jr)
      end do
   end if
   fn_hubbard_g2 = sum
   end function fn_hubbard_g2

!=====================================================================
   subroutine calc_hubbard_u(ier)
!=====================================================================
!
!  M. Okamoto
!
!---------------------------------------------------------------------
   use parameters
   implicit none
   integer,intent(out) :: ier
   integer :: ishell, jshell, ill, jll, ll, llp, imm, jmm
   integer(8) :: fn_factorial
   real(8) :: sum
   ier = 0
   hubbard_u(:,:,:,:) = 0.d0
LI:do ishell = 1,nshell
LJ:do jshell = ishell,nshell
      if ((is_solve(ishell) == 0).or.(is_solve(jshell) == 0)) then
         cycle LJ
      end if
      ill = l_qnum(ishell) ; jll = l_qnum(jshell) ; ll = min(ill,jll)
      do imm = -ill,ill
      do jmm = -jll,jll
         sum = 0.d0
         do llp = 0,2*ll
            sum = sum &
             + dble((2*ill+1)*(2*jll+1)) / dble(2*llp+1)**2 &
               * dble(fn_factorial(ill-imm)) &
               / dble(fn_factorial(ill+imm)) &
               * dble(fn_factorial(jll-jmm)) &
               / dble(fn_factorial(jll+jmm)) &
               * hubbard_b(ill,imm,llp) * hubbard_b(jll,jmm,llp) &
               * hubbard_i(ishell,jshell,llp)
          end do  
          hubbard_u(ishell,imm,jshell,jmm) = sum
          hubbard_u(jshell,jmm,ishell,imm) = sum    
       end do      
       end do
   end do LJ
   end do LI   
   end subroutine calc_hubbard_u

!=====================================================================
   subroutine write_hubbard_u(ifile)
!=====================================================================  
!
!  M. Okamoto
!
!---------------------------------------------------------------------
   use parameters
   implicit none
   integer,intent(in) :: ifile
   integer        :: i, nn, ll, mm, ishell, lshell, mm1, mm2
   character(100) :: line
   do i = 1,100
      line(i:i)='-'
   end do
   write(ifile,*)
   write(ifile,*) &
      'hubbard  Hubbard U (On-Site Coulomb Energy) [Diagonal]'
   write(ifile,10) line(1:100)
   write(ifile,11) '   symm','m','s', &
                   'Energy (Ha)','Energy (eV)'
   write(ifile,10) line(1:100)
LSH1:do ishell = 1,nshell
      lshell = list_shell(ishell)
      if (is_solve(lshell) == 0) then
         cycle LSH1
      end if
      nn = n_qnum(lshell)
      ll = l_qnum(lshell)
      do mm = -ll,ll
         write(ifile,12) state(lshell)(1:2), &
            mm,spin_label(lshell)(1:1), &
            hubbard_u(lshell,mm,lshell,mm), &
            hubbard_u(lshell,mm,lshell,mm)*HARTREE
      end do
   end do LSH1
   write(ifile,10) line(1:100)
10 format(1x,'hubbard',a59)
11 format(1x,'hubbard',a7,2(4x,a1),2(9x,a11))
12 format(1x,'hubbard',(4x,a2,1x),(i5),(4x,a1),2(f20.10))
   write(ifile,*)
   write(ifile,*) &
      'hubbard  Hubbard U (On-Site Coulomb Energy) [Off-Diagonal]'
   write(ifile,20) line(1:100)
   write(ifile,21) '   symm','m1','s1','m2','s2', &
                   'Energy (Ha)','Energy (eV)'
   write(ifile,20) line(1:100)
LSH2:do ishell = 1,nshell
      lshell = list_shell(ishell)
      if (is_solve(lshell) == 0) then
         cycle LSH2
      end if
      nn = n_qnum(lshell)
      ll = l_qnum(lshell)
      if (ll == 0) then
         cycle LSH2
      end if
      do mm1 = -ll,ll-1
      do mm2 = mm1+1,ll
         write(ifile,22) state(lshell)(1:2), &
            mm1,spin_label(lshell)(1:1), &
            mm2,spin_label(lshell)(1:1), &
            hubbard_u(lshell,mm1,lshell,mm2), &
            hubbard_u(lshell,mm1,lshell,mm2)*HARTREE
      end do
      end do
   end do LSH2
   write(ifile,20) line(1:100)
20 format(1x,'hubbard',a69)
21 format(1x,'hubbard',a7,4(3x,a2),2(9x,a11))
22 format(1x,'hubbard',(4x,a2,1x),2(i5,(4x,a1)),2(f20.10))
   end subroutine write_hubbard_u
