! @@@@@@@@@@@@@@@@@@@@@@@@@@@@@@@@@@@@@@@@@@@@@@@@@@@@@@@@@@@@@@@@@@@@ !
! @@                                                                @@ !
! @@       PROGRAM  ASCOT 2014.440 (ver.4.40)                       @@ !
! @@     "Abinitio Simulation Code for Quantum Transport"           @@ !
! @@                                                                @@ !
! @@                                                                @@ !
! @@  AUTHOR(S): Hisashi KONDO (Univ. Tokyo)                        @@ !
! @@                                                09/May/2014     @@ !
! @@                                                                @@ !
! @@  Contact address: Phase System Consortium                      @@ !
! @@                                                                @@ !
! @@@@@@@@@@@@@@@@@@@@@@@@@@@@@@@@@@@@@@@@@@@@@@@@@@@@@@@@@@@@@@@@@@@@ !

subroutine cal_vhartree

  use scf_negf
  use fft
  use dft
  use hamiltonian_sgf
  use hamiltonian_c
  use gf_se_c
  use constant
  use condition_ini
  use mod_mpi

  implicit none
  real(8) :: tmp0

  integer :: i1,i2,i3,i4,ii,gnj,ier

  complex(8), allocatable :: temp(:)

  pai=datan(1.d0)*4.d0

  !                       ------------------------------------                       !

  if( ft_switch == 'f_2_ft' .or. ft_switch == 'fft' ) then
     do i3=l_cell_l_bound,r_cell_l_bound
        do i2=0,n_b-1
           do i1=0,n_a-1
              if( ispin_pol_scf < 4 ) then
                 if( ispin_pol_scf == 1 ) then
                    tmp0=2.d0*rho(i1*n_b*n_c+i2*n_c+i3,1)                            &
                         -rhoval(i1*n_b*n_c+i2*n_c+i3)
                 else
                    tmp0=rho(i1*n_b*n_c+i2*n_c+i3,1)                                 &
                         +rho(i1*n_b*n_c+i2*n_c+i3,2)                                 &
                         -rhoval(i1*n_b*n_c+i2*n_c+i3)
                 end if
              else
                 tmp0=dreal(rhols(i1*n_b*n_c+i2*n_c+i3,1)                           &
                      +rhols(i1*n_b*n_c+i2*n_c+i3,4))                          &
                      -rhoval(i1*n_b*n_c+i2*n_c+i3)
              end if
              fft1(i1+1)=dcmplx(tmp0,0.d0)
           end do
           if( ft_switch == 'f_2_ft' ) then
              call made_fourier(fft1,wxn,n_a,ix_fft)
           else
              call made_fourier_arb(fft1,wxn,n_a)
           end if
           do i1=0,n_a-1
              rho_f(i1*n_b*n_c+i2*n_c+i3)=fft1(i1+1)
           end do
        end do
        do i1=0,n_a-1
           do i2=0,n_b-1
              fft2(i2+1)=rho_f(i1*n_b*n_c+i2*n_c+i3)
           end do
           if( ft_switch == 'f_2_ft' ) then
              call made_fourier(fft2,wyn,n_b,iy_fft)
           else
              call made_fourier_arb(fft2,wyn,n_b)
           end if
           do i2=0,n_b-1
              rho_f(i1*n_b*n_c+i2*n_c+i3)=fft2(i2+1)
           end do
        end do
     end do
  else
     do i3=l_cell_l_bound,r_cell_l_bound
        do i2=0,n_b-1
           do i1=0,n_a-1
              r_tem(1,i1*n_b+i2+1)=dfloat(i1)
              r_tem(2,i1*n_b+i2+1)=dfloat(i2)
              p_tem(1,i1*n_b+i2+1)=dfloat(i1)*2.d0*pai/dfloat(n_a)
              p_tem(2,i1*n_b+i2+1)=dfloat(i2)*2.d0*pai/dfloat(n_b)
              if( ispin_pol_scf < 4 ) then
                 if( ispin_pol_scf == 1 ) then
                    tmp0=2.d0*rho(i1*n_b*n_c+i2*n_c+i3,1)                            &
                         -rhoval(i1*n_b*n_c+i2*n_c+i3)
                 else
                    tmp0=rho(i1*n_b*n_c+i2*n_c+i3,1)                                 &
                         +rho(i1*n_b*n_c+i2*n_c+i3,2)                                 &
                         -rhoval(i1*n_b*n_c+i2*n_c+i3)
                 end if
              else
                 tmp0=dreal(rhols(i1*n_b*n_c+i2*n_c+i3,1)                           &
                      +rhols(i1*n_b*n_c+i2*n_c+i3,4))                          &
                      -rhoval(i1*n_b*n_c+i2*n_c+i3)
              end if
              fft_in(i1*n_b+i2+1)=dcmplx(tmp0,0.d0)
           end do
        end do
        call made_dft(fft_in,fft_out,r_tem,p_tem,n_a*n_b,2,1)
        do i2=0,n_b-1
           do i1=0,n_a-1
              rho_f(i1*n_b*n_c+i2*n_c+i3)=fft_out(i1*n_b+i2+1)
           end do
        end do
     end do
  end if

  !                       ------------------------------------                       !

  allocate(temp(n_c+1),stat=ier)
  if( ier /= 0 ) then
     write(6,*) 'error allocate: dens_atom2cell_lr'
     stop
  end if
  do i2=0,n_b-1
     do i1=0,n_a-1
        if( i1 == 0 .and. i2 == 0) then
           call cal_vhart_gzero_2
        else
           call cal_vhart_gnonzero(i1,i2,n_c,temp)
        end if
     end do
  end do
  deallocate(temp,stat=ier)
  if( ier /= 0 ) then
     write(6,*) 'error deallocate: dens_atom2cell_lr'
     stop
  end if

  !                       ------------------------------------                       !

  if( ft_switch == 'f_2_ft' .or. ft_switch == 'fft' ) then
     do i3=l_cell_l_bound+1,r_cell_l_bound-1
        do i2=0,n_b-1
           do i1=0,n_a-1
              fft1(i1+1)=rho_f(i1*n_b*n_c+i2*n_c+i3)
           end do
           if( ft_switch == 'f_2_ft' ) then
              call made_fourier(fft1,wxn_i,n_a,ix_fft)
           else
              call made_fourier_arb(fft1,wxn_i,n_a)
           end if
           do i1=0,n_a-1
              rho_f(i1*n_b*n_c+i2*n_c+i3)=fft1(i1+1)
           end do
        end do
        do i1=0,n_a-1
           do i2=0,n_b-1
              fft2(i2+1)=rho_f(i1*n_b*n_c+i2*n_c+i3)
           end do
           if( ft_switch == 'f_2_ft' ) then
              call made_fourier(fft2,wyn_i,n_b,iy_fft)
           else
              call made_fourier_arb(fft2,wyn_i,n_b)
           end if
           do i2=0,n_b-1
              v_hartree(i1*n_b*n_c+i2*n_c+i3)                                      &
                   =dreal(fft2(i2+1))/dfloat(n_a*n_b)
           end do
        end do
     end do
  else
     do i3=l_cell_l_bound+1,r_cell_l_bound-1
        do i2=0,n_b-1
           do i1=0,n_a-1
              r_tem(1,i1*n_b+i2+1)=dfloat(i1)
              r_tem(2,i1*n_b+i2+1)=dfloat(i2)
              p_tem(1,i1*n_b+i2+1)=dfloat(i1)*2.d0*pai/dfloat(n_a)
              p_tem(2,i1*n_b+i2+1)=dfloat(i2)*2.d0*pai/dfloat(n_b)
              fft_in(i1*n_b+i2+1)=rho_f(i1*n_b*n_c+i2*n_c+i3)
           end do
        end do
        call made_dft(fft_in,fft_out,p_tem,r_tem,n_a*n_b,2,-1)
        do i2=0,n_b-1
           do i1=0,n_a-1
              v_hartree(i1*n_b*n_c+i2*n_c+i3)                                      &
                   =dreal(fft_out(i1*n_b+i2+1))/dfloat(n_a*n_b)
           end do
        end do
     end do
  end if

  !                       -----------------------------------                        !

  if( myrank ==0 ) then

     open(unit=90,file='negf_vh.cube')
     write(90,*) 'SYS1'
     write(90,*) 'SYS1'
     write(90,993) num_atom_scf,cell_lo(1),cell_lo(2),cell_lo(3)
     write(90,993) n_a,cell_dlabc(1,1),cell_dlabc(1,2),cell_dlabc(1,3)
     write(90,993) n_b,cell_dlabc(2,1),cell_dlabc(2,2),cell_dlabc(2,3)
     write(90,993) n_c,cell_dlabc(3,1),cell_dlabc(3,2),cell_dlabc(3,3)
     do i1=1,num_atom_scf
        write(90,992) atom_name_num(i1)                                        &
             ,vatom_q(i1)-sum_charge(i1)                                 &
             ,atom_ro(i1,1),atom_ro(i1,2),atom_ro(i1,3)
     end do
     do i1=0,n_a-1
        do i2=0,n_b-1
           ii=n_c+6
           do i3=0,n_c-1,6
              gnj=i1*n_b*n_c+i2*n_c+i3
              ii=ii-6
              if( ii >= 6 ) then
                 write(90,999) (v_hartree(gnj+i4),i4=1,6)
              else
                 if( ii == 5 ) write(90,998) (v_hartree(gnj+i4),i4=1,ii)
                 if( ii == 4 ) write(90,997) (v_hartree(gnj+i4),i4=1,ii)
                 if( ii == 3 ) write(90,996) (v_hartree(gnj+i4),i4=1,ii)
                 if( ii == 2 ) write(90,995) (v_hartree(gnj+i4),i4=1,ii)
                 if( ii == 1 ) write(90,994) (v_hartree(gnj+i4),i4=1,ii)
              end if
           end do
        end do
     end do
     close(90)
  end if

