! @@@@@@@@@@@@@@@@@@@@@@@@@@@@@@@@@@@@@@@@@@@@@@@@@@@@@@@@@@@@@@@@@@@@ !
! @@                                                                @@ !
! @@       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 onsite_rtbh_hamiltonian(max_atom_orbital,i1_do,h_ijmn,s_ijmn)

  use condition
  use rtbh_parameter

  implicit none
  integer, intent(in) :: max_atom_orbital,i1_do
  complex(8), intent(out) :: h_ijmn(max_atom_orbital,max_atom_orbital)
  complex(8), intent(out) :: s_ijmn(max_atom_orbital,max_atom_orbital)
  integer :: id

  id=atom_kindn(i1_do)

  h_ijmn=dcmplx(0.d0,0.d0)
  s_ijmn=dcmplx(0.d0,0.d0)

  h_ijmn(1,1)=dcmplx(h_s(id)+v_lr,0.d0)
  h_ijmn(2,2)=dcmplx(h_p(id)+v_lr,0.d0)
  h_ijmn(3,3)=dcmplx(h_p(id)+v_lr,0.d0)
  h_ijmn(4,4)=dcmplx(h_p(id)+v_lr,0.d0)

  s_ijmn(1,1)=dcmplx(1.d0,0.d0)
  s_ijmn(2,2)=dcmplx(1.d0,0.d0)
  s_ijmn(3,3)=dcmplx(1.d0,0.d0)
  s_ijmn(4,4)=dcmplx(1.d0,0.d0)

  return
end subroutine onsite_rtbh_hamiltonian

subroutine off_rtbh_hamiltonian(iz,kx,ky,lx,ly,i1_do,i2_do,max_atom_orbital        &
     ,h_ijmn,s_ijmn)

  use condition
  use rtbh_parameter

  implicit none
  integer, intent(in) :: max_atom_orbital,kx,ky,lx,ly,iz,i1_do,i2_do
  complex(8), intent(out) :: h_ijmn(max_atom_orbital,max_atom_orbital)
  complex(8), intent(out) :: s_ijmn(max_atom_orbital,max_atom_orbital)

  integer :: id1,id2,j_do,jr_do
  real(8) :: r_distance,rab_distance(3),r_temp_a(3),r_temp_b(3)

  do jr_do=1,3
     r_temp_a(jr_do)=dfloat(kx)*unit_block(1,jr_do)                             &
          +dfloat(ky)*unit_block(2,jr_do)                             &
          +dfloat(iz)*unit_block(3,jr_do)+ra(i1_do,jr_do)
     r_temp_b(jr_do)=dfloat(lx)*unit_block(1,jr_do)                             &
          +dfloat(ly)*unit_block(2,jr_do)+ra(i2_do,jr_do)
  end do

  do jr_do=1,3
     rab_distance(jr_do)=r_temp_b(jr_do)-r_temp_a(jr_do)
  end do

  r_distance=0.d0
  do j_do=1,3
     r_distance=r_distance+rab_distance(j_do)**2
  end do
  r_distance=dsqrt(r_distance)

  rab_distance=rab_distance/r_distance

  id1=atom_kindn(i1_do)
  id2=atom_kindn(i2_do)

  call set_off_rtbh(r_distance,rab_distance,id1,id2                            &
       ,max_atom_orbital,h_ijmn,s_ijmn)

  return
end subroutine off_rtbh_hamiltonian

