! @@@@@@@@@@@@@@@@@@@@@@@@@@@@@@@@@@@@@@@@@@@@@@@@@@@@@@@@@@@@@@@@@@@@ !
! @@                                                                @@ !
! @@       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 set_chemical_potential(i_rl)

  use condition_ini
  use condition
  use hamiltonian_zper
  use hamiltonian_sgf
  use hamiltonian_c
  use hamiltonian_temp
  use eigen_values
  use gf_se_c
  use mod_mpi

  implicit none
  include 'mpif.h'
  integer, intent(in) :: i_rl

  integer :: kx,ky,kz,mat_max,ispin
  integer :: mul
  real(8) :: st1,st2,stdel

  integer :: i1_do,i2_do,i3_do,i4_do,i5_do,i_temp,ier
  real(8), allocatable :: tr_temp1(:,:,:),tr_temp2(:,:,:,:,:,:)

  character(50) :: switch_eigen

  integer :: kt
  real(8) :: qx_tr,qy_tr

  !                                                ==================================
  !                                                  set chemical potential
  !                                               for tight-binding method, basically
  !                                                ==================================

  if( i_rl == 1 ) then
     switch_eigen=switch_l_eigen
  else
     switch_eigen=switch_r_eigen
  end if

  open(unit=16,file=file_tempout,position='append')
  write(16,*)
  write(16,*) '++++++++++++++++++++++++++++++++++++++++++++++++++++++++++++++'
  if( i_rl == 1 ) then
     write(16,*) '++++++++++++ chemical_potential: left'
  else
     write(16,*) '++++++++++++ chemical_potential: right'
  end if
  write(16,*) '++++++++++++++++++++++++++++++++++++++++++++++++++++++++++++++'
  close(16)

  call myclock(st1)

  call alo_hamiltonian_zper

  mat_max=mat_max_zper
  mat_ev_max=2*mat_max

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

  do kt=1,ka_tr*kb_tr
     if( ham_model == 'input' .or. ham_model == 'scf_accel' ) then
        qx_tr=po_kt_tr(2,kt)
        qy_tr=po_kt_tr(3,kt)
     end if

     do ispin=1,spin_switch_temp

        do kx=1,kx_max
           do ky=1,ky_max
              if( p_or_f == 'periodic' ) then
                 open(unit=16,file=file_tempout,position='append')
                 write(16,*) 'cal_eigen',kx_max,ky_max,kx,ky
                 close(16)
              end if
              if( ham_model == 'input' .or. ham_model == 'scf_accel' ) then
                 call alo_ham_temp_ham(m_mat_max_c,mat_max_ll,mat_max_rr)
                 if( lr_switch == -1 ) then
                    call set_ham_temp_ham_l(qx_tr,qy_tr)
                 end if
                 if( lr_switch == 1 ) then
                    call set_ham_temp_ham_r(qx_tr,qy_tr)
                 end if
              end if
              do kz=1+myrank,kz_max/2+1,nprocs
                 if( p_or_f == 'free' ) then
                    open(unit=16,file=file_tempout,position='append')
                    write(16,*) 'cal_eigen',kz_max,kz
                    close(16)
                 end if
                 open(unit=16,file=file_tempout,position='append')
                 call set_hamiltonian_zper(kx,ky,kz,ispin)
                 if( switch_eigen == 'on' ) then
                    if( eigen_s_as == 'symmetry' ) then
                       call cal_eigen(kx,ky,kz,ispin,kt)
                    else
                       if( eigen_s_as == 'general' ) then
                          call cal_eigen_as(kx,ky,kz,ispin,kt)
                       else
                          write(6,*) 'error: method_eigen;; set_chemical_potential'
                          stop
                       end if
                    end if
                 end if
                 if( dos_on_off == 'on' ) then
                    if( kz == 1 .or. kz == (kz_max/2+1) ) then
                       mul=1
                    else
                       mul=2
                    end if
                    call gf_bulk(mul,ispin,kt)
                 end if
                 close(16)
              end do
              if( ham_model == 'input' .or. ham_model == 'scf_accel' ) then
                 call dealo_ham_temp_ham
              end if
           end do
        end do
     end do
  end do

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

  allocate(tr_temp1(omega_par_num(num_gra_te),spin_switch_temp,ka_tr*kb_tr)  &
       ,stat=ier)
  if( ier /= 0 ) then
     write(6,*) 'error allocate: alo_density_temp'
     stop
  end if
  tr_temp1(:,:,:)=0.d0

  i_temp=omega_par_num(num_gra_te)*spin_switch_temp*ka_tr*kb_tr

  call MPI_REDUCE(dos,tr_temp1,i_temp,MPI_DOUBLE_PRECISION,MPI_SUM,0           &
       ,mpi_comm_world,ierr)

  dos(:,:,:) = tr_temp1(:,:,:)

  deallocate(tr_temp1,stat=ier)
  if( ier /= 0 ) then
     write(6,*) 'error allocate: alo_density_temp'
     stop
  end if

  allocate(tr_temp2(mat_max_eigen,kz_max,ky_max,kx_max,spin_switch_temp      &
       ,ka_tr*kb_tr),stat=ier)
  if( ier /= 0 ) then
     write(6,*) 'error allocate: alo_density_temp'
     stop
  end if

  tr_temp2(:,:,:,:,:,:) = 0.0d0

  i_temp=mat_max_eigen*kz_max*ky_max*kx_max*spin_switch_temp*ka_tr*kb_tr
  call MPI_REDUCE(ev_mat,tr_temp2,i_temp,MPI_DOUBLE_PRECISION,MPI_SUM,0        &
       ,mpi_comm_world,ierr)

  ev_mat(:,:,:,:,:,:) = tr_temp2(:,:,:,:,:,:)

  deallocate(tr_temp2,stat=ier)
  if( ier /= 0 ) then
     write(6,*) 'error allocate: alo_density_temp'
     stop
  end if

  i_temp=omega_par_num(num_gra_te)*spin_switch_temp*ka_tr*kb_tr
  call MPI_BCAST(dos,i_temp,MPI_DOUBLE_PRECISION,0,mpi_comm_world,ierr)
  i_temp=mat_max_eigen*kz_max*ky_max*kx_max*spin_switch_temp*ka_tr*kb_tr
  call MPI_BCAST(ev_mat,i_temp,MPI_DOUBLE_PRECISION,0,mpi_comm_world,ierr)

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

  call cal_chemical_potential(ka_tr*kb_tr)

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

  call unset_hamiltonian_zper

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

  open(unit=16,file=file_tempout,position='append')
  call myclock(st2)
  stdel=st2-st1
  write(16,*) '           t=',stdel
  close(16)

  return
