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

subroutine cal_vhart_easier
  use scf_negf
  use ac_mpi_module
  implicit none

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

  complex(8), allocatable :: work1(:), work3(:,:,:)
  complex(8), allocatable :: result(:)
  integer :: i

  real(8) :: kk, phi
  real(8) :: K(3)

  allocate( result(0:n_c-1),stat=ier )
  allocate( work1(0:n_c-1),stat=ier )
  allocate( work3(0:n_a-1,0:n_b-1,0:n_c-1),stat=ier )

  do i3=0,n_c-1
     do i2=0,n_b-1
        do i1=0,n_a-1
           i = i1*n_b*n_c+i2*n_c+i3+1
           if( ispin_pol_scf < 4 ) then
              if( ispin_pol_scf == 1 ) then
                 work3(i1,i2,i3) = 2.d0*rho(i,1) - rhoval(i)
              else
                 work3(i1,i2,i3) = rho(i,1) + rho(i,2) - rhoval(i)
              end if
           else
              work3(i1,i2,i3) = dreal(rhols(i,1)+rhols(i,4)) - rhoval(i)
           end if
        end do
     end do
  end do

  call ZFFT3D_backward(n_a,n_b,n_c,work3)

  do i3=0,n_c-1
     do i2=0,n_b-1
        do i1=0,n_a-1
           call Param__Cell__K(K,i1+1,i2+1,i3+1)
           kk = dot_product(K,K)
           call Hartree__PhiK(phi,kk)
           work3(i1,i2,i3) = work3(i1,i2,i3)*phi
        end do
     end do
  end do

  do i2=0,n_b-1
     do i1=0,n_a-1
        do i3=0,n_c-1
           work1(i3) = work3(i1,i2,i3)
        end do

        call make_boucon(i1,i2,work1)

        call ZFFT1D_forward(n_c,work1)
        work1(:) = work1(:)*(1.0d0/dble(n_c))

        if( i1 == 0 .and. i2 == 0 )then
           if( i_gzero_method == 0 ) then
              call cal_vhartea_gzero_1(result)
           else
              call cal_vhartea_gzero_2(result)
           end if

           do i3=l_cell_l_bound+1-1,r_cell_l_bound-1-1
              i = i1*n_b*n_c+i2*n_c+i3+1
              work1(i3) = work1(i3) + result(i3)
           end do
        else
           do i3=l_cell_l_bound+1-1,r_cell_l_bound-1-1
              call cal_vh_temp1(i1,i2,i3+1,result(i3))

              i = i1*n_b*n_c+i2*n_c+i3+1
              work1(i3) = work1(i3) + result(i3)
           end do
        end if

        do i3=0,n_c-1
           work3(i1,i2,i3) = work1(i3)
        end do
     end do
  end do

  do i3=l_cell_l_bound+1-1,r_cell_l_bound-1-1
     call ZFFT2D_forward(n_a,n_b,work3(:,:,i3))
     work3(:,:,i3) = work3(:,:,i3)*(1.0d0/dble(n_a*n_b))

     do i2=0,n_b-1
        do i1=0,n_a-1
           i = i1*n_b*n_c+i2*n_c+i3+1
           v_hartree(i) = dreal(work3(i1,i2,i3))
        end do
     end do
  end do

  deallocate( result )
  deallocate( work1, work3 )

  if( MPI%root ) 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_vhart_easier

subroutine make_boucon(kx,ky,boucon_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) :: kx,ky
  complex(8), intent(in) :: boucon_temp(n_c)

  integer :: i3,m3
  real(8) :: r1,r2,gx
  complex(8) :: temp_l,temp_r

  r1=cell_lr(1,l_cell_l_bound)+del_bound_l
  r2=cell_lr(1,r_cell_l_bound)-del_bound_r

  temp_l=dcmplx(0.d0,0.d0)
  temp_r=dcmplx(0.d0,0.d0)

  do i3=0,n_c-1
     if( i3 < n_c/2 ) then
        m3=i3
     else
        m3=i3-n_c
     end if
     gx=dfloat(m3)*cell_dkabc(3,1)
     temp_l=temp_l+boucon_temp(i3+1)*dcmplx(dcos(gx*r1),-dsin(gx*r1))
     temp_r=temp_r+boucon_temp(i3+1)*dcmplx(dcos(gx*r2),-dsin(gx*r2))
  end do

  boucon_l(kx*n_b+ky+1)=temp_l/dcmplx(dfloat(n_c),0.d0)
  boucon_r(kx*n_b+ky+1)=temp_r/dcmplx(dfloat(n_c),0.d0)

  return
end subroutine make_boucon

subroutine cal_vhartea_gzero_1(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
  complex(8), intent(out) :: result(0:n_c-1)

  integer :: i3
  real(8) :: r2,r1
  complex(8) :: va,vb

  r1=cell_lr(1,l_cell_l_bound)+del_bound_l
  r2=cell_lr(1,r_cell_l_bound)-del_bound_r
  vb=vh_l_f(1)-boucon_l(1)
  va=(vh_r_f(1)-boucon_r(1)-vb)/dcmplx(r2-r1,0.d0)
  do i3=l_cell_l_bound+1-1,r_cell_l_bound-1-1  
     r2=cell_lr(1,i3+1)
     result(i3) = va*dcmplx(r2-r1,0.d0)+vb  
  end do

  return
end subroutine cal_vhartea_gzero_1

subroutine cal_vhartea_gzero_2(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
  complex(8), intent(out) :: result(0:n_c-1)

  integer :: mat_gzero,i1,i2,i3,i4,ier
  real(8) :: g_temp,temp_r
  real(8) :: result1
  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_vhartea_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
     call cal_vh_temp1(0,0,i3,result(i3))
     del2_z(i3)=result(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_green1(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-1,r_cell_l_bound-1-1  
     result(i3) = d(i3+1-l_cell_l_bound+1)  
  end do

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

  return
end subroutine cal_vhartea_gzero_2

subroutine cal_vh_temp1(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
  i1_do=kx
  i2_do=ky
  i1=i1_do*n_b+i2_do+1
  if( i1_do == 0 .and. i2_do == 0 ) then
     g_temp=gzero_gamma
  else
     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)-boucon_r(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)-boucon_l(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_temp1

subroutine cal_green1(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_green1