subroutine set_off_rtbh(r_distance,rab_distance,id1,id2                            &
     ,max_atom_orbital,h_ijmn,s_ijmn)

  use condition
  use rtbh_parameter

  implicit none
  integer, intent(in) :: max_atom_orbital
  integer, intent(in) :: id1,id2
  real(8), intent(in) :: r_distance,rab_distance(3)
  complex(8), intent(out) :: h_ijmn(max_atom_orbital,max_atom_orbital)
  complex(8), intent(out) :: s_ijmn(max_atom_orbital,max_atom_orbital)

  integer :: j_do

  real(8) :: hsss,hsps,hpps,hppp
  real(8) :: hsss_b,hsps_b,hpps_b,hppp_b
  real(8) :: ssss,ssps,spps,sppp
  real(8) :: ssss_b,ssps_b,spps_b,sppp_b
  real(8) :: h_r0(2)

  h_ijmn=dcmplx(0.d0,0.d0)

  call h_ss_sigma_rtbh(id1,id2,r_distance,hsss)
  call h_ss_sigma_rtbh(id1,id2,r_distance,hsss_b)

  call h_sp_sigma_rtbh(id1,id2,r_distance,hsps)
  call h_sp_sigma_rtbh(id1,id2,r_distance,hsps_b)

  call h_pp_sigma_rtbh(id1,id2,r_distance,hpps)
  call h_pp_sigma_rtbh(id1,id2,r_distance,hpps_b)
  call h_pp_pi_rtbh(id1,id2,r_distance,hppp)
  call h_pp_pi_rtbh(id1,id2,r_distance,hppp_b)

  h_ijmn(1,1)=hsss

  do j_do=1,3
     h_ijmn(1,j_do+1)=hsps*rab_distance(j_do)
     h_ijmn(j_do+1,1)=-1.d0*hsps_b*rab_distance(j_do)
  end do

  do j_do=1,3
     h_r0(1)=hpps*rab_distance(j_do)**2
     h_r0(2)=hppp*(1.d0-rab_distance(j_do)**2)
     h_ijmn(j_do+1,j_do+1)=h_r0(1)+h_r0(2) 
  end do

  do j_do=2,3
     h_r0(1)=hpps*rab_distance(1)*rab_distance(j_do)
     h_r0(2)=hppp*rab_distance(1)*rab_distance(j_do)
     h_ijmn(2,j_do+1)=h_r0(1)-h_r0(2) 

     h_r0(1)=hpps_b*rab_distance(1)*rab_distance(j_do)
     h_r0(2)=hppp_b*rab_distance(1)*rab_distance(j_do)
     h_ijmn(j_do+1,2)=h_r0(1)-h_r0(2) 
  end do

  h_r0(1)=hpps*rab_distance(2)*rab_distance(3)
  h_r0(2)=hppp*rab_distance(2)*rab_distance(3)
  h_ijmn(3,4)=h_r0(1)-h_r0(2) 

  h_r0(1)=hpps_b*rab_distance(2)*rab_distance(3)
  h_r0(2)=hppp_b*rab_distance(2)*rab_distance(3)
  h_ijmn(4,3)=h_r0(1)-h_r0(2) 


  s_ijmn=dcmplx(0.d0,0.d0)

  call s_ss_sigma_rtbh(id1,id2,r_distance,ssss)
  call s_ss_sigma_rtbh(id1,id2,r_distance,ssss_b)

  call s_sp_sigma_rtbh(id1,id2,r_distance,ssps)
  call s_sp_sigma_rtbh(id1,id2,r_distance,ssps_b)

  call s_pp_sigma_rtbh(id1,id2,r_distance,spps)
  call s_pp_sigma_rtbh(id1,id2,r_distance,spps_b)
  call s_pp_pi_rtbh(id1,id2,r_distance,sppp)
  call s_pp_pi_rtbh(id1,id2,r_distance,sppp_b)

  s_ijmn(1,1)=ssss

  do j_do=1,3
     s_ijmn(1,j_do+1)=ssps*rab_distance(j_do)
     s_ijmn(j_do+1,1)=-1.d0*ssps_b*rab_distance(j_do)
  end do

  do j_do=1,3
     h_r0(1)=spps*rab_distance(j_do)**2
     h_r0(2)=sppp*(1.d0-rab_distance(j_do)**2)
     s_ijmn(j_do+1,j_do+1)=h_r0(1)+h_r0(2) 
  end do

  do j_do=2,3
     h_r0(1)=spps*rab_distance(1)*rab_distance(j_do)
     h_r0(2)=sppp*rab_distance(1)*rab_distance(j_do)
     s_ijmn(2,j_do+1)=h_r0(1)-h_r0(2) 

     h_r0(1)=spps_b*rab_distance(1)*rab_distance(j_do)
     h_r0(2)=sppp_b*rab_distance(1)*rab_distance(j_do)
     s_ijmn(j_do+1,2)=h_r0(1)-h_r0(2) 
  end do

  h_r0(1)=spps*rab_distance(2)*rab_distance(3)
  h_r0(2)=sppp*rab_distance(2)*rab_distance(3)
  s_ijmn(3,4)=h_r0(1)-h_r0(2) 

  h_r0(1)=spps_b*rab_distance(2)*rab_distance(3)
  h_r0(2)=sppp_b*rab_distance(2)*rab_distance(3)
  s_ijmn(4,3)=h_r0(1)-h_r0(2) 

  return