end subroutine set_chemical_potential

subroutine cal_eigen(kx,ky,kz,ispin,kt)

  use condition
  use hamiltonian_zper
  use eigen_values

  implicit none

  integer, intent(in) :: kx,ky,kz,ispin,kt
  integer :: i1_do,i2_do,i3_do,i4_do,i_count,l_con,mat_max,ier
  real(8) :: norm_temp
  complex(8) :: temp,temp1
  complex(8), allocatable :: temp_mat1(:,:),temp_mat2(:)

  mat_max=mat_max_zper

  call alo_eigen_values_1

  do i2_do=1,mat_max
     do i1_do=1,mat_max
        a(2*i1_do-1,2*i2_do-1)=dreal(s00_mat(i1_do,i2_do))
        a(2*i1_do-1,2*i2_do)=-dimag(s00_mat(i1_do,i2_do))
        a(2*i1_do,2*i2_do-1)=dimag(s00_mat(i1_do,i2_do))
        a(2*i1_do,2*i2_do)=dreal(s00_mat(i1_do,i2_do))
     end do
  end do
  l_con=1
  call ep1(a,d,mat_ev_max,l_con)
  do i1_do=1,mat_ev_max
     i_num(i1_do)=i1_do
  end do
  do i1_do=1,mat_ev_max
     do i2_do=i1_do+1,mat_ev_max
        if( d(i_num(i1_do)) > d(i_num(i2_do)) ) then
           i3_do=i_num(i1_do)
           i_num(i1_do)=i_num(i2_do)
           i_num(i2_do)=i3_do
        end if
     end do
  end do

  call alo_eigen_values_2

  do i1_do=1,mat_ev_max
     e_temp(i1_do)=d(i_num(i1_do))
     do i2_do=1,mat_max
        ev_vec_temp(i2_do,i1_do)                                                 &
             =dcmplx(a(2*i2_do-1,i_num(i1_do)),a(2*i2_do,i_num(i1_do)))
     end do
  end do

  call unset_eigen_values_1
  call alo_eigen_values_3

  do i1_do=1,mat_max
     s_ev(i1_do)=e_temp(2*i1_do)
     do i2_do=1,mat_max
        ev_vec(i2_do,i1_do)=ev_vec_temp(i2_do,2*i1_do)
     end do
  end do

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

  i_count=0