999 format(f13.6,f13.6,f13.6,f13.6,f13.6,f13.6)
998 format(f13.6,f13.6,f13.6,f13.6,f13.6)
997 format(f13.6,f13.6,f13.6,f13.6)
996 format(f13.6,f13.6,f13.6)
995 format(f13.6,f13.6)
994 format(f13.6)
993 format(i4,f13.6,f13.6,f13.6)
992 format(i4,f13.6,f13.6,f13.6,f13.6)

  return
end subroutine cal_vhartree

subroutine cal_vhart_gnonzero(i1,i2,n_c_in,temp)

  use scf_negf
  use fft
  use dft
  use hamiltonian_sgf
  use hamiltonian_c
  use gf_se_c
  use constant
  use condition_ini

  implicit none
  integer, intent(in) :: i1,i2,n_c_in
  complex(8), intent(inout) :: temp(n_c_in+1)

  integer :: i3,i4

  complex(8) :: c1,c2,result
  real(8) :: result1,result2

  pai=datan(1.d0)*4.d0

  !                       ------------------------------------                       !

  do i3=l_cell_l_bound,r_cell_l_bound
     temp(i3)=dcmplx(0.d0,0.d0)
  end do
  do i3=l_cell_l_bound,r_cell_l_bound
     do i4=l_cell_l_bound+1,r_cell_l_bound
        c1=dcmplx(1.d0,0.d0)
        c2=dcmplx(1.d0,0.d0)
        if( i4 == l_cell_l_bound+1 ) then
           if( del_bound_l < del_cell_l*.5d0 ) then
              c1=dcmplx((del_cell_l-del_bound_l)/del_cell_l,0.d0)
           else
              c1=dcmplx(0.d0,0.d0)
              c2=dcmplx((del_cell_l-del_bound_l)/del_cell_l,0.d0)
           end if
        end if
        if( i4 == r_cell_l_bound ) then
           if( del_bound_r < del_cell_l*.5d0 ) then
              c2=dcmplx((del_cell_l-del_bound_r)/del_cell_l,0.d0)
           else
              c1=dcmplx((del_cell_l-del_bound_r)/del_cell_l,0.d0)
              c2=dcmplx(0.d0,0.d0)
           end if
        end if
        call cal_green(i1,i2,i3,i4-1,result1)
        call cal_green(i1,i2,i3,i4,result2)
        temp(i3)=temp(i3)+c1*dcmplx(result1,0.d0)                                &
             *rho_f(i1*n_b*n_c+i2*n_c+i4-1)                     &
             +c2*dcmplx(result2,0.d0)                                &
             *rho_f(i1*n_b*n_c+i2*n_c+i4)
     end do
  end do
  do i3=l_cell_l_bound+1,r_cell_l_bound-1
     call cal_vh_temp(i1,i2,i3,result)
     rho_f(i1*n_b*n_c+i2*n_c+i3)                                                &
          =result+dcmplx(2.d0*pai*del_cell_l,0.d0)*temp(i3)
  end do

  return