end subroutine set_off_rtbh

subroutine h_ss_sigma_rtbh(id1,id2,r,hsss)

  use rtbh_parameter

  implicit none
  integer, intent(in) :: id1,id2
  real(8), intent(in) :: r
  real(8), intent(out) :: hsss
  real(8) :: rc,nc,qr,x,pai

  nc=-b*dsqrt(v_ss(id1)*v_ss(id2))

  x=a*r/(r_ss(id1)+r_ss(id2))
  rc=dexp(-x)*(1.d0+x+x*x/3.d0)

  if( r < r1 ) then
     qr=1.d0
  else
     if( r > r2 ) then
        qr=0.d0
     else
        pai=datan(1.d0)*4.d0
        qr=.5d0*(1.d0+dcos(pai*(r-r1)/(r2-r1)))
     end if
  end if

  hsss=nc*rc*qr

  return
end subroutine h_ss_sigma_rtbh

subroutine h_sp_sigma_rtbh(id1,id2,r,hsps)

  use rtbh_parameter

  implicit none
  integer, intent(in) :: id1,id2
  real(8), intent(in) :: r
  real(8), intent(out) :: hsps
  real(8) :: rc,nc,qr,x,pai

  nc=-b*dsqrt(v_ss(id1)*v_ps(id2))

  x=a*r/(r_ss(id1)+r_ps(id2))
  rc=-dexp(-x)*(x+x*x/3.d0)

  if( r < r1 ) then
     qr=1.d0
  else
     if( r > r2 ) then
        qr=0.d0
     else
        pai=datan(1.d0)*4.d0
        qr=.5d0*(1.d0+dcos(pai*(r-r1)/(r2-r1)))
     end if
  end if

  hsps=nc*rc*qr

  return
end subroutine h_sp_sigma_rtbh

subroutine h_pp_sigma_rtbh(id1,id2,r,hpps)

  use rtbh_parameter

  implicit none
  integer, intent(in) :: id1,id2
  real(8), intent(in) :: r
  real(8), intent(out) :: hpps
  real(8) :: rc,nc,qr,x,pai

  nc=-b*dsqrt(v_ps(id1)*v_ps(id2))

  x=a*r/(r_ps(id1)+r_ps(id2))
  rc=-dexp(-x)*(-1.d0+x+x*x/3.d0)

  if( r < r1 ) then
     qr=1.d0
  else
     if( r > r2 ) then
        qr=0.d0
     else
        pai=datan(1.d0)*4.d0
        qr=.5d0*(1.d0+dcos(pai*(r-r1)/(r2-r1)))
     end if
  end if

  hpps=nc*rc*qr

  return
end subroutine h_pp_sigma_rtbh

