! @@@@@@@@@@@@@@@@@@@@@@@@@@@@@@@@@@@@@@@@@@@@@@@@@@@@@@@@@@@@@@@@@@@@ !
! @@                                                                @@ !
! @@       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_gf_se_c

  use condition_ini
  use hamiltonian_sgf
  use hamiltonian_c
  use hamiltonian_temp
  use gf_se_c
  use constant
  use mod_mpi
  use scf_negf

  implicit none
  include 'mpif.h'
  integer :: ic_spin
  integer :: iw_max_mpi
  integer :: iw_do,i1_do,i2_do,i3_do,icou_l,icou_r
  integer :: px,py,qx,qy,ispin
  complex(8) :: w

  real(8) :: st1,st2,stdel,t_tot

  complex(8), allocatable :: tr_temp11(:,:,:,:),tr_temp12(:,:,:,:)
  integer :: i_temp,ier

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

  if( file_selfe_outsw == 'on' ) then
     call alo_mod_sftr(kt_tr,file_selfenergy)
  end if
  call alo_ham_temp_ham(m_mat_max_c,mat_max_ll,mat_max_rr)

  open(unit=16,file=file_tempout,position='append')
  write(16,*)
  write(16,*) '++++++++++++++++++++++++++++++++++++++++++++++++++++++++++++++'
  write(16,*) '++++++++++++ start calculation:'
  write(16,*) '++++++++++++++++++++++++++++++++++++++++++++++++++++++++++++++'
  write(16,*)
  close(16)

  call show_ksampling

  if( spin_switch_cc /= 2) then
     ic_spin=1
  else
     ic_spin=2
  end if

  !                                +++++++++++++++++++++++++++++++++++++++++++++++++++

  do kt=1,ka_tr*kb_tr
     if( ham_model_ini /= 'rtb_h' .and. ham_model_ini /= 'gsp' ) then
        qx_tr=po_kt_tr(2,kt)
        qy_tr=po_kt_tr(3,kt)
     else
        qx_tr=0.d0
        qy_tr=0.d0
     end if

     open(unit=16,file=file_tempout,position='append')
     write(16,*) '--------------------------------------------------------------'
     write(16,800) kt,qx_tr,qy_tr
