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

subroutine cal_vother(cutene_vt_ok)

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

  implicit none
  integer, intent(inout) :: cutene_vt_ok

  integer :: gn

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

  call cal_vother_accel

  if( MPI%root ) then

     if( ispin_pol_scf == 1 ) then
        open(unit=90,file='negf_vtot.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_tot_temp(gnj+i4,1),i4=1,6)
                 else
                    if( ii == 5 ) write(90,998) (v_tot_temp(gnj+i4,1),i4=1,ii)
                    if( ii == 4 ) write(90,997) (v_tot_temp(gnj+i4,1),i4=1,ii)
                    if( ii == 3 ) write(90,996) (v_tot_temp(gnj+i4,1),i4=1,ii)
                    if( ii == 2 ) write(90,995) (v_tot_temp(gnj+i4,1),i4=1,ii)
                    if( ii == 1 ) write(90,994) (v_tot_temp(gnj+i4,1),i4=1,ii)
                 end if
              end do
           end do
        end do
        close(90)
     end if
     if( ispin_pol_scf == 2 ) then
        open(unit=90,file='negf_vtot_up.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_tot_temp(gnj+i4,1),i4=1,6)
                 else
                    if( ii == 5 ) write(90,998) (v_tot_temp(gnj+i4,1),i4=1,ii)
                    if( ii == 4 ) write(90,997) (v_tot_temp(gnj+i4,1),i4=1,ii)
                    if( ii == 3 ) write(90,996) (v_tot_temp(gnj+i4,1),i4=1,ii)
                    if( ii == 2 ) write(90,995) (v_tot_temp(gnj+i4,1),i4=1,ii)
                    if( ii == 1 ) write(90,994) (v_tot_temp(gnj+i4,1),i4=1,ii)
                 end if
              end do
           end do
        end do
        close(90)
        open(unit=90,file='negf_vtot_do.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_tot_temp(gnj+i4,2),i4=1,6)
                 else
                    if( ii == 5 ) write(90,998) (v_tot_temp(gnj+i4,2),i4=1,ii)
                    if( ii == 4 ) write(90,997) (v_tot_temp(gnj+i4,2),i4=1,ii)
                    if( ii == 3 ) write(90,996) (v_tot_temp(gnj+i4,2),i4=1,ii)
                    if( ii == 2 ) write(90,995) (v_tot_temp(gnj+i4,2),i4=1,ii)
                    if( ii == 1 ) write(90,994) (v_tot_temp(gnj+i4,2),i4=1,ii)
                 end if
              end do
           end do
        end do
        close(90)
     end if
     if( ispin_pol_scf == 4 ) then
        open(unit=90,file='negf_vtot_up.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_tot_temp(gnj+i4,1),i4=1,6)
                 else
                    if( ii == 5 ) write(90,998) (v_tot_temp(gnj+i4,1),i4=1,ii)
                    if( ii == 4 ) write(90,997) (v_tot_temp(gnj+i4,1),i4=1,ii)
                    if( ii == 3 ) write(90,996) (v_tot_temp(gnj+i4,1),i4=1,ii)
                    if( ii == 2 ) write(90,995) (v_tot_temp(gnj+i4,1),i4=1,ii)
                    if( ii == 1 ) write(90,994) (v_tot_temp(gnj+i4,1),i4=1,ii)
                 end if
              end do
           end do
        end do
        close(90)
        open(unit=90,file='negf_vtot_sx.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_tot_temp(gnj+i4,2),i4=1,6)
                 else
                    if( ii == 5 ) write(90,998) (v_tot_temp(gnj+i4,2),i4=1,ii)
                    if( ii == 4 ) write(90,997) (v_tot_temp(gnj+i4,2),i4=1,ii)
                    if( ii == 3 ) write(90,996) (v_tot_temp(gnj+i4,2),i4=1,ii)
                    if( ii == 2 ) write(90,995) (v_tot_temp(gnj+i4,2),i4=1,ii)
                    if( ii == 1 ) write(90,994) (v_tot_temp(gnj+i4,2),i4=1,ii)
                 end if
              end do
           end do
        end do
        close(90)
        open(unit=90,file='negf_vtot_sy.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_tot_temp(gnj+i4,3),i4=1,6)
                 else
                    if( ii == 5 ) write(90,998) (v_tot_temp(gnj+i4,3),i4=1,ii)
                    if( ii == 4 ) write(90,997) (v_tot_temp(gnj+i4,3),i4=1,ii)
                    if( ii == 3 ) write(90,996) (v_tot_temp(gnj+i4,3),i4=1,ii)
                    if( ii == 2 ) write(90,995) (v_tot_temp(gnj+i4,3),i4=1,ii)
                    if( ii == 1 ) write(90,994) (v_tot_temp(gnj+i4,3),i4=1,ii)
                 end if
              end do
           end do
        end do
        close(90)
        open(unit=90,file='negf_vtot_do.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_tot_temp(gnj+i4,4),i4=1,6)
                 else
                    if( ii == 5 ) write(90,998) (v_tot_temp(gnj+i4,4),i4=1,ii)
                    if( ii == 4 ) write(90,997) (v_tot_temp(gnj+i4,4),i4=1,ii)
                    if( ii == 3 ) write(90,996) (v_tot_temp(gnj+i4,4),i4=1,ii)
                    if( ii == 2 ) write(90,995) (v_tot_temp(gnj+i4,4),i4=1,ii)
                    if( ii == 1 ) write(90,994) (v_tot_temp(gnj+i4,4),i4=1,ii)
                 end if
              end do
           end do
        end do
        close(90)
     end if
  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_vother

subroutine cal_vother_accel
  use scf_negf

  implicit none
  real(8), allocatable :: vexc(:,:,:,:)
  real(8), allocatable :: rho1(:,:,:,:),rho2(:,:,:)
  complex(8), allocatable :: rho1ls(:,:,:,:)

  real(8) :: eexc,const
  integer :: i1,i2,i3,ispin,gn,ier

  if( ispin_pol_scf < 4 ) then
     allocate(vexc(ispin_pol_scf,0:n_a-1,0:n_b-1,0:n_c-1)                     &
          ,rho1(ispin_pol_scf,0:n_a-1,0:n_b-1,0:n_c-1)                     &
          ,rho2(0:n_a-1,0:n_b-1,0:n_c-1)                                   &
          ,stat=ier)
     if( ier /= 0 ) then
        write(6,*) 'error allocate: cal_vother_accel'
        stop
     end if

     const=3.0d0-dfloat(ispin_pol_scf)
     do i3=0,n_c-1
        do i2=0,n_b-1
           do i1=0,n_a-1
              gn=i1*n_b*n_c+i2*n_c+i3+1
              do ispin=1,ispin_pol_scf
                 rho1(ispin,i1,i2,i3)=rho(gn,ispin)*const
              end do
              rho2(i1,i2,i3)=rhopcc(gn)*2.d0
           end do
        end do
     end do

     call Exchange__calcPotential(eexc,vexc,rho1,rho2)

     do ispin=1,ispin_pol_scf
        do i3=l_cell_l_bound+1,r_cell_l_bound-1
           do i2=0,n_b-1
              do i1=0,n_a-1
                 gn=i1*n_b*n_c+i2*n_c+i3+1
                 v_tot_temp(gn,ispin)=v_hartree(gn)+vexc(ispin,i1,i2,i3)+v_ext(gn)
              end do
           end do
        end do
     end do

     deallocate(vexc,rho1,rho2,stat=ier)
     if( ier /= 0 ) then
        write(6,*) 'error deallocate: cal_vother_accel'
        stop
     end if
  else
     allocate(vexc(ispin_pol_scf,0:n_a-1,0:n_b-1,0:n_c-1)                     &
          ,rho1ls(ispin_pol_scf,0:n_a-1,0:n_b-1,0:n_c-1)                   &
          ,rho2(0:n_a-1,0:n_b-1,0:n_c-1)                                   &
          ,stat=ier)
     if( ier /= 0 ) then
        write(6,*) 'error allocate: cal_vother_accel'
        stop
     end if

     do ispin=1,ispin_pol_scf
        do i3=0,n_c-1
           do i2=0,n_b-1
              do i1=0,n_a-1
                 gn=i1*n_b*n_c+i2*n_c+i3+1
                 rho1ls(ispin,i1,i2,i3)=rhols(gn,ispin)
                 rho2(i1,i2,i3)=rhopcc(gn)*2.d0
              end do
           end do
        end do
     end do

     call ExchangeLS__calcPotential(eexc,vexc,rho1ls,rho2)

     do ispin=1,ispin_pol_scf
        do i3=l_cell_l_bound+1,r_cell_l_bound-1
           do i2=0,n_b-1
              do i1=0,n_a-1
                 gn=i1*n_b*n_c+i2*n_c+i3+1
                 if( ispin == 1 .or. ispin == 4 ) then
                    v_tot_temp(gn,ispin)                                           &
                         =v_hartree(gn)+vexc(ispin,i1,i2,i3)+v_ext(gn)
                 else
                    v_tot_temp(gn,ispin)=vexc(ispin,i1,i2,i3)
                 end if
              end do
           end do
        end do
     end do

     deallocate(vexc,rho1ls,rho2,stat=ier)
     if( ier /= 0 ) then
        write(6,*) 'error deallocate: cal_vother_accel'
        stop
     end if
  end if

  return
end subroutine cal_vother_accel