subroutine h_pp_pi_rtbh(id1,id2,r,hppp)

  use rtbh_parameter

  implicit none
  integer, intent(in) :: id1,id2
  real(8), intent(in) :: r
  real(8), intent(out) :: hppp
  real(8) :: rc,nc,qr,x,pai

  nc=-b*dsqrt(v_pp(id1)*v_pp(id2))

  x=a*r/(r_pp(id1)+r_pp(id2))
  rc=dexp(-x)*(1.d0+x+x*x/3.d0)

  if( r < r1 ) then
     qr=1.d0
  else
     if( r > r2 ) then
        qr=0.d0
     else
        pai=datan(1.d0)*4.d0
        qr=.5d0*(1.d0+dcos(pai*(r-r1)/(r2-r1)))
     end if
  end if

  hppp=nc*rc*qr

  return
end subroutine h_pp_pi_rtbh

subroutine s_ss_sigma_rtbh(id1,id2,r,ssss)

  use rtbh_parameter

  implicit none
  integer, intent(in) :: id1,id2
  real(8), intent(in) :: r
  real(8), intent(out) :: ssss
  real(8) :: rc,nc,qr,x,pai

  nc=dsqrt(u_ss(id1)*u_ss(id2))

  x=a*r/(r_ss(id1)+r_ss(id2))
  rc=dexp(-x)*(1.d0+x+x*x/3.d0)

  if( r < r1 ) then
     qr=1.d0
  else
     if( r > r2 ) then
        qr=0.d0
     else
        pai=datan(1.d0)*4.d0
        qr=.5d0*(1.d0+dcos(pai*(r-r1)/(r2-r1)))
     end if
  end if

  ssss=nc*rc*qr

  return
end subroutine s_ss_sigma_rtbh

subroutine s_sp_sigma_rtbh(id1,id2,r,ssps)

  use rtbh_parameter

  implicit none
  integer, intent(in) :: id1,id2
  real(8), intent(in) :: r
  real(8), intent(out) :: ssps
  real(8) :: rc,nc,qr,x,pai

  nc=dsqrt(u_ss(id1)*u_ps(id2))

  x=a*r/(r_ss(id1)+r_ps(id2))
  rc=-dexp(-x)*(x+x*x/3.d0)

  if( r < r1 ) then
     qr=1.d0
  else
     if( r > r2 ) then
        qr=0.d0
     else
        pai=datan(1.d0)*4.d0
        qr=.5d0*(1.d0+dcos(pai*(r-r1)/(r2-r1)))
     end if
  end if

  ssps=nc*rc*qr

  return
end subroutine s_sp_sigma_rtbh

subroutine s_pp_sigma_rtbh(id1,id2,r,spps)

  use rtbh_parameter

  implicit none
  integer, intent(in) :: id1,id2
  real(8), intent(in) :: r
  real(8), intent(out) :: spps
  real(8) :: rc,nc,qr,x,pai

  nc=dsqrt(u_ps(id1)*u_ps(id2))

  x=a*r/(r_ps(id1)+r_ps(id2))
  rc=-dexp(-x)*(-1.d0+x+x*x/3.d0)

  if( r < r1 ) then
     qr=1.d0
  else
     if( r > r2 ) then
        qr=0.d0
     else
        pai=datan(1.d0)*4.d0
        qr=.5d0*(1.d0+dcos(pai*(r-r1)/(r2-r1)))
     end if
  end if

  spps=nc*rc*qr

  return
end subroutine s_pp_sigma_rtbh

subroutine s_pp_pi_rtbh(id1,id2,r,sppp)

  use rtbh_parameter

  implicit none
  integer, intent(in) :: id1,id2
  real(8), intent(in) :: r
  real(8), intent(out) :: sppp
  real(8) :: rc,nc,qr,x,pai

  nc=dsqrt(u_pp(id1)*u_pp(id2))

  x=a*r/(r_pp(id1)+r_pp(id2))
  rc=dexp(-x)*(1.d0+x+x*x/3.d0)

  if( r < r1 ) then
     qr=1.d0
  else
     if( r > r2 ) then
        qr=0.d0
     else
        pai=datan(1.d0)*4.d0
        qr=.5d0*(1.d0+dcos(pai*(r-r1)/(r2-r1)))
     end if
  end if

  sppp=nc*rc*qr

  return
end subroutine s_pp_pi_rtbh