800  format(' ------------  ',i5,2f13.8)
     write(16,*) '--------------------------------------------------------------'
     close(16)

     if( file_selfe_outsw == 'on' ) then
        open(unit=60,file=file_sf_tr(kt,myrank+1))
        write(60,995) m_mat_max_c,iw_max_gs
        write(60,996) omega_gs(1)
        write(60,996) omega_gs(iw_max_gs)
        close(60)
     end if

     call set_ham_temp_ham_l(qx_tr,qy_tr)
     call set_ham_temp_ham_r(qx_tr,qy_tr)
     if( ham_model_ini == 'input' ) then
        call set_ham_temp_ham_c(qx_tr,qy_tr)
        if( myrank == 0 ) then
           if( switch_out_ham /= 'off' ) then
              call outham(kt,ic_spin,m_mat_max_c,hcc_t,scc_t)
           end if
        end if
     end if
     if( ham_model_ini == 'scf_accel' ) then
        call set_ham_scf_ham_c(qx_tr,qy_tr)
        if( myrank == 0 ) then
           if( switch_out_ham /= 'off' ) then
              call outham(kt,ic_spin,m_mat_max_c,h_cc_scf,s_cc_scf)
           end if
        end if
     end if

     if( mod(iw_max_gs,nprocs) == 0 ) then
        iw_max_mpi=iw_max_gs
     else
        iw_max_mpi=iw_max_gs+nprocs-mod(iw_max_gs,nprocs)
     end if
     iw_max_mpi=(iw_max_mpi/nprocs)*nprocs
     do iw_do=1+myrank,iw_max_mpi,nprocs

        open(unit=16,file=file_tempout,position='append')
        write(16,*) '     ------- cal_gf_se_c:',iw_do
        close(16)

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

        do ispin=1,ic_spin

           if( iw_do > iw_max_gs ) then
              go to 100
           end if
           w=omega_gs(iw_do)

           t_tot=0.d0

           open(unit=16,file=file_tempout,position='append')
           call myclock(st1)
           do px=1,kx_max_ll                                       ! kx_max_ll = 1
              do py=1,ky_max_ll                                     ! ky_max_ll = 1
                 call selfenergy_l(w,iw_do,px,py,ispin,kt)

                 if( file_selfe_outsw == 'on' ) then
                    icou_l=0
                    do i2_do=1,m_mat_max_c
                       do i1_do=1,m_mat_max_c
                          if( se_l_mat_per(i1_do,i2_do,px,py) /= dcmplx(0.d0,0.d0) )then
                             icou_l=icou_l+1
                          end if
                       end do
                    end do
                 end if
              end do
           end do

           call myclock(st2)
           stdel=st2-st1
           t_tot=t_tot+stdel
           close(16)

           open(unit=16,file=file_tempout,position='append')
           call myclock(st1)

           do qx=1,kx_max_rr                                       ! kx_max_rr = 1
              do qy=1,ky_max_rr                                     ! ky_max_rr = 1
                 call selfenergy_r(w,iw_do,qx,qy,ispin,kt)

                 if( file_selfe_outsw == 'on' ) then
                    icou_r=0
                    do i2_do=1,m_mat_max_c
                       do i1_do=1,m_mat_max_c
                          if( se_r_mat_per(i1_do,i2_do,qx,qy) /= dcmplx(0.d0,0.d0) )then
                             icou_r=icou_r+1
                          end if
                       end do
                    end do
                 end if
              end do
           end do

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