end subroutine cal_vhart_gnonzero

subroutine cal_vhart_gzero_2

  use scf_negf
  use fft
  use dft
  use hamiltonian_sgf
  use hamiltonian_c
  use gf_se_c
  use constant
  use condition_ini

  implicit none
  integer :: mat_gzero,i1,i2,i3,i4,ier
  real(8) :: g_temp,temp_r
  complex(8) :: c1,c2,result
  real(8) :: result1,result2
  complex(8), allocatable :: temp(:),a(:,:),b(:,:),c(:),d(:)

  pai=datan(1.d0)*4.d0
  mat_gzero=r_cell_l_bound-l_cell_l_bound+1

  allocate(temp(n_c),a(mat_gzero,mat_gzero),b(mat_gzero,mat_gzero)             &
       ,c(mat_gzero),d(mat_gzero),stat=ier)
  if( ier /= 0 ) then
     write(6,*) 'error allocate: cal_vhart_gzero_2'
     stop
  end if
  do i3=1,n_c
     temp(i3)=dcmplx(0.d0,0.d0)
  end do

  do i3=l_cell_l_bound,r_cell_l_bound
     do i4=l_cell_l_bound+1,r_cell_l_bound
        c1=dcmplx(1.d0,0.d0)
        c2=dcmplx(1.d0,0.d0)
        if( i4 == l_cell_l_bound+1 ) then
           if( del_bound_l < del_cell_l*.5d0 ) then
              c1=dcmplx((del_cell_l-del_bound_l)/del_cell_l,0.d0)
           else
              c1=dcmplx(0.d0,0.d0)
              c2=dcmplx((del_cell_l-del_bound_l)/del_cell_l,0.d0)
           end if
        end if
        if( i4 == r_cell_l_bound ) then
           if( del_bound_r < del_cell_l*.5d0 ) then
              c2=dcmplx((del_cell_l-del_bound_r)/del_cell_l,0.d0)
           else
              c1=dcmplx((del_cell_l-del_bound_r)/del_cell_l,0.d0)
              c2=dcmplx(0.d0,0.d0)
           end if
        end if
        call cal_green(0,0,i3,i4-1,result1)
        call cal_green(0,0,i3,i4,result2)
        temp(i3)=temp(i3)+c1*dcmplx(result1,0.d0)*rho_f(i4-1)                    &
             +c2*dcmplx(result2,0.d0)*rho_f(i4)
     end do
  end do
  do i3=l_cell_l_bound,r_cell_l_bound
     call cal_vh_temp(0,0,i3,result)
     del2_z(i3)=result+dcmplx(2.d0*pai*del_cell_l,0.d0)*temp(i3)
  end do

  g_temp=gzero_gamma*gzero_gamma
  i1=0
  do i3=l_cell_l_bound,r_cell_l_bound
     i1=i1+1
     i2=0
     do i4=l_cell_l_bound,r_cell_l_bound
        i2=i2+1
        temp_r=1.d0
        if( i4 == l_cell_l_bound ) then
           if( del_bound_l < del_cell_l*.5d0 ) then
              temp_r=.5d0*(del_cell_l-del_bound_l)/del_cell_l
           else
              temp_r=0.d0
           end if
        end if
        if( i4 == r_cell_l_bound ) then
           if( del_bound_r < del_cell_l*.5d0 ) then
              temp_r=.5d0*(del_cell_l-del_bound_r)/del_cell_l
           else
              temp_r=0.d0
           end if
        end if
        if( i4 == l_cell_l_bound+1 ) then
           if( del_bound_l > del_cell_l*.5d0 ) then
              temp_r=.5d0+.5d0*(del_cell_l-del_bound_l)/del_cell_l
           end if
        end if
        if( i4 == r_cell_l_bound-1 ) then
           if( del_bound_r > del_cell_l*.5d0 ) then
              temp_r=.5d0+.5d0*(del_cell_l-del_bound_r)/del_cell_l
           end if
        end if
        call cal_green(0,0,i3,i4,result1)
        a(i1,i2)=-dcmplx(g_temp*del_cell_l*temp_r*result1,0.d0)
     end do
     a(i1,i1)=a(i1,i1)+dcmplx(1.d0,0.d0)
  end do

  do i3=l_cell_l_bound+1,r_cell_l_bound-1
     c(i3-l_cell_l_bound+1)=del2_z(i3)
  end do
  call linear_equation(mat_gzero,a,c,d)
  do i3=l_cell_l_bound+1,r_cell_l_bound-1
     rho_f(i3)=d(i3-l_cell_l_bound+1)
  end do

  deallocate(temp,a,b,c,d,stat=ier)
  if( ier /= 0 ) then
     write(6,*) 'error deallocate: cal_vhart_gzero_2'
     stop
  end if

  return