10 continue
  do i1_do=1,mat_max
     do i2_do=1,mat_max
        temp=dcmplx(0.d0,0.d0)
        if( i1_do == i2_do ) then
           do i3_do=1,mat_max
              temp=temp+dconjg(ev_vec(i3_do,i1_do))*ev_vec(i3_do,i1_do)
           end do
        else
           do i3_do=1,mat_max
              temp=temp+dconjg(ev_vec(i3_do,i1_do))*ev_vec(i3_do,i2_do)
           end do
           if( cdabs(temp) > 1.d-10 ) then
              temp1=temp
              temp=dcmplx(0.d0,0.d0)
              norm_temp=0.d0
              do i3_do=1,mat_max
                 ev_vec(i3_do,i2_do)=ev_vec(i3_do,i2_do)-temp1*ev_vec(i3_do,i1_do)
                 norm_temp=norm_temp+dconjg(ev_vec(i3_do,i2_do))*ev_vec(i3_do,i2_do)
                 temp=temp+dconjg(ev_vec(i3_do,i1_do))*ev_vec(i3_do,i2_do)
              end do
              if( norm_temp < 1.d-15 ) then
                 i_count=i_count+1
                 do i3_do=1,mat_max
                    ev_vec(i3_do,i2_do)=ev_vec_temp(i3_do,2*i2_do-1)
                 end do
                 if( i_count > mat_max*2 ) then
                    write(6,*) 'error - eigen_vector',i_count,norm_temp
                    stop
                 end if
                 go to 10
              else
                 do i3_do=1,mat_max
                    ev_vec(i3_do,i2_do)=ev_vec(i3_do,i2_do)/dsqrt(norm_temp)
                 end do
              end if
           end if
        end if
     end do
  end do

  call unset_eigen_values_2

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

  call alo_eigen_values_1

  allocate(temp_mat2(mat_max),stat=ier)
  if( ier /= 0 ) then
     write(6,*) 'error allocate: cal_eigen'
     stop
  end if

  do i1_do=1,mat_max
     s_ev(i1_do)=1.d0/dsqrt(s_ev(i1_do))
  end do
  do i2_do=1,mat_max
     temp_mat2=dcmplx(0.d0,0.d0)
     do i4_do=1,mat_max
        do i3_do=1,mat_max
           temp_mat2(i3_do)=temp_mat2(i3_do)                                      &
                +h00_mat(i3_do,i4_do)*ev_vec(i4_do,i2_do)
        end do
     end do
     do i1_do=1,mat_max
        temp=dcmplx(0.d0,0.d0)
        do i3_do=1,mat_max
           temp=temp+dconjg(ev_vec(i3_do,i1_do))*temp_mat2(i3_do)
        end do
        temp=s_ev(i1_do)*temp*s_ev(i2_do)
        a(2*i1_do-1,2*i2_do-1)=dreal(temp)
        a(2*i1_do-1,2*i2_do)=-dimag(temp)
        a(2*i1_do,2*i2_do-1)=dimag(temp)
        a(2*i1_do,2*i2_do)=dreal(temp)
     end do
  end do

  deallocate(temp_mat2,stat=ier)
  if( ier /= 0 ) then
     write(6,*) 'error deallocate: cal_eigen'
     stop
  end if

  call unset_eigen_values_3

  l_con=0
  call ep1(a,d,mat_ev_max,l_con)

  do i1_do=1,mat_ev_max
     i_num(i1_do)=i1_do
  end do
  do i1_do=1,mat_ev_max
     do i2_do=i1_do+1,mat_ev_max
        if( d(i_num(i1_do)) > d(i_num(i2_do)) ) then
           i3_do=i_num(i1_do)
           i_num(i1_do)=i_num(i2_do)
           i_num(i2_do)=i3_do
        end if
     end do
  end do
  do i1_do=1,mat_max
     ev_mat(i1_do,kz,ky,kx,ispin,kt)=d(i_num(2*i1_do))
  end do

  call unset_eigen_values_1

  return
end subroutine cal_eigen