100        continue

           if( file_selfe_outsw == 'on' ) then
              if( iw_do <= iw_max_gs ) then
                 do px=1,kx_max_ll
                    do py=1,ky_max_ll
                       open(unit=60,file=file_sf_tr(kt,myrank+1),position='append')
                       write(60,997) w,ispin
                       write(60,*) icou_l
                       do i2_do=1,m_mat_max_c
                          do i1_do=1,m_mat_max_c
                             if( se_l_mat_per(i1_do,i2_do,px,py)                        &
                                  /= dcmplx(0.d0,0.d0) ) then
                                write(60,999)i1_do,i2_do,se_l_mat_per(i1_do,i2_do,px,py)
                             end if
                          end do
                       end do
                       close(60)
                    end do
                 end do
                 do qx=1,kx_max_rr
                    do qy=1,ky_max_rr
                       open(unit=60,file=file_sf_tr(kt,myrank+1),position='append')
                       write(60,998) w,ispin
                       write(60,*) icou_r
                       do i2_do=1,m_mat_max_c
                          do i1_do=1,m_mat_max_c
                             if( se_r_mat_per(i1_do,i2_do,qx,qy)                        &
                                  /= dcmplx(0.d0,0.d0) ) then
                                write(60,999)i1_do,i2_do,se_r_mat_per(i1_do,i2_do,qx,qy)
                             end if
                          end do
                       end do
                       close(60)
                    end do
                 end do
              end if
           end if

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

           call myclock(st2)
           stdel=st2-st1
           t_tot=t_tot+stdel
           close(16)

           open(unit=16,file=file_tempout,position='append')
           call myclock(st1)

           do px=1,kx_max_ll                                       ! kx_max_ll = 1
              do py=1,ky_max_ll                                     ! ky_max_ll = 1
                 do qx=1,kx_max_rr                                   ! kx_max_rr = 1
                    do qy=1,ky_max_rr                                 ! ky_max_rr = 1
                       call trans(w,iw_do,px,py,qx,qy,ispin,kt)
                    end do
                 end do
              end do
           end do

           call myclock(st2)
           stdel=st2-st1
           t_tot=t_tot+stdel
           write(16,*) '           t(spin:',ispin,')=',t_tot
           close(16)

        end do

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

     end do

  end do

  if( file_selfe_outsw == 'on' ) then
     call dealo_mod_sftr
  end if
  call dealo_ham_temp_ham

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

  allocate(tr_temp11(4+num_block_gr,ic_spin,iw_max_gs,ka_tr*kb_tr)           &
       ,tr_temp12(4+num_block_gr,ic_spin,iw_max_gs,ka_tr*kb_tr)           &
       ,stat=ier)
  if( ier /= 0 ) then
     write(6,*) 'error allocate: alo_density_temp'
     stop
  end if

  do kt=1,ka_tr*kb_tr
     do i1_do=1,iw_max_gs
        do i2_do=1,ic_spin
           tr_temp11(1,i2_do,i1_do,kt)=tr_gr_l(i2_do,i1_do,kt)
           tr_temp11(2,i2_do,i1_do,kt)=tr_gr_r(i2_do,i1_do,kt)
           tr_temp11(3,i2_do,i1_do,kt)=tr_gr_c(i2_do,i1_do,kt)
           tr_temp11(4,i2_do,i1_do,kt)=tr_tr(i2_do,i1_do,kt)
           do i3_do=1,num_block_gr
              tr_temp11(4+i3_do,i2_do,i1_do,kt)=tr_grc_block(i2_do,i3_do,i1_do,kt)
           end do
        end do
     end do
  end do

  i_temp=(4+num_block_gr)*ic_spin*iw_max_gs*ka_tr*kb_tr
  call MPI_REDUCE(tr_temp11,tr_temp12,i_temp,MPI_DOUBLE_COMPLEX,MPI_SUM,0    &
       ,mpi_comm_world,ierr)

  do kt=1,ka_tr*kb_tr
     do i1_do=1,iw_max_gs
        do i2_do=1,ic_spin
           tr_gr_l(i2_do,i1_do,kt)=tr_temp12(1,i2_do,i1_do,kt)
           tr_gr_r(i2_do,i1_do,kt)=tr_temp12(2,i2_do,i1_do,kt)
           tr_gr_c(i2_do,i1_do,kt)=tr_temp12(3,i2_do,i1_do,kt)
           tr_tr(i2_do,i1_do,kt)=tr_temp12(4,i2_do,i1_do,kt)
           do i3_do=1,num_block_gr
              tr_grc_block(i2_do,i3_do,i1_do,kt)=tr_temp12(4+i3_do,i2_do,i1_do,kt)
           end do
        end do
     end do
  end do

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

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

  open(unit=16,file=file_tempout,position='append')
  write(16,*) '++++++++++++++++++++++++++++++++++++++++++++++++++++++++++++++'
  write(16,*) '++++++++++++  end  calculation:'
  write(16,*) '++++++++++++++++++++++++++++++++++++++++++++++++++++++++++++++'
  close(16)

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

995 format(i10,i10)
996 format(d28.19,d28.19)
997 format(d28.19,d28.19,i5,'    ** left  *******************************')
998 format(d28.19,d28.19,i5,'    ** right *******************************')
999 format(i10,i10,d28.19,d28.19)

  return
end subroutine cal_gf_se_c