end subroutine cal_vhart_gzero_2

subroutine cal_vh_temp(kx,ky,kz,result)

  use scf_negf
  use fft
  use dft
  use hamiltonian_sgf
  use hamiltonian_c
  use gf_se_c
  use constant
  use condition_ini

  implicit none
  integer, intent(in) :: kx,ky,kz
  complex(8), intent(out) :: result

  integer :: i1_do,i2_do,i3_do,i1
  real(8) :: g_temp,r1,r2,r3

  r1=cell_lr(1,l_cell_l_bound)+del_bound_l
  r2=cell_lr(1,r_cell_l_bound)-del_bound_r
  i2_do=ky
  i1_do=kx
  if( i1_do == 0 .and. i2_do == 0 ) then
     g_temp=gzero_gamma
  else
     i1=i1_do*n_b+i2_do+1
     g_temp=dsqrt(r_cell_dk(1,i1)*r_cell_dk(1,i1)                               &
          +r_cell_dk(2,i1)*r_cell_dk(2,i1))
  end if
  i3_do=kz
  r3=cell_lr(1,i3_do)
  result                                                                       &
       =(vh_r_f(i1_do*n_b+i2_do+1)                                               &
       *dcmplx(dexp(-g_temp*(r2-r3))-dexp(-g_temp*(r2-2.d0*r1+r3)),0.d0)  &
       +vh_l_f(i1_do*n_b+i2_do+1)                                                 &
       *dcmplx(dexp(-g_temp*(r3-r1))-dexp(-g_temp*(2.d0*r2-r1-r3)),0.d0)) &
       /dcmplx(1.d0-dexp(-2.d0*g_temp*(r2-r1)),0.d0)

  return