subroutine cal_eigen_as(kx,ky,kz,ispin,kt)

  use condition
  use hamiltonian_zper
  use eigen_values

  implicit none

  integer, intent(in) :: kx,ky,kz,ispin,kt
  integer :: i1_do,i2_do,i3_do,mat_max,ier,ier_ev
  complex(8), allocatable :: temp_mat1(:,:),temp_mat2(:,:)

  mat_max=mat_max_zper

  allocate(temp_mat1(mat_max,mat_max),stat=ier)
  if( ier /= 0 ) then
     write(6,*) 'error allocate: cal_eigen_as 1'
     stop
  end if

  call inverse_mat1(mat_max,s00_mat,temp_mat1)

  allocate(temp_mat2(mat_max,mat_max),stat=ier)
  if( ier /= 0 ) then
     write(6,*) 'error allocate: cal_eigen_as 2'
     stop
  end if

  call mat_mul(mat_max,temp_mat1,h00_mat,temp_mat2)

  call alo_eigen_values_as

  do i2_do=1,mat_max
     do i1_do=1,mat_max
        a_as(2*i1_do-1,2*i2_do-1)=dreal(temp_mat2(i1_do,i2_do))
        a_as(2*i1_do-1,2*i2_do)=-dimag(temp_mat2(i1_do,i2_do))
        a_as(2*i1_do,2*i2_do-1)=dimag(temp_mat2(i1_do,i2_do))
        a_as(2*i1_do,2*i2_do)=dreal(temp_mat2(i1_do,i2_do))
     end do
  end do

  deallocate(temp_mat2,stat=ier)
  if( ier /= 0 ) then
     write(6,*) 'error deallocate: cal_eigen_as 1'
     stop
  end if

  call ep_as1(a_as,d_as,mat_ev_max,ier_ev)

  if( ier_ev == 0) then
     do i1_do=1,mat_ev_max
        if( dabs(dimag(d_as(i1_do))) > 1.d-10 ) then
           write(16,*) 'error: eigen_as (imaginaly part)',d_as(i1_do)
           ier_ev=1
        end if
     end do
  end if

  if( ier_ev == 0 ) then
     deallocate(temp_mat1,stat=ier)
     if( ier /= 0 ) then
        write(6,*) 'error deallocate: cal_eigen_as 2'
        stop
     end if
     go to 10
  end if

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

  allocate(temp_mat2(mat_max,mat_max),stat=ier)
  if( ier /= 0 ) then
     write(6,*) 'error allocate: cal_eigen_as 3'
     stop
  end if

  call mat_mul(mat_max,h00_mat,temp_mat1,temp_mat2)

  call alo_eigen_values_as

  do i2_do=1,mat_max
     do i1_do=1,mat_max
        a_as(2*i1_do-1,2*i2_do-1)=dreal(temp_mat2(i1_do,i2_do))
        a_as(2*i1_do-1,2*i2_do)=-dimag(temp_mat2(i1_do,i2_do))
        a_as(2*i1_do,2*i2_do-1)=dimag(temp_mat2(i1_do,i2_do))
        a_as(2*i1_do,2*i2_do)=dreal(temp_mat2(i1_do,i2_do))
     end do
  end do

  deallocate(temp_mat1,temp_mat2,stat=ier)
  if( ier /= 0 ) then
     write(6,*) 'error deallocate: cal_eigen_as 3'
     stop
  end if

  call ep_as1(a_as,d_as,mat_ev_max,ier_ev)

  if( ier_ev == 0) then
     do i1_do=1,mat_ev_max
        if( dabs(dimag(d_as(i1_do))) > 1.d-10 ) then
           write(16,*) 'error: eigen_as (imaginaly part)',d_as(i1_do)
           ier_ev=1
        end if
     end do
  end if

  if( ier_ev /= 0 ) then
     write(16,*) 'error: eigen_as '
     call unset_eigen_values_as
     call cal_eigen(kx,ky,kz,ispin,kt)
     return
  end if

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

10 continue

  do i1_do=1,mat_ev_max
     i_num(i1_do)=i1_do
  end do
  do i1_do=1,mat_ev_max
     do i2_do=i1_do+1,mat_ev_max
        if( dreal(d_as(i_num(i1_do))) > dreal(d_as(i_num(i2_do))) ) then
           i3_do=i_num(i1_do)
           i_num(i1_do)=i_num(i2_do)
           i_num(i2_do)=i3_do
        end if
     end do
  end do
  do i1_do=1,mat_max
     ev_mat(i1_do,kz,ky,kx,ispin,kt)=dreal(d_as(i_num(2*i1_do)))
  end do

  call unset_eigen_values_as

  return
end subroutine cal_eigen_as