subroutine cal_gf_se_read

  use condition_ini
  use hamiltonian_sgf
  use hamiltonian_c
  use hamiltonian_temp
  use gf_se_c
  use constant
  use mod_mpi
  use scf_negf

  implicit none
  include 'mpif.h'
  integer :: ic_spin
  integer :: iw_max_mpi
  integer :: iw_do,i1_do,i2_do,icou,i3_do,ier
  integer :: px,py,qx,qy,ispin
  integer :: m_mat_max_read,itemp
  real(8) :: temp1,temp2
  complex(8) :: w,w1

  real(8) :: st1,st2,stdel

  complex(8), allocatable :: tr_temp11(:,:,:,:),tr_temp12(:,:,:,:)
  integer :: i_temp

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

  call alo_mod_sftr(kt_tr,file_selfenergy)
  call alo_ham_temp_ham(m_mat_max_c,mat_max_ll,mat_max_rr)

  open(unit=16,file=file_tempout,position='append')
  write(16,*)
  write(16,*) '++++++++++++++++++++++++++++++++++++++++++++++++++++++++++++++'
  write(16,*) '++++++++++++ start calculation:'
  write(16,*) '++++++++++++++++++++++++++++++++++++++++++++++++++++++++++++++'
  close(16)

  call show_ksampling

  if( spin_switch_cc /= 2) then
     ic_spin=1
  else
     ic_spin=2
  end if

  do kt=1,ka_tr*kb_tr
     qx_tr=po_kt_tr(2,kt)
     qy_tr=po_kt_tr(3,kt)

     open(unit=16,file=file_tempout,position='append')
     write(16,*) '--------------------------------------------------------------'
     write(16,800) kt,qx_tr,qy_tr
800  format(' -------- K:   ',i5,2f13.8)
     write(16,*) '--------------------------------------------------------------'
     close(16)

     open(unit=60,file=file_sf_tr(kt,myrank+1))
     read(60,*) m_mat_max_read,iw_max_gs
     read(60,*)
     read(60,*)
     if( ham_model_ini == 'input' ) then
        call set_ham_temp_ham_c(qx_tr,qy_tr)
        if( myrank == 0 ) then
           if( switch_out_ham /= 'off' ) then
              call outham(kt,ic_spin,m_mat_max_c,hcc_t,scc_t)
           end if
        end if
     end if
     if( ham_model_ini == 'scf_accel' ) then
        call set_ham_temp_ham_l(qx_tr,qy_tr)
        call set_ham_temp_ham_r(qx_tr,qy_tr)
        call set_ham_scf_ham_c(qx_tr,qy_tr)
        if( myrank == 0 ) then
           if( switch_out_ham /= 'off' ) then
              call outham(kt,ic_spin,m_mat_max_c,h_cc_scf,s_cc_scf)
           end if
        end if
     end if

     itemp=m_mat_max_c-m_mat_max_read

     if( mod(iw_max_gs,nprocs) == 0 ) then
        iw_max_mpi=iw_max_gs
     else
        iw_max_mpi=iw_max_gs+nprocs-mod(iw_max_gs,nprocs)
     end if
     iw_max_mpi=(iw_max_mpi/nprocs)*nprocs
     do iw_do=1+myrank,iw_max_mpi,nprocs

        open(unit=16,file=file_tempout,position='append')
        write(16,*) '     ------- cal_gf_se_c:',iw_do
        close(16)

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

        do ispin=1,ic_spin

           if( iw_do > iw_max_gs ) then
              go to 100
           end if

           do px=1,kx_max_ll
              do py=1,ky_max_ll
                 do i2_do=1,m_mat_max_c
                    do i1_do=1,m_mat_max_c
                       se_l_mat_per(i1_do,i2_do,px,py)=dcmplx(0.d0,0.d0)
                    end do
                 end do
              end do
           end do

           do qx=1,kx_max_rr
              do qy=1,ky_max_rr
                 do i2_do=1,m_mat_max_c
                    do i1_do=1,m_mat_max_c
                       se_r_mat_per(i1_do,i2_do,qx,qy)=dcmplx(0.d0,0.d0)
                    end do
                 end do
              end do
           end do