end subroutine cal_vh_temp

subroutine cal_green(kx,ky,kz1,kz2,result)

  use scf_negf
  use fft
  use dft
  use hamiltonian_sgf
  use hamiltonian_c
  use gf_se_c
  use constant
  use condition_ini

  implicit none
  integer, intent(in) :: kx,ky,kz1,kz2
  real(8), intent(out) :: result

  integer :: i1_do,i2_do,i3_do,i4_do,i1
  real(8) :: g_temp,r1,r2,r3,r4

  r1=cell_lr(1,l_cell_l_bound)+del_bound_l
  r2=cell_lr(1,r_cell_l_bound)-del_bound_r
  i2_do=ky
  i1_do=kx
  if( i1_do == 0 .and. i2_do == 0 ) then
     g_temp=gzero_gamma
  else
     i1=i1_do*n_b+i2_do+1
     g_temp=dsqrt(r_cell_dk(1,i1)*r_cell_dk(1,i1)                               &
          +r_cell_dk(2,i1)*r_cell_dk(2,i1))
  end if
  i3_do=kz1
  r3=cell_lr(1,i3_do)
  i4_do=kz2
  r4=cell_lr(1,i4_do)
  result=(dexp(-g_temp*dabs(r3-r4))+dexp(-g_temp*(2.d0*(r2-r1)-dabs(r3-r4)))   &
       -dexp(-g_temp*(2.d0*r2-r3-r4))-dexp(-g_temp*(r3+r4-2.d0*r1)))         &
       /(2.d0*g_temp*(1.d0-dexp(-2.d0*g_temp*(r2-r1))))

  return
end subroutine cal_green