subroutine cal_chemical_potential(kt_num)

  use condition
  use hamiltonian_zper
  use eigen_values

  implicit none
  integer, intent(in) :: kt_num

  integer :: num_total_ele
  integer :: i1_do,i2_do,kx,ky,kz,iter,mat_max,ier,ispin,kt
  real(8) :: temp_t
  real(8), allocatable :: temp(:)

  mat_max=mat_max_zper

  do kt=1,kt_num
     do ispin=1,spin_switch_temp
        do kx=1,kx_max
           do ky=1,ky_max
              do kz=2,kz_max/2
                 do i1_do=1,mat_max
                    ev_mat(i1_do,kz_max-kz+2,ky,kx,ispin,kt)                         &
                         =ev_mat(i1_do,kz,ky,kx,ispin,kt)
                 end do
              end do
           end do
        end do
     end do
  end do

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

  allocate(temp(kx_max*ky_max*kz_max*mat_max*kt_num*2),stat=ier)
  if( ier /= 0 ) then
     write(6,*) 'error allocate: cal_chemical_potential'
     stop
  end if

  iter=0
  do kt=1,kt_num
     do kx=1,kx_max
        do ky=1,ky_max
           do kz=1,kz_max
              do i1_do=1,mat_max
                 if( spin_switch_temp == 1 ) then
                    iter=iter+1
                    temp(iter)=ev_mat(i1_do,kz,ky,kx,1,kt)
                    iter=iter+1
                    temp(iter)=ev_mat(i1_do,kz,ky,kx,1,kt)
                 else
                    iter=iter+1
                    temp(iter)=ev_mat(i1_do,kz,ky,kx,1,kt)
                    iter=iter+1
                    temp(iter)=ev_mat(i1_do,kz,ky,kx,2,kt)
                 end if
              end do
           end do
        end do
     end do
  end do

  do i1_do=1,kx_max*ky_max*kz_max*mat_max*kt_num*2
     do i2_do=i1_do+1,kx_max*ky_max*kz_max*mat_max*kt_num*2
        if( temp(i1_do) > temp(i2_do) ) then
           temp_t=temp(i1_do)
           temp(i1_do)=temp(i2_do)
           temp(i2_do)=temp_t
        end if
     end do
  end do

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

  if( ham_model == 'input' .or. ham_model == 'scf_accel' ) then
     num_total_ele=ele_num_temp
  else
     num_total_ele=0.d0
     do i1_do=1,num_atom
        num_total_ele=num_total_ele+atom_electron(atom_kindn(i1_do))
     end do
  end if
  num_total_ele=num_total_ele*kx_max*ky_max*kz_max*kt_num

  if( num_total_ele < kx_max*ky_max*kz_max*mat_max*kt_num*2 ) then
     cp=(temp(num_total_ele)+temp(num_total_ele+1))*.5d0
  else
     cp=temp(kx_max*ky_max*kz_max*mat_max*kt_num*2)
  end if

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

  deallocate(temp,stat=ier)
  if( ier /= 0 ) then
     write(6,*) 'error deallocate: cal_chemical_potential'
     stop
  end if

  return
end subroutine cal_chemical_potential

subroutine gf_bulk(mul,ispin,kt)

  use condition
  use hamiltonian_zper

  implicit none
  integer , intent(in) :: mul,ispin,kt
  integer :: i1_do,i2_do,j1_do,j2_do,ier,mat_max
  complex(8) :: w
  complex(8), allocatable :: a_mat(:,:),b_mat(:,:)

  mat_max=mat_max_zper

  allocate(a_mat(mat_max,mat_max),b_mat(mat_max,mat_max),stat=ier)
  if( ier /= 0 ) then
     write(6,*) 'error allocate: gf_bulk'
     stop
  end if

  do j1_do=1,omega_par_num(num_gra_te)
     w=omega(omega_par(num_gra_te)+j1_do)
     do i2_do=1,mat_max
        do i1_do=1,mat_max
           a_mat(i1_do,i2_do)=w*s00_mat(i1_do,i2_do)-h00_mat(i1_do,i2_do)
        end do
     end do
     call inverse_mat1(mat_max,a_mat,b_mat)
     do j2_do=1,mat_max
        dos(j1_do,ispin,kt)=dos(j1_do,ispin,kt)                                  &
             -dimag(b_mat(j2_do,j2_do))*dfloat(mul)
     end do
  end do

  deallocate(a_mat,b_mat,stat=ier)
  if( ier /= 0 ) then
     write(6,*) 'error deallocate: gf_bulk'
     stop
  end if

  return
end subroutine gf_bulk