100        continue

           if( iw_do <= iw_max_gs ) then
              do px=1,kx_max_ll
                 do py=1,ky_max_ll
                    read(60,996) temp1,temp2
                    w=dcmplx(temp1,temp2)
                    read(60,*) icou
                    do i3_do=1,icou
                       read(60,999) i1_do,i2_do,temp1,temp2
                       se_l_mat_per(i1_do,i2_do,px,py)=dcmplx(temp1,temp2)
                    end do
                 end do
              end do
              do qx=1,kx_max_rr
                 do qy=1,ky_max_rr
                    read(60,996) temp1,temp2
                    w1=dcmplx(temp1,temp2)
                    if( w /= w1 ) then
                       open(unit=16,file=file_tempout,position='append')
                       write(16,*) 'error--  w /= w1'
                       close(16)
                       stop
                    end if
                    read(60,*) icou
                    do i3_do=1,icou
                       read(60,999) i1_do,i2_do,temp1,temp2
                       se_r_mat_per(itemp+i1_do,itemp+i2_do,qx,qy)=dcmplx(temp1,temp2)
                    end do
                 end do
              end do
           end if

           open(unit=16,file=file_tempout,position='append')
           call myclock(st1)

           do px=1,kx_max_ll
              do py=1,ky_max_ll
                 do qx=1,kx_max_rr
                    do qy=1,ky_max_rr
                       call trans(w,iw_do,px,py,qx,qy,ispin,kt)
                    end do
                 end do
              end do
           end do
           call myclock(st2)
           stdel=st2-st1
           write(16,*) '           t=',stdel

           close(16)

        end do

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

     end do
  end do

  close(60)

  call dealo_mod_sftr
  call dealo_ham_temp_ham

  allocate(tr_temp11(4+num_block_gr,ic_spin,iw_max_gs,ka_tr*kb_tr)           &
       ,tr_temp12(4+num_block_gr,ic_spin,iw_max_gs,ka_tr*kb_tr)           &
       ,stat=ier)
  if( ier /= 0 ) then
     write(6,*) 'error allocate: alo_density_temp'
     stop
  end if

  do kt=1,ka_tr*kb_tr
     do i1_do=1,iw_max_gs
        do i2_do=1,ic_spin
           tr_temp11(1,i2_do,i1_do,kt)=tr_gr_l(i2_do,i1_do,kt)
           tr_temp11(2,i2_do,i1_do,kt)=tr_gr_r(i2_do,i1_do,kt)
           tr_temp11(3,i2_do,i1_do,kt)=tr_gr_c(i2_do,i1_do,kt)
           tr_temp11(4,i2_do,i1_do,kt)=tr_tr(i2_do,i1_do,kt)
           do i3_do=1,num_block_gr
              tr_temp11(4+i3_do,i2_do,i1_do,kt)=tr_grc_block(i2_do,i3_do,i1_do,kt)
           end do
        end do
     end do
  end do

  i_temp=(4+num_block_gr)*ic_spin*iw_max_gs*ka_tr*kb_tr
  call MPI_REDUCE(tr_temp11,tr_temp12,i_temp,MPI_DOUBLE_COMPLEX,MPI_SUM,0    &
       ,mpi_comm_world,ierr)

  do kt=1,ka_tr*kb_tr
     do i1_do=1,iw_max_gs
        do i2_do=1,ic_spin
           tr_gr_l(i2_do,i1_do,kt)=tr_temp12(1,i2_do,i1_do,kt)
           tr_gr_r(i2_do,i1_do,kt)=tr_temp12(2,i2_do,i1_do,kt)
           tr_gr_c(i2_do,i1_do,kt)=tr_temp12(3,i2_do,i1_do,kt)
           tr_tr(i2_do,i1_do,kt)=tr_temp12(4,i2_do,i1_do,kt)
           do i3_do=1,num_block_gr
              tr_grc_block(i2_do,i3_do,i1_do,kt)=tr_temp12(4+i3_do,i2_do,i1_do,kt)
           end do
        end do
     end do
  end do

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

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

  open(unit=16,file=file_tempout,position='append')
  write(16,*)
  write(16,*)
  write(16,*)
  write(16,*) '++++++++++++++++++++++++++++++++++++++++++++++++++++++++++++++'
  write(16,*) '++++++++++++  end  calculation:'
  write(16,*) '++++++++++++++++++++++++++++++++++++++++++++++++++++++++++++++'
  close(16)

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

996 format(d28.19,d28.19)
999 format(i10,i10,d28.19,d28.19)

  return
end subroutine cal_gf_se_read

subroutine outham(kt,ic_spin,m_mat_max_c,hcc,scc)

  implicit none
  integer, intent(in) :: kt,ic_spin,m_mat_max_c
  complex(8), intent(in) :: hcc(ic_spin,m_mat_max_c,m_mat_max_c)
  complex(8), intent(in) :: scc(m_mat_max_c,m_mat_max_c)

  character(50) :: nfile_shs
  integer :: i_hcc_1,i_hcc_2,i_scc,i_temp1,i_temp2
  integer :: ispin,icou,i1_do,i2_do

  call makefilename_outham(kt,nfile_shs)

  i_hcc_1=0
  i_hcc_2=0
  do ispin=1,ic_spin
     do i1_do=1,m_mat_max_c
        do i2_do=1,m_mat_max_c
           if( cdabs(hcc(ispin,i1_do,i2_do)) > 1.d-16 ) then
              if( ispin == 1 ) then
                 i_hcc_1=i_hcc_1+1
              else
                 i_hcc_2=i_hcc_2+1
              end if
           end if
        end do
     end do
  end do
  i_scc=0
  do i1_do=1,m_mat_max_c
     do i2_do=1,m_mat_max_c
        if( cdabs(scc(i1_do,i2_do)) > 1.d-16 ) then
           i_scc=i_scc+1
        end if
     end do
  end do

  i_temp1=0
  i_temp2=0
  open(unit=36,file=nfile_shs)

  write(36,*) i_temp1,m_mat_max_c,i_temp2
  write(36,*) ic_spin-1
  write(36,*) i_hcc_1,i_hcc_2,i_scc
  write(36,*)
  write(36,*)

  do ispin=1,ic_spin
     write(36,*)
     icou=0
     do i1_do=1,m_mat_max_c
        do i2_do=1,m_mat_max_c
           if( cdabs(hcc(ispin,i1_do,i2_do)) > 1.d-16 ) then
              icou=icou+1
              write(36,999) icou,i1_do,i2_do,hcc(ispin,i1_do,i2_do)
           end if
        end do
     end do
  end do

  write(36,*)
  icou=0
  do i1_do=1,m_mat_max_c
     do i2_do=1,m_mat_max_c
        if( cdabs(scc(i1_do,i2_do)) > 1.d-16 ) then
           icou=icou+1
           write(36,999) icou,i1_do,i2_do,scc(i1_do,i2_do)
        end if
     end do
  end do

999 format(i10,i10,i10,d28.19,d28.19)

  close(36)

  return
end subroutine outham

subroutine makefilename_outham(kt,nfile_strans)

  implicit none
  integer, intent(in) :: kt
  character(50), intent(out) :: nfile_strans

  character(1) :: character_temk(4),a(10)
  integer :: i1,i2,k1,i_temp1,i_temp2

  a(1)='0'
  a(2)='1'
  a(3)='2'
  a(4)='3'
  a(5)='4'
  a(6)='5'
  a(7)='6'
  a(8)='7'
  a(9)='8'
  a(10)='9'

  nfile_strans='hss'

  i_temp1=kt
  do i2=1,4
     i_temp2=i_temp1/(10**(4-i2))
     character_temk(i2)=a(i_temp2+1)
     i_temp1=i_temp1-(10**(4-i2))*i_temp2
  end do
  nfile_strans=trim(nfile_strans)                                         &
       //'_'//character_temk(1)//character_temk(2)                &
       //character_temk(3)//character_temk(4)//'.data'

  return
end subroutine makefilename_outham
