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

subroutine gen_outf
  use ac_misc_module
  use mod_mpi

  implicit none

  Param%Option%file_ac_tempout=file_tempout

  return
end subroutine gen_outf

subroutine Param__read__ASCOT(fname)
  use ac_misc_module
  use scf_negf

  implicit none

  character(len=*) fname

  character(16) :: name
  character(64) :: mode,mode2
  character(256) :: fname_pao,fname_vps
  character(256) :: dummy

  integer :: i,i_c
  real(8) :: polarization_t
  logical :: optimize

  real(8) :: R(3)
  type(Element_type), pointer :: elem

  Param%Option%na = .true.
  optimize = .false.

  open(unit=90,file=fname)

  read(90,*) Param%name

  read(90,*)
  read(90,*) Param%Data%element_type,Param%SCF%exc_type,i_c
  read(90,*) Param%SCF%Te,Param%SCF%Ecutoff

  if( i_c == 0 ) then
     Param%Option%spin_orbit = .false.
     Param%Option%spin_polar = .false.
     ispin_pol_scf=1
     Param%Option%nspin=1
  else
     if( i_c == 1 ) then
        Param%Option%spin_orbit = .false.
        Param%Option%spin_polar = .true.
        ispin_pol_scf=2
        Param%Option%nspin=2
     else
        Param%Option%spin_orbit = .true.
        Param%Option%spin_polar = .true.
        ispin_pol_scf=4
        Param%Option%nspin=4
     end if
  end if

  read(90,*)
  read(90,*) Param%SCF%Nka,Param%SCF%Nkb,Param%SCF%Nkc

  read(90,*)
  read(90,*) Param%Integral1D%Nk,Param%Integral1D%Nr,Param%Integral1D%Ecutoff

  read(90,*)
  read(90,'(a)') dummy
  read(dummy,*,end=100) Param%Data%nelem,mode2
  if( mode2 == 'on' ) then
     Param%Option%projection=.true.
  else
     Param%Option%projection=.false.
  end if
100 continue
  allocate( Param%Data%velem(Param%Data%nelem))
  allocate( Param%Data%velem_file(Param%Data%nelem,5))
  do i=1,Param%Data%nelem
     if( Param%Option%projection ) then
        read(90,*) name,fname_pao,mode,fname_vps,mode2
     else
        read(90,*) name,fname_pao,mode,fname_vps
        mode2=""
     end if

     Param%Data%velem_file(i,1)=name
     Param%Data%velem_file(i,2)=fname_pao
     Param%Data%velem_file(i,3)=mode
     Param%Data%velem_file(i,4)=fname_vps
     Param%Data%velem_file(i,5)=mode2

     select case(Param%Data%element_type)
     case('ciao')
        call Element__readPAO_ciao( Param%Data%velem(i), name, fname_pao, mode, mode2 )
        call Element__readVPS_ciao( Param%Data%velem(i), name, fname_vps )
     case('ciao_ls')
        call Element__readPAO_ciao  ( Param%Data%velem(i), name, fname_pao, mode, mode2 )
        call Element__readVPS_ciao_ls( Param%Data%velem(i), name, fname_vps )
     end select
  end do

  read(90,*)
  read(90,*) Param%Cell%La(:)
  read(90,*) Param%Cell%Lb(:)
  read(90,*) Param%Cell%Lc(:)

  read(90,*)
  read(90,*) Param%Data%natom,Param%Data%natom_left,Param%Data%natom_right
  allocate( Param%Data%vatom(Param%Data%natom) )
  do i=1,Param%Data%natom
     read(90,*) dummy,name,R(:),polarization_t
     if( dummy == dummy ) then
     endif
     elem => Param__Data__getElement( name )
     call Atom__set( Param%Data%vatom(i),name,R                               &
          ,elem%vpao(1)%Rc,-elem%Vloc%Q,elem%atomic_number                 &
          ,polarization_t,optimize )
  end do

  close(90)

  num_atom_scf=Param%Data%natom
  nelem_num=Param%Data%nelem

  numl_atom_scf=Param%Data%natom_left
  numr_atom_scf=Param%Data%natom_right
  numc_atom_scf=num_atom_scf-numr_atom_scf-numl_atom_scf
  xc_type=1

  Param%Option%fname_matrices_in=file_parameter_hc_scf

  if( file_parameter_out_vh0 /= '' ) then
     Param%Option%fname_matrices=file_parameter_out_vh0
  else
     Param%Option%fname_matrices=''
  end if

  return
end subroutine Param__read__ASCOT

subroutine Param__show__ASCOT
  use ac_misc_module

  implicit none

  open(unit=16,file=Param%Option%file_ac_tempout,position='append')
  write(16,*)
  write(16,*)
  write(16,*) '********************** **************** **********************'
  write(16,*) '*                    condition  !  dft  !                    *'
  write(16,*) '********************** **************** **********************'

  call Param__SCF__show__ASCOT
  call Param__Data__show
  close(16)

  return
end subroutine Param__show__ASCOT

subroutine Param__SCF__show__ASCOT
  use ac_misc_module

  implicit none
  character(10) :: chara_temp

  write(16,*)

  write(16,921) Param%SCF%exc_type
921 format('                        Vxc type: ',a)
  write(16,922) Param%SCF%Te*AU_TO_KELVIN
922 format('         electric temperature[K]: ',f10.4)
  write(16,923) Param%SCF%Ecutoff
923 format('  real space energy cutoff[a.u.]: ',f10.4)
  if( Param%Option%spin_polar ) then
     chara_temp='on'
  else
     chara_temp='off'
  end if
  write(16,924) chara_temp
924 format('               spin polarization: ',a)

  if( Param%Option%projection ) then
     chara_temp='on'
  else
     chara_temp='off'
  end if
  write(16,929) chara_temp
929 format('                 Vloc projection: ',a)

  if( Param%Option%cluster ) then
     chara_temp='on'
  else
     chara_temp='off'
  end if
  write(16,928) chara_temp
928 format('                         cluster: ',a)

  write(16,*)
  write(16,*) '=========== one-dimensional integration calculation =========='
  write(16,*)
  write(16,918) Param%Integral1D%Nr
918 format('          real space grid points: ',i10)
  write(16,919) Param%Integral1D%Nr
919 format('          reciprocal grid points: ',i10)
  write(16,920) Param%Integral1D%Ecutoff
920 format('             energy cutoff [a.u]: ',e10.5)

  return
end subroutine Param__SCF__show__ASCOT

subroutine MPI__Initialize__ASCOT
  use ac_mpi_module
  use mod_mpi

  implicit none

  MPI%rank=myrank
  MPI%size=nprocs

  if( MPI%rank == 0 ) then
     MPI%root = .true.
  else
     MPI%root = .false.
  end if

  !!      call MPI_Type_Contiguous(3,MPI_DOUBLE_PRECISION,MPI%DOUBLE_POSITION,MPI%info)
  !!      call MPI_Type_Commit(MPI%DOUBLE_POSITION,MPI%info)
  !!      call MPI_Op_create(MPI__Sum_Position,.true.,MPI%SUM_POSITION,MPI%info)

  call SL_Init( MPI%SL_ID, 1, MPI%size )

  return
end subroutine MPI__Initialize__ASCOT

subroutine Param__setup__ASCOT
  use ac_misc_module
  use scf_negf

  implicit none
  integer :: a,l

  n_a=Param%Cell%Na
  n_b=Param%Cell%Nb
  n_c=Param%Cell%Nc
  num_cell_l=n_a*n_b*n_c

  param_cell_nl=Param%Cell%nL
  call alo_scf_negf_parameter_11
  do l=1,param_cell_nl
     param_cell_vl(l,:)=Param%Cell%vL(:,l-1)
  end do

  cell_labc(1,:)=Param%Cell%La(:)
  cell_labc(2,:)=Param%Cell%Lb(:)
  cell_labc(3,:)=Param%Cell%Lc(:)

  cell_dkabc(1,:)=Param%Cell%dKa(:)
  cell_dkabc(2,:)=Param%Cell%dKb(:)
  cell_dkabc(3,:)=Param%Cell%dKc(:)

  cell_lo(:)=Param%Cell%Lo(:)

  tot_ele_num=0.d0
  do a=1,Param%Data%natom
     atom_name(a)=Param%Data%vatom(a)%name
     atom_name_num(a)=Param%Data%vatom(a)%number
     vatom_q(a)=Param%Data%vatom(a)%Q
     atom_ro(a,:)=Param%Data%vatom(a)%Ro(:)
     atom_rcut(a)=Param%Data%vatom(a)%Rc
     tot_ele_num=tot_ele_num+Param%Data%vatom(a)%Q
  end do

  if( iter_conv == 11 ) then
     Param%SCF%mix_target='density_matrix'
     Param%SCF%mix_type='Simple'
     Param%SCF%mix_history=1
  end if
  if( iter_conv == 12 ) then
     Param%SCF%mix_target='density_matrix'
     Param%SCF%mix_type='Pulay'
     Param%SCF%mix_history=negf_mix_history
     Param%SCF%mix_start=negf_mix_start
  end if
  if( iter_conv == 13 ) then
     Param%SCF%mix_target='density_matrix'
     Param%SCF%mix_type='Anderson'
     Param%SCF%mix_history=3
  end if
  if( iter_conv == 21 ) then
     Param%SCF%mix_target='density'
     Param%SCF%mix_type='Simple'
     Param%SCF%mix_history=1
  end if
  if( iter_conv == 22 ) then
     Param%SCF%mix_target='density'
     Param%SCF%mix_type='Pulay'
     Param%SCF%mix_history=negf_mix_history
     Param%SCF%mix_start=negf_mix_start
  end if
  if( iter_conv == 23 ) then
     Param%SCF%mix_target='density'
     Param%SCF%mix_type='Anderson'
     Param%SCF%mix_history=3
  end if
  Param%SCF%mix_weight=mixing_dm
  Param%SCF%mix_weight_s=mixing_dm_s

  if( force_calc_onoff == 'on' ) then
     Param%Option%optimize=.true.
  else
     Param%Option%optimize=.false.
  end if

  if( Param%Option%projection ) then
     param_option_projection='on'
  else
     param_option_projection='off'
  end if

  return
end subroutine Param__setup__ASCOT

subroutine MPI__setup_ASCOT
  use ac_mpi_module

  implicit none

  call MPI__setup

  return
end subroutine MPI__setup_ASCOT

subroutine Base__setup__ASCOT
  use ac_misc_module
  use scf_negf

  implicit none
  integer :: a

  do a=1,Param%Data%natom
     iatom_orb_num(a)=Base%vnpao(a)
  end do
  base_npao=Base%npao

  return
end subroutine Base__setup__ASCOT

subroutine Density__setup__ASCOT
  use ac_misc_module
  use scf_negf

  implicit none
  integer :: ia,ib,ic

  if( Param%Option%na ) then
     do ia=1,Param%Cell%Na
        do ib=1,Param%Cell%Nb
           do ic=1,Param%Cell%Nc
              rhoval((ia-1)*n_b*n_c+(ib-1)*n_c+(ic-1)+1)=Density%rhoval(ia,ib,ic)
           end do
        end do
     end do
  else
     do ia=1,Param%Cell%Na
        do ib=1,Param%Cell%Nb
           do ic=1,Param%Cell%Nc
              rhoval((ia-1)*n_b*n_c+(ib-1)*n_c+(ic-1)+1)=0.d0
           end do
        end do
     end do
  end if

  if( Param%Option%pcc ) then
     do ia=1,Param%Cell%Na
        do ib=1,Param%Cell%Nb
           do ic=1,Param%Cell%Nc
              rhopcc((ia-1)*n_b*n_c+(ib-1)*n_c+(ic-1)+1)=Density%rhopcc(ia,ib,ic)*.5d0
           end do
        end do
     end do
  else
     do ia=1,Param%Cell%Na
        do ib=1,Param%Cell%Nb
           do ic=1,Param%Cell%Nc
              rhopcc((ia-1)*n_b*n_c+(ib-1)*n_c+(ic-1)+1)=0.d0
           end do
        end do
     end do
  end if

  return
end subroutine Density__setup__ASCOT

subroutine Potential__setup__ASCOT
  use ac_misc_module
  use scf_negf

  implicit none
  integer :: ia,ib,ic

  if( .not. Param%Option%projection ) then
     do ia=1,Param%Cell%Na
        do ib=1,Param%Cell%Nb
           do ic=1,Param%Cell%Nc
              v_ext((ia-1)*n_b*n_c+(ib-1)*n_c+(ic-1)+1)=Potential%Vext(ia,ib,ic)
           end do
        end do
     end do
  else
     do ia=1,Param%Cell%Na
        do ib=1,Param%Cell%Nb
           do ic=1,Param%Cell%Nc
              v_ext((ia-1)*n_b*n_c+(ib-1)*n_c+(ic-1)+1)=0.d0
           end do
        end do
     end do
  end if

  return
end subroutine Potential__setup__ASCOT

subroutine Hamiltonian__setup__ASCOT                                               &
     (num_atom_scf,param_cell_nl,hv_atom_matrix,n_v_atom_matrix,n_v_nim_max)
  use ac_misc_module
  use ac_mpi_module

  implicit none
  integer, intent(in) :: num_atom_scf,param_cell_nl
  integer, intent(inout) :: n_v_atom_matrix,n_v_nim_max
  integer, intent(inout) :: hv_atom_matrix(num_atom_scf,num_atom_scf,0:param_cell_nl-1)

  integer       :: l, a, i, b, j
  integer       :: li, c, k
  logical       :: overlap

  n_v_atom_matrix=0
  n_v_nim_max=0

  do l=0, Param%Cell%nL-1
     do a=MPI%isatom, MPI%ieatom
        i=Base%vipao(a)
        do b=1, Param%Data%natom
           j=Base%vipao(b)
           if( associated(Hamiltonian%vAtomMatrix(b,a,l)%Ptr) ) then
              n_v_atom_matrix=n_v_atom_matrix+1
              hv_atom_matrix(b,a,l)=n_v_atom_matrix
           else
              hv_atom_matrix(b,a,l)=0
           end if
           if( n_v_nim_max < Base%vipao(a)-1 ) then
              n_v_nim_max=Base%vipao(a)-1
           end if
        end do
     end do
  end do

  return
end subroutine Hamiltonian__setup__ASCOT

subroutine Hamiltonian__loadAM_ASCOT
  use ac_misc_module
  use ac_mpi_module

  implicit none
  integer :: l
  integer :: a,i1
  integer :: b,j1
  integer :: iunit
  logical :: ex

  integer :: l_t,a_t,b_t
  integer :: i2,i_temp1,i_temp2,i_temp3,i_temp4,i_temp5
  character(1) :: character_temp(4),a_c(10)
  character(55) :: fname

  real(8) :: temp1,temp2,temp3,temp4

  real(8) :: t_L(3)

  open(unit=16,file=Param%Option%file_ac_tempout,position='append')
  write(16,*) '++++++++++++++++++++++++++++++++++++++++++++++++++++++++++++++'
  write(16,*) '+++++++++++        loading hamiltonian matrices'
  write(16,999) trim(Param%Option%fname_matrices_in)
  write(16,*) '++++++++++++++++++++++++++++++++++++++++++++++++++++++++++++++'
  write(16,*)
999 format(' +++++++++++        read file:: ',a)
  close(16)

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

  do a=MPI%isatom,MPI%ieatom

     i_temp1=a
     do i2=1,4
        i_temp2=i_temp1/(10**(4-i2))
        character_temp(i2)=a_c(i_temp2+1)
        i_temp1=i_temp1-(10**(4-i2))*i_temp2
     end do
     fname=trim(Param%Option%fname_matrices_in)                                 &
          //'_'//character_temp(1)//character_temp(2)                      &
          //character_temp(3)//character_temp(4)
     inquire(file=fname,exist=ex)
     if( .not. ex ) then
        open(unit=16,file=Param%Option%file_ac_tempout,position='append')
        write(16,'(a,a)') '      ++++++ Error!: can not open file ',fname
        close(16)
        stop
     end if

     iunit=1
     open(iunit,file=fname)
     read(iunit,*) i_temp1,i_temp2,i_temp3,i_temp4,i_temp5
     read(iunit,*)
     read(iunit,*)
     read(iunit,*)

     if(i_temp5/=Param%Option%nspin-1) then
        open(unit=16,file=Param%Option%file_ac_tempout,position='append')
        write(16,'(a,a)') '      ++++++ Error!: spin ', fname
        close(16)
        stop
     end if

     do
        read(iunit,*,end=1000)
        read(iunit,*) a_t,l,b_t,i_temp1,i_temp2,i_temp3
        read(iunit,*) t_L
        b = b_t +1

        if(a/=a_t+1) then
           open(unit=16,file=Param%Option%file_ac_tempout,position='append')
           write(16,'(a,a)') '      ++++++ Error!: a ',fname,a,a_t
           close(16)
           stop
        end if
        if( Param%Data%natom < b ) then
           open(unit=16,file=Param%Option%file_ac_tempout,position='append')
           write(16,'(a,a)') '      ++++++ Error!: b ', fname
           close(16)
           stop
        end if
        if(Base%vnpao(a)/=i_temp2) then
           open(unit=16,file=Param%Option%file_ac_tempout,position='append')
           write(16,'(a,a)') '      ++++++ Error!: Base%vnpao(a) ', fname
           close(16)
           stop
        end if
        if(Base%vnpao(b)/=i_temp3) then
           open(unit=16,file=Param%Option%file_ac_tempout,position='append')
           write(16,'(a,a)') '      ++++++ Error!: Base%vnpao(b) ', fname
           close(16)
           stop
        end if

        if( i_temp1 /= 1 ) then
           l=Param%Cell%nL
           do l_t=0, Param%Cell%nL-1
              if( sqrt(dot_product(Param%Cell%vL(:,l_t)-t_L,Param%Cell%vL(:,l_t)-t_L)) < 1.d-8 ) then
                 l=l_t
                 exit
              end if
           end do
           if( Param%Cell%nL-1 < l ) then
              do i1=1, Base%vnpao(a)
                 do j1=1, Base%vnpao(b)
                    if( Param%Option%nspin-1 < 3 ) then
                       read(iunit,*)
                    else
                       read(iunit,*)
                       read(iunit,*)
                       read(iunit,*)
                       read(iunit,*)
                       read(iunit,*)
                       read(iunit,*)
                       read(iunit,*)
                    end if
                 end do
              end do
              cycle
           end if
           if( associated(Hamiltonian%vAtomMatrix(b,a,l)%Ptr) ) then
              do i1=1,Base%vnpao(a)
                 do j1=1,Base%vnpao(b)
                    if( i1 >= MPI%ispao(a) .and. i1 <= MPI%iepao(a) ) then
                       if( Param%Option%nspin-1 == 0 ) then
                          read(iunit,*)                                           &
                               Hamiltonian%vAtomMatrix(b,a,l)%Ptr%S(j1,i1),        &
                               Hamiltonian%vAtomMatrix(b,a,l)%Ptr%H0(j1,i1,1),     &
                               Hamiltonian%vAtomMatrix(b,a,l)%Ptr%H(j1,i1,1),      &
                               Hamiltonian%vAtomMatrix(b,a,l)%Ptr%CDM(j1,i1,1)
                       else
                          if( Param%Option%nspin-1 == 1 ) then
                             read(iunit,*)                                         &
                                  Hamiltonian%vAtomMatrix(b,a,l)%Ptr%S(j1,i1),        &
                                  Hamiltonian%vAtomMatrix(b,a,l)%Ptr%H0(j1,i1,1),     &
                                  Hamiltonian%vAtomMatrix(b,a,l)%Ptr%H(j1,i1,1),      &
                                  Hamiltonian%vAtomMatrix(b,a,l)%Ptr%H(j1,i1,2),      &
                                  Hamiltonian%vAtomMatrix(b,a,l)%Ptr%CDM(j1,i1,1),    &
                                  Hamiltonian%vAtomMatrix(b,a,l)%Ptr%CDM(j1,i1,2)
                             Hamiltonian%vAtomMatrix(b,a,l)%Ptr%H0(j1,i1,2)        &
                                  =Hamiltonian%vAtomMatrix(b,a,l)%Ptr%H0(j1,i1,1)
                          else
                             read(iunit,*) Hamiltonian%vAtomMatrix(b,a,l)%Ptr%S(j1,i1)
                             read(iunit,*) temp1,temp2,temp3,temp4
                             Hamiltonian%vAtomMatrix(b,a,l)%Ptr%H0LS(j1,i1,1) &
                                  =dcmplx(temp1,temp2)
                             Hamiltonian%vAtomMatrix(b,a,l)%Ptr%H0LS(j1,i1,2) &
                                  =dcmplx(temp3,temp4)
                             read(iunit,*) temp1,temp2,temp3,temp4
                             Hamiltonian%vAtomMatrix(b,a,l)%Ptr%H0LS(j1,i1,3) &
                                  =dcmplx(temp1,temp2)
                             Hamiltonian%vAtomMatrix(b,a,l)%Ptr%H0LS(j1,i1,4) &
                                  =dcmplx(temp3,temp4)
                             read(iunit,*) temp1,temp2,temp3,temp4
                             Hamiltonian%vAtomMatrix(b,a,l)%Ptr%HLS(j1,i1,1)  &
                                  =dcmplx(temp1,temp2)
                             Hamiltonian%vAtomMatrix(b,a,l)%Ptr%HLS(j1,i1,2)  &
                                  =dcmplx(temp3,temp4)
                             read(iunit,*) temp1,temp2,temp3,temp4
                             Hamiltonian%vAtomMatrix(b,a,l)%Ptr%HLS(j1,i1,3)  &
                                  =dcmplx(temp1,temp2)
                             Hamiltonian%vAtomMatrix(b,a,l)%Ptr%HLS(j1,i1,4)  &
                                  =dcmplx(temp3,temp4)
                             read(iunit,*) temp1,temp2,temp3,temp4
                             Hamiltonian%vAtomMatrix(b,a,l)%Ptr%CDMLS(j1,i1,1) &
                                  =dcmplx(temp1,temp2)
                             Hamiltonian%vAtomMatrix(b,a,l)%Ptr%CDMLS(j1,i1,2) &
                                  =dcmplx(temp3,temp4)
                             read(iunit,*) temp1,temp2,temp3,temp4
                             Hamiltonian%vAtomMatrix(b,a,l)%Ptr%CDMLS(j1,i1,3) &
                                  =dcmplx(temp1,temp2)
                             Hamiltonian%vAtomMatrix(b,a,l)%Ptr%CDMLS(j1,i1,4) &
                                  =dcmplx(temp3,temp4)
                          end if
                       end if
                    else
                       if( Param%Option%nspin-1 < 3 ) then
                          read(iunit,*)
                       else
                          read(iunit,*)
                          read(iunit,*)
                          read(iunit,*)
                          read(iunit,*)
                          read(iunit,*)
                          read(iunit,*)
                          read(iunit,*)
                       end if
                    end if
                 end do
              end do
           else
              do i1=1, Base%vnpao(a)
                 do j1=1, Base%vnpao(b)
                    if( Param%Option%nspin-1 < 3 ) then
                       read(iunit,*)
                    else
                       read(iunit,*)
                       read(iunit,*)
                       read(iunit,*)
                       read(iunit,*)
                       read(iunit,*)
                       read(iunit,*)
                       read(iunit,*)
                    end if
                 end do
              end do
           end if
        end if

     end do

1000 continue

     close(iunit)
  end do

  return
end subroutine Hamiltonian__loadAM_ASCOT

subroutine Hamiltonian__saveAM_ASCOT
  use ac_misc_module
  use ac_mpi_module

  implicit none
  type(Element_type), pointer :: elem

  integer :: l,a,i1,b,j1
  integer :: iunit

  integer :: i2,i_temp1,i_temp2
  character(1) :: character_temp(4),a_c(10)
  character(55) :: fname

  integer, allocatable :: i_orb(:)
  integer :: i_c,n
  integer :: ispin,i_cyc
  integer :: mat_max_ll,mat_max_rr,mat_max_cc,ele_num_ll,ele_num_rr

  if( .not. Param%Option%spin_polar ) then
     ispin=0
  else
     ispin=1
  end if

  allocate(i_orb(0:Param%Data%natom))

  i_orb(0)=0
  do a=1,Param%Data%natom
     elem => Param__Data__getElement(Param%Data%vatom(a)%name)
     i_c=0
     do n=1,elem%npao
        i_c=i_c+2*(elem%vpao(n)%l)+1
     end do
     i_orb(a)=i_orb(a-1)+i_c
  end do

  if( Param%Option%nspin < 4 ) then
     mat_max_cc=Base%npao
     mat_max_ll=i_orb(Param%Data%natom_left)
     mat_max_rr=Base%npao-i_orb(Param%Data%natom-Param%Data%natom_right)
  else
     mat_max_cc=Base%npao*2
     mat_max_ll=i_orb(Param%Data%natom_left)*2
     mat_max_rr=(Base%npao-i_orb(Param%Data%natom-Param%Data%natom_right))*2
  end if

  ele_num_ll=0
  do a=1,Param%Data%natom_left
     elem => Param__Data__getElement(Param%Data%vatom(a)%name)
     ele_num_ll=ele_num_ll+Param%Data%vatom(a)%Q
  end do
  ele_num_rr=0
  do a=Param%Data%natom-Param%Data%natom_right+1,Param%Data%natom
     elem => Param__Data__getElement(Param%Data%vatom(a)%name)
     ele_num_rr=ele_num_rr+Param%Data%vatom(a)%Q
  end do

  deallocate(i_orb)

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

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

  do a=1, Param%Data%natom

     i_temp1=a
     do i2=1,4
        i_temp2=i_temp1/(10**(4-i2))
        character_temp(i2)=a_c(i_temp2+1)
        i_temp1=i_temp1-(10**(4-i2))*i_temp2
     end do
     fname=trim(Param%Option%fname_matrices)                                    &
          //'_'//character_temp(1)//character_temp(2)                      &
          //character_temp(3)//character_temp(4)
     iunit=1
     if( MPI%root ) then
        open(iunit,file=fname)
        write(iunit,886)                                                       &
             Param%Data%natom,Param%Data%natom_left,Param%Data%natom_right, &
             Param%Cell%nL,Param%Option%nspin-1,                            &
             mat_max_ll,mat_max_cc,mat_max_rr,ele_num_ll,ele_num_rr
        write(iunit,*) Param%Cell%La(:)
        write(iunit,*) Param%Cell%Lb(:)
        write(iunit,*) Param%Cell%Lc(:)
        close(iunit)
886     format(10i6,'      = natom, nL, mat_max')
     end if

     do l=0, Param%Cell%nL-1
        do b=1, Param%Data%natom

           do i_cyc=0,MPI%size-1
              if( i_cyc == MPI%rank ) then
                 if( a >= MPI%isatom .and. a <= MPI%ieatom ) then

                    if( .not. associated(Hamiltonian%vAtomMatrix(b,a,l)%Ptr) ) then
                       if( MPI%ispao(a) == 0 ) then
                          open(iunit,file=fname,position='append')
                          i_temp1=1
                          write(iunit,*)
                          write(iunit,887) a-1,l,b-1,i_temp1,Base%vnpao(a),Base%vnpao(b)
                          write(iunit,885) Param%Cell%vL(:,l)
                          close(iunit)
                       end if
                       go to 100
                    else
                       if( MPI%ispao(a) == 1 ) then
                          open(iunit,file=fname,position='append')
                          i_temp1=1
                          write(iunit,*)
                          write(iunit,887) a-1,l,b-1,i_temp1,Base%vnpao(a),Base%vnpao(b)
                          write(iunit,885) Param%Cell%vL(:,l)
                          close(iunit)
                       end if
                    end if
887                 format(6i6,'      *****************')
885                 format(3d25.16,'      =vL.x, vL.y, vL. z')

                    do i1=MPI%ispao(a), MPI%iepao(a)

                       open(iunit,file=fname,position='append')
                       do j1=1, Base%vnpao(b)
                          if( Param%Option%nspin-1 == 0 ) then
                             write(iunit,889) &
                                  Hamiltonian%vAtomMatrix(b,a,l)%Ptr%S  (j1,i1),      &
                                  Hamiltonian%vAtomMatrix(b,a,l)%Ptr%H0 (j1,i1,1),    &
                                  Hamiltonian%vAtomMatrix(b,a,l)%Ptr%H  (j1,i1,1),    &
                                  Hamiltonian%vAtomMatrix(b,a,l)%Ptr%CDM(j1,i1,1)
889                          format(4d25.16)
                          else
                             if( Param%Option%nspin-1 == 1 ) then
                                write(iunit,888) &
                                     Hamiltonian%vAtomMatrix(b,a,l)%Ptr%S(j1,i1),        &
                                     Hamiltonian%vAtomMatrix(b,a,l)%Ptr%H0(j1,i1,1),     &
                                     Hamiltonian%vAtomMatrix(b,a,l)%Ptr%H(j1,i1,1),      &
                                     Hamiltonian%vAtomMatrix(b,a,l)%Ptr%H(j1,i1,2),      &
                                     Hamiltonian%vAtomMatrix(b,a,l)%Ptr%CDM(j1,i1,1),    &
                                     Hamiltonian%vAtomMatrix(b,a,l)%Ptr%CDM(j1,i1,2)
888                             format(6d25.16)
                             else
                                write(iunit,876) &
                                     Hamiltonian%vAtomMatrix(b,a,l)%Ptr%S(j1,i1)
                                write(iunit,877) &
                                     Hamiltonian%vAtomMatrix(b,a,l)%Ptr%H0LS(j1,i1,1), &
                                     Hamiltonian%vAtomMatrix(b,a,l)%Ptr%H0LS(j1,i1,2)
                                write(iunit,877) &
                                     Hamiltonian%vAtomMatrix(b,a,l)%Ptr%H0LS(j1,i1,3), &
                                     Hamiltonian%vAtomMatrix(b,a,l)%Ptr%H0LS(j1,i1,4)
                                write(iunit,877) &
                                     Hamiltonian%vAtomMatrix(b,a,l)%Ptr%HLS(j1,i1,1),  &
                                     Hamiltonian%vAtomMatrix(b,a,l)%Ptr%HLS(j1,i1,2)
                                write(iunit,877) &
                                     Hamiltonian%vAtomMatrix(b,a,l)%Ptr%HLS(j1,i1,3),  &
                                     Hamiltonian%vAtomMatrix(b,a,l)%Ptr%HLS(j1,i1,4)
                                write(iunit,877) &
                                     Hamiltonian%vAtomMatrix(b,a,l)%Ptr%CDMLS(j1,i1,1), &
                                     Hamiltonian%vAtomMatrix(b,a,l)%Ptr%CDMLS(j1,i1,2)
                                write(iunit,877) &
                                     Hamiltonian%vAtomMatrix(b,a,l)%Ptr%CDMLS(j1,i1,3), &
                                     Hamiltonian%vAtomMatrix(b,a,l)%Ptr%CDMLS(j1,i1,4)
876                             format(1d25.16)
877                             format(4d25.16)
                             end if
                          end if
                       end do
                       close(iunit)
                    end do
                 end if
              end if
100           continue
              call MPI__Barrier
           end do

        end do
     end do

  end do

  return
end subroutine Hamiltonian__saveAM_ASCOT

subroutine Hamiltonian__rotAM_ASCOT
  use ac_misc_module
  use ac_mpi_module
  use scf_negf

  implicit none
  integer :: l,a,i1,b,j1,i_cont
  real(8) :: del_lc,temp

  del_lc=Param%Cell%Lc(1)/dfloat(Param%Cell%Nc)
  del_lc=del_lc*(n_c*shift_cell_l1/shift_cell_l2)

  do a=MPI%isatom,MPI%ieatom
     do l=0,Param%Cell%nL-1
        do b=1,Param%Data%natom
           if( .not. associated(Hamiltonian%vAtomMatrix(b,a,l)%Ptr) ) then
              cycle
           end if
           i_cont=0
           if( dabs(Param%Data%vatom(a)%Ro(1)-del_lc)                              &
                > dabs(Param%Data%vatom(b)%Ro(1)-del_lc) ) then
              if( i_rotspin_l==1 .and. (Param%Data%vatom(a)%Ro(1)-del_lc)<0.d0 ) then
                 i_cont=1
              end if
              if( i_rotspin_r==1 .and. (Param%Data%vatom(a)%Ro(1)-del_lc)>0.d0 ) then
                 i_cont=-1
              end if
           else
              if( i_rotspin_l==1 .and. (Param%Data%vatom(b)%Ro(1)-del_lc)<0.d0 ) then
                 i_cont=1
              end if
              if( i_rotspin_r==1 .and. (Param%Data%vatom(b)%Ro(1)-del_lc)>0.d0 ) then
                 i_cont=-1
              end if
           end if

           if( i_cont /= 0 ) then
              do i1=MPI%ispao(a), MPI%iepao(a)
                 do j1=1,Base%vnpao(b)
                    temp=Hamiltonian%vAtomMatrix(b,a,l)%Ptr%CDM(j1,i1,1)
                    Hamiltonian%vAtomMatrix(b,a,l)%Ptr%CDM(j1,i1,1)                  &
                         =Hamiltonian%vAtomMatrix(b,a,l)%Ptr%CDM(j1,i1,2)
                    Hamiltonian%vAtomMatrix(b,a,l)%Ptr%CDM(j1,i1,2)=temp
                 end do
              end do
           end if

        end do
     end do
  end do

  return
end subroutine Hamiltonian__rotAM_ASCOT

subroutine Hamiltonian__calcAMT__as2ac
  use ac_misc_module
  use scf_negf

  implicit none
  integer :: ia,ib,ic,ispin,gn

  do ispin=1,Param%Option%nspin
     do ia=1,Param%Cell%Na
        do ib=1,Param%Cell%Nb
           do ic=1,Param%Cell%Nc
              gn=(ia-1)*n_b*n_c+(ib-1)*n_c+(ic-1)+1
              Potential%Vtot(ispin,ia,ib,ic)=v_tot_temp(gn,ispin)
              v_tot(gn,ispin)=v_tot_temp(gn,ispin)
           end do
        end do
     end do
  end do

  return
end subroutine Hamiltonian__calcAMT__as2ac

subroutine Hamiltonian__calcD__acbas(temp_rho)
  use ac_misc_module
  use ac_mpi_module
  use scf_negf

  implicit none
  real(8) ::                                                                     &
       temp_rho(Param%Cell%Na,Param%Cell%Nb,Param%Cell%Nc,ispin_pol_scf)
  integer :: ia0,ib0,ic0,ispin

  do ic0=1,Param%Cell%Nc
     do ib0=1,Param%Cell%Nb
        do ia0=1,Param%Cell%Na
           do ispin=1,Param%Option%nspin
              temp_rho(ia0,ib0,ic0,ispin) = Density%rho(ispin,ia0,ib0,ic0)
           end do
        end do
     end do
  end do

  return
end subroutine Hamiltonian__calcD__acbas

subroutine Hamiltonian__calcD_ls__acbas(temp_rhols)
  use ac_misc_module
  use ac_mpi_module
  use scf_negf

  implicit none
  complex(8) :: temp_rhols(Param%Cell%Na,Param%Cell%Nb,Param%Cell%Nc,ispin_pol_scf)
  integer :: ia0,ib0,ic0,ispin

  do ic0=1,Param%Cell%Nc
     do ib0=1,Param%Cell%Nb
        do ia0=1,Param%Cell%Na
           temp_rhols(ia0,ib0,ic0,1) = dcmplx(dreal(Density%rhoLS(1,ia0,ib0,ic0)),0.d0)
           temp_rhols(ia0,ib0,ic0,2)  &
                = (Density%rhoLS(2,ia0,ib0,ic0)+dconjg(Density%rhoLS(3,ia0,ib0,ic0)))*.5d0
           temp_rhols(ia0,ib0,ic0,3) = dconjg(temp_rhols(ia0,ib0,ic0,2))
           temp_rhols(ia0,ib0,ic0,4) = dcmplx(dreal(Density%rhoLS(4,ia0,ib0,ic0)),0.d0)
        end do
     end do
  end do

  return
end subroutine Hamiltonian__calcD_ls__acbas

subroutine Hamiltonian__calcD__ac2as
  use ac_misc_module
  use ac_mpi_module
  use scf_negf

  implicit none
  integer :: ia0,ib0,ic0,ispin

  if( Param%Option%nspin < 4 ) then
     do ic0=1,Param%Cell%Nc
        do ib0=1,Param%Cell%Nb
           do ia0=1,Param%Cell%Na
              do ispin=1,Param%Option%nspin
                 Density%rho(ispin,ia0,ib0,ic0)=rho((ia0-1)*n_b*n_c+(ib0-1)*n_c+(ic0-1)+1,ispin)
              end do
           end do
        end do
     end do
  else
     do ic0=1,Param%Cell%Nc
        do ib0=1,Param%Cell%Nb
           do ia0=1,Param%Cell%Na
              do ispin=1,Param%Option%nspin
                 Density%rhoLS(ispin,ia0,ib0,ic0)=rhols((ia0-1)*n_b*n_c+(ib0-1)*n_c+(ic0-1)+1,ispin)
              end do
           end do
        end do
     end do
  end if

  return
end subroutine Hamiltonian__calcD__ac2as

subroutine Hamiltonian__calcD__as2ac(qx_scf,qy_scf,qq_con,kt)
  use ac_misc_module
  use ac_mpi_module
  use scf_negf
  use hamiltonian_temp

  use hamiltonian_c

  implicit none
  integer, intent(in) :: kt
  real(8), intent(in) :: qx_scf,qy_scf,qq_con
  integer :: l,a,b,i1,j1,ispin
  real(8) :: co,sn
  complex(8) :: temp1,temp2
  integer :: i, j

  if( kt == 1 ) then
     do a=MPI%isatom,MPI%ieatom
        do b=1,num_atom_scf
           if( a <= numl_atom_scf .and. b > num_atom_scf-numr_atom_scf ) then
              cycle
           end if
           if( b <= numl_atom_scf .and. a > num_atom_scf-numr_atom_scf ) then
              cycle
           end if
           do l=0,param_cell_nl-1
              if( .not. associated(Hamiltonian%vAtomMatrix(b,a,l)%Ptr) ) then
                 cycle
              end if
              do i1=MPI%ispao(a), MPI%iepao(a)
                 do j1=1,iatom_orb_num(b)
                    if( Param%Option%nspin < 4 ) then
                       do ispin=1,Param%Option%nspin
                          Hamiltonian%vAtomMatrix(b,a,l)%Ptr%CDM(j1,i1,ispin)=0.d0
                       end do
                       if( Param%Option%optimize ) then
                          Hamiltonian%vAtomMatrix(b,a,l)%Ptr%EDM(j1,i1)=0.d0
                       end if
                    else
                       do ispin=1,Param%Option%nspin
                          Hamiltonian%vAtomMatrix(b,a,l)%Ptr%CDMLS(j1,i1,ispin)=dcmplx(0.d0,0.d0)
                       end do
                       if( Param%Option%optimize ) then
                          Hamiltonian%vAtomMatrix(b,a,l)%Ptr%EDMLS(j1,i1)=0.d0
                       end if
                    end if
                 end do
              end do
           end do
        end do
     end do
  end if

  do a=MPI%isatom,MPI%ieatom
     do b=1,num_atom_scf
        if( a <= numl_atom_scf .and. b > num_atom_scf-numr_atom_scf ) then
           cycle
        end if
        if( b <= numl_atom_scf .and. a > num_atom_scf-numr_atom_scf ) then
           cycle
        end if
        do l=0,param_cell_nl-1
           if( .not. associated(Hamiltonian%vAtomMatrix(b,a,l)%Ptr) ) then
              cycle
           end if
           co=dcos(-qx_scf*rac_c(2,l+1)-qy_scf*rac_c(3,l+1))                    &
                *qq_con/dfloat(kt_num)
           sn=dsin(-qx_scf*rac_c(2,l+1)-qy_scf*rac_c(3,l+1))                    &
                *qq_con/dfloat(kt_num)
           do i1=MPI%ispao(a), MPI%iepao(a)
              do j1=1,iatom_orb_num(b)
                 i = i_orb(a)+i1
                 j = i_orb(b)+j1
                 if( Param%Option%nspin < 4 ) then
                    do ispin=1,Param%Option%nspin
                       Hamiltonian%vAtomMatrix(b,a,l)%Ptr%CDM(j1,i1,ispin)          &
                            =Hamiltonian%vAtomMatrix(b,a,l)%Ptr%CDM(j1,i1,ispin)    &
                            +dens(ispin,j,i)*co - dens2(ispin,j,i)*sn
                       if( Param%Option%optimize ) then
                          Hamiltonian%vAtomMatrix(b,a,l)%Ptr%EDM(j1,i1)              &
                               =Hamiltonian%vAtomMatrix(b,a,l)%Ptr%EDM(j1,i1)            &
                               +edens(ispin,j,i)*co*EV_TO_AU &
                               -edens2(ispin,j,i)*sn*EV_TO_AU
                       end if
                    end do
                 else
                    temp1=dcmplx(co,sn)
                    temp2                                                          &
                         =dcmplx(dens(1,j*2-1,i*2-1) &
                         ,dens2(1,j*2-1,i*2-1))
                    Hamiltonian%vAtomMatrix(b,a,l)%Ptr%CDMLS(j1,i1,1)              &
                         =Hamiltonian%vAtomMatrix(b,a,l)%Ptr%CDMLS(j1,i1,1)        &
                         +temp1*temp2
                    temp2                                                          &
                         =dcmplx(dens(1,j*2-1,i*2)   &
                         ,dens2(1,j*2-1,i*2))
                    Hamiltonian%vAtomMatrix(b,a,l)%Ptr%CDMLS(j1,i1,2)              &
                         =Hamiltonian%vAtomMatrix(b,a,l)%Ptr%CDMLS(j1,i1,2)        &
                         +temp1*temp2
                    temp2                                                          &
                         =dcmplx(dens(1,j*2,i*2-1)   &
                         ,dens2(1,j*2,i*2-1))
                    Hamiltonian%vAtomMatrix(b,a,l)%Ptr%CDMLS(j1,i1,3)              &
                         =Hamiltonian%vAtomMatrix(b,a,l)%Ptr%CDMLS(j1,i1,3)        &
                         +temp1*temp2
                    temp2                                                          &
                         =dcmplx(dens(1,j*2,i*2)     &
                         ,dens2(1,j*2,i*2))
                    Hamiltonian%vAtomMatrix(b,a,l)%Ptr%CDMLS(j1,i1,4)              &
                         =Hamiltonian%vAtomMatrix(b,a,l)%Ptr%CDMLS(j1,i1,4)        &
                         +temp1*temp2

                    if( Param%Option%optimize ) then
                       temp1=dcmplx(co,sn)*EV_TO_AU
                       temp2                                                        &
                            =dcmplx(edens(1,j*2-1,i*2-1) &
                            ,edens2(1,j*2-1,i*2-1)) &
                            +dcmplx(edens(1,j*2,i*2)     &
                            ,edens2(1,j*2,i*2))
                       Hamiltonian%vAtomMatrix(b,a,l)%Ptr%EDMLS(j1,i1)              &
                            =Hamiltonian%vAtomMatrix(b,a,l)%Ptr%EDMLS(j1,i1)          &
                            +dreal(temp1*temp2)
                    end if
                 end if
              end do
           end do
        end do
     end do
  end do

  return
end subroutine Hamiltonian__calcD__as2ac

subroutine Hamiltonian__delDM(dif_max_rho,rho_max)
  use ac_misc_module
  use ac_mpi_module
  use scf_negf
  use mod_mpi
  use hamiltonian_c

  implicit none
  real(8), intent(out) :: dif_max_rho,rho_max

  real(8), allocatable :: rho_temp1(:,:),rho_temp2(:,:)
  integer :: ier,i_temp,i1_do,i2_do

  integer :: a,b,l,i1,j1,ispin

  dif_max_rho=0.d0

  do a=MPI%isatom,MPI%ieatom
     do b=1,num_atom_scf
        if( a <= numl_atom_scf .and. b > num_atom_scf-numr_atom_scf ) then
           cycle
        end if
        if( b <= numl_atom_scf .and. a > num_atom_scf-numr_atom_scf ) then
           cycle
        end if
        do l=0,param_cell_nl-1
           if( .not. associated(Hamiltonian%vAtomMatrix(b,a,l)%Ptr) ) then
              cycle
           end if
           do i1=MPI%ispao(a), MPI%iepao(a)
              do j1=1,iatom_orb_num(b)
                 do ispin=1,Param%Option%nspin
                    if( Param%Option%nspin < 4 ) then
                       if( dif_max_rho                                                 &
                            < dabs(Hamiltonian%vAtomMatrix(b,a,l)%Ptr%vpast(1)%dCDM(j1,i1,ispin)) ) &
                            then
                          dif_max_rho                                                   &
                               =dabs(Hamiltonian%vAtomMatrix(b,a,l)%Ptr%vpast(1)%dCDM(j1,i1,ispin))
                          rho_max=Hamiltonian%vAtomMatrix(b,a,l)%Ptr%CDM(j1,i1,ispin)
                       end if
                    else
                       if( dif_max_rho                                                 &
                            < cdabs(Hamiltonian%vAtomMatrix(b,a,l)%Ptr%vpast(1)%dCDMLS(j1,i1,ispin)) ) &
                            then
                          dif_max_rho                                                   &
                               =cdabs(Hamiltonian%vAtomMatrix(b,a,l)%Ptr%vpast(1)%dCDMLS(j1,i1,ispin))
                          rho_max=cdabs(Hamiltonian%vAtomMatrix(b,a,l)%Ptr%CDMLS(j1,i1,ispin))
                       end if
                    end if
                 end do
              end do
           end do
        end do
     end do
  end do


  allocate(rho_temp1(2,MPI%size),rho_temp2(2,MPI%size),stat=ier)
  if( ier /= 0 ) then
     open(unit=16,file=Param%Option%file_ac_tempout,position='append')
     write(16,*) 'error allocate'
     close(16)
     stop
  end if
  do i2_do=1,MPI%size
     do i1_do=1,2
        rho_temp1(i1_do,i2_do)=0.d0
        rho_temp2(i1_do,i2_do)=0.d0
     end do
  end do
  rho_temp1(1,MPI%rank+1)=dif_max_rho
  rho_temp1(2,MPI%rank+1)=rho_max
  i_temp=2*MPI%size
  call MPI_ALLREDUCE(rho_temp1,rho_temp2,i_temp,MPI_DOUBLE_PRECISION,MPI_SUM  &
       ,mpi_comm_world,ier)
  dif_max_rho=0.d0
  do i2_do=1,MPI%size
     if( dif_max_rho < rho_temp2(1,i2_do) ) then
        dif_max_rho=rho_temp2(1,i2_do)
        rho_max=rho_temp2(2,i2_do)
     end if
  end do
  deallocate(rho_temp1,rho_temp2,stat=ier)
  if( ier /= 0 ) then
     open(unit=16,file=Param%Option%file_ac_tempout,position='append')
     write(16,*) 'error deallocate:'
     close(16)
     stop
  end if

  return
end subroutine Hamiltonian__delDM

subroutine Hamiltonian__delDR(dif_max_rho,rho_max)
  use ac_misc_module
  use ac_mpi_module
  use scf_negf
  use mod_mpi
  use hamiltonian_c

  implicit none
  real(8), intent(out) :: dif_max_rho,rho_max

  real(8), allocatable :: rho_temp1(:,:),rho_temp2(:,:)
  integer :: ier,i_temp,i1_do,i2_do

  integer :: ispin,ia0,ib0,ic0

  dif_max_rho=0.d0

  do ic0=1,Param%Cell%Nc
     if( ic0 > l_cell_l_bound .and. ic0 < r_cell_l_bound ) then
        do ib0=1,Param%Cell%Nb
           do ia0=1,Param%Cell%Na
              do ispin=1,Param%Option%nspin
                 if( Param%Option%nspin < 4 ) then
                    if( dif_max_rho < dabs(Density%vpast(1)%drho(ispin,ia0,ib0,ic0)) ) then
                       dif_max_rho=dabs(Density%vpast(1)%drho(ispin,ia0,ib0,ic0))
                       rho_max=Density%rho(ispin,ia0,ib0,ic0)
                    end if
                 else
                    if( dif_max_rho < cdabs(Density%vpast(1)%drhoLS(ispin,ia0,ib0,ic0)) ) then
                       dif_max_rho=cdabs(Density%vpast(1)%drhoLS(ispin,ia0,ib0,ic0))
                       rho_max=cdabs(Density%rhoLS(ispin,ia0,ib0,ic0))
                    end if
                 end if
              end do
           end do
        end do
     end if
  end do


  allocate(rho_temp1(2,MPI%size),rho_temp2(2,MPI%size),stat=ier)
  if( ier /= 0 ) then
     open(unit=16,file=Param%Option%file_ac_tempout,position='append')
     write(16,*) 'error allocate'
     close(16)
     stop
  end if
  do i2_do=1,MPI%size
     do i1_do=1,2
        rho_temp1(i1_do,i2_do)=0.d0
        rho_temp2(i1_do,i2_do)=0.d0
     end do
  end do
  rho_temp1(1,MPI%rank+1)=dif_max_rho
  rho_temp1(2,MPI%rank+1)=rho_max
  i_temp=2*MPI%size
  call MPI_ALLREDUCE(rho_temp1,rho_temp2,i_temp,MPI_DOUBLE_PRECISION,MPI_SUM  &
       ,mpi_comm_world,ier)
  dif_max_rho=0.d0
  do i2_do=1,MPI%size
     if( dif_max_rho < rho_temp2(1,i2_do) ) then
        dif_max_rho=rho_temp2(1,i2_do)
        rho_max=rho_temp2(2,i2_do)
     end if
  end do
  deallocate(rho_temp1,rho_temp2,stat=ier)
  if( ier /= 0 ) then
     open(unit=16,file=Param%Option%file_ac_tempout,position='append')
     write(16,*) 'error deallocate:'
     close(16)
     stop
  end if

  return
end subroutine Hamiltonian__delDR

subroutine set_ham_scf_ham_c(qx_scf,qy_scf)

  use ac_misc_module
  use ac_mpi_module

  use scf_negf
  use mod_mpi
  use hamiltonian_c
  use hamiltonian_sgf
  use hamiltonian_temp
  use constant

  implicit none
  real(8), intent(in) :: qx_scf,qy_scf

  complex(8), allocatable :: h_temp1(:,:,:),h_temp2(:,:,:)
  complex(8) :: const
  integer :: ier,i_temp,i1_do,i2_do,i3_do

  integer :: a,i1
  integer :: l,b,j1
  integer :: i_do,j_do,ispin,ic_spin
  real(8) :: co,sn
  integer :: i, j

  if( ispin_pol_scf == 2 ) then
     ic_spin=2
  else
     ic_spin=1
  end if

  do i_do=1,m_mat_max_c
     do j_do=1,m_mat_max_c
        do ispin=1,ic_spin
           h_cc_scf(ispin,i_do,j_do)=dcmplx(0.d0,0.d0)
        end do
        s_cc_scf(i_do,j_do)=dcmplx(0.d0,0.d0)
     end do
  end do

  do a=MPI%isatom,MPI%ieatom
     do b=1,num_atom_scf
        if( a <= numl_atom_scf .and. b > num_atom_scf-numr_atom_scf ) then
           cycle
        end if
        if( b <= numl_atom_scf .and. a > num_atom_scf-numr_atom_scf ) then
           cycle
        end if
        do l=0,param_cell_nl-1
           if( .not. associated(Hamiltonian%vAtomMatrix(b,a,l)%Ptr) ) then
              cycle
           end if
           co=dcos(qx_scf*rac_c(2,l+1)+qy_scf*rac_c(3,l+1))
           sn=dsin(qx_scf*rac_c(2,l+1)+qy_scf*rac_c(3,l+1))
           if( l /= 0 ) then
              const=dcmplx(co,sn)
           else
              const=dcmplx(.5d0*co,.5d0*sn)
           end if
           do i1=MPI%ispao(a), MPI%iepao(a)
              do j1=1,iatom_orb_num(b)
                 i = i_orb(a)+i1
                 j = i_orb(b)+j1
                 if( Param%Option%nspin < 4 ) then
                    do ispin=1,Param%Option%nspin
                       h_cc_scf(ispin,j,i)               &
                            =h_cc_scf(ispin,j,i)         &
                            +Hamiltonian%vAtomMatrix(b,a,l)%Ptr%H(j1,i1,ispin)*const
                    end do
                    s_cc_scf(j,i)                       &
                         =s_cc_scf(j,i)                 &
                         +Hamiltonian%vAtomMatrix(b,a,l)%Ptr%S(j1,i1)*const
                 else
                    h_cc_scf(1,j*2-1,i*2-1)         &
                         =h_cc_scf(1,j*2-1,i*2-1)   &
                         +Hamiltonian%vAtomMatrix(b,a,l)%Ptr%HLS(j1,i1,1)*const
                    h_cc_scf(1,j*2-1,i*2)           &
                         =h_cc_scf(1,j*2-1,i*2)     &
                         +Hamiltonian%vAtomMatrix(b,a,l)%Ptr%HLS(j1,i1,2)*const
                    h_cc_scf(1,j*2,i*2-1)           &
                         =h_cc_scf(1,j*2,i*2-1)     &
                         +Hamiltonian%vAtomMatrix(b,a,l)%Ptr%HLS(j1,i1,3)*const
                    h_cc_scf(1,j*2,i*2)             &
                         =h_cc_scf(1,j*2,i*2)       &
                         +Hamiltonian%vAtomMatrix(b,a,l)%Ptr%HLS(j1,i1,4)*const
                    s_cc_scf(j*2-1,i*2-1)           &
                         =s_cc_scf(j*2-1,i*2-1)     &
                         +Hamiltonian%vAtomMatrix(b,a,l)%Ptr%S(j1,i1)*const
                    s_cc_scf(j*2,i*2)               &
                         =s_cc_scf(j*2,i*2)         &
                         +Hamiltonian%vAtomMatrix(b,a,l)%Ptr%S(j1,i1)*const
                 end if
              end do
           end do
        end do
     end do
  end do


  allocate(h_temp1(ic_spin+1,m_mat_max_c,m_mat_max_c)                         &
       ,h_temp2(ic_spin+1,m_mat_max_c,m_mat_max_c),stat=ier)
  if( ier /= 0 ) then
     open(unit=16,file=Param%Option%file_ac_tempout,position='append')
     write(16,*) 'error allocate:'
     close(16)
     stop
  end if
  do i3_do=1,m_mat_max_c
     do i2_do=1,m_mat_max_c
        do i1_do=1,ic_spin
           h_temp1(i1_do,i2_do,i3_do)=h_cc_scf(i1_do,i2_do,i3_do)
           h_temp2(i1_do,i2_do,i3_do)=dcmplx(0.d0,0.d0)
        end do
        h_temp1(ic_spin+1,i2_do,i3_do)=s_cc_scf(i2_do,i3_do)
        h_temp2(ic_spin+1,i2_do,i3_do)=dcmplx(0.d0,0.d0)
     end do
  end do
  i_temp=(ic_spin+1)*m_mat_max_c*m_mat_max_c
  call MPI_ALLREDUCE(h_temp1,h_temp2,i_temp,MPI_DOUBLE_COMPLEX,MPI_SUM        &
       ,mpi_comm_world,ier)
  do i3_do=1,m_mat_max_c
     do i2_do=1,m_mat_max_c
        do i1_do=1,ic_spin
           h_cc_scf(i1_do,i2_do,i3_do)=h_temp2(i1_do,i2_do,i3_do)
        end do
        s_cc_scf(i2_do,i3_do)=h_temp2(ic_spin+1,i2_do,i3_do)
     end do
  end do
  deallocate(h_temp1,h_temp2,stat=ier)
  if( ier /= 0 ) then
     open(unit=16,file=Param%Option%file_ac_tempout,position='append')
     write(16,*) 'error deallocate:'
     close(16)
     stop
  end if

  do i3_do=1,m_mat_max_c
     do i2_do=i3_do,m_mat_max_c
        do i1_do=1,ic_spin
           h_cc_scf(i1_do,i2_do,i3_do)                                           &
                =(h_cc_scf(i1_do,i2_do,i3_do)+dconjg(h_cc_scf(i1_do,i3_do,i2_do))) &
                *ene_scale
           h_cc_scf(i1_do,i3_do,i2_do)=dconjg(h_cc_scf(i1_do,i2_do,i3_do))
        end do
        s_cc_scf(i2_do,i3_do)=s_cc_scf(i2_do,i3_do)                           &
             +dconjg(s_cc_scf(i3_do,i2_do))
        s_cc_scf(i3_do,i2_do)=dconjg(s_cc_scf(i2_do,i3_do))
     end do
  end do


  if( ispin_pol_scf < 4 ) then
     do j_do=1,m_mat_max_c
        do i_do=1,m_mat_max_c
           if( i_do <= i_orb(atom_parlay_l*lay_shift_l+1)                       &
                .and. j_do <= i_orb(atom_parlay_l*lay_shift_l+1) ) then
              do ispin=1,ic_spin
                 h_cc_scf(ispin,i_do,j_do)=h00_l_t(ispin,i_do,j_do)
              end do
              s_cc_scf(i_do,j_do)=s00_l_t(i_do,j_do)
              cycle
           end if
           if( i_do > i_orb(num_atom_scf-atom_parlay_r*lay_shift_r+1) .and.     &
                j_do > i_orb(num_atom_scf-atom_parlay_r*lay_shift_r+1) ) then
              do ispin=1,ic_spin
                 h_cc_scf(ispin,i_do,j_do)                                        &
                      =h00_r_t(ispin,mat_max_rr-m_mat_max_c+i_do                 &
                      ,mat_max_rr-m_mat_max_c+j_do)
              end do
              s_cc_scf(i_do,j_do)=s00_r_t(mat_max_rr-m_mat_max_c+i_do            &
                   ,mat_max_rr-m_mat_max_c+j_do)
              cycle
           end if
        end do
     end do
  else
     do j_do=1,m_mat_max_c
        do i_do=1,m_mat_max_c
           if( i_do <= i_orb(atom_parlay_l*lay_shift_l+1)*2 .and.               &
                j_do <= i_orb(atom_parlay_l*lay_shift_l+1)*2 ) then
              h_cc_scf(1,i_do,j_do)=h00_l_t(1,i_do,j_do)
              s_cc_scf(i_do,j_do)=s00_l_t(i_do,j_do)
              cycle
           end if
           if( i_do > i_orb(num_atom_scf-atom_parlay_r*lay_shift_r+1)*2 .and.   &
                j_do > i_orb(num_atom_scf-atom_parlay_r*lay_shift_r+1)*2 ) then
              h_cc_scf(1,i_do,j_do)                                              &
                   =h00_r_t(1,mat_max_rr-m_mat_max_c+i_do                 &
                   ,mat_max_rr-m_mat_max_c+j_do)
              s_cc_scf(i_do,j_do)=s00_r_t(mat_max_rr-m_mat_max_c+i_do            &
                   ,mat_max_rr-m_mat_max_c+j_do)
              cycle
           end if
        end do
     end do
  end if

  return
end subroutine set_ham_scf_ham_c

subroutine calc_charge_open
  use scf_negf
  use ac_misc_module
  use ac_mpi_module

  implicit none
  real(8), allocatable :: ca(:,:),ca_sen(:,:),ca_rec(:,:)
  real(8) :: sum_u,sum_d
  real(8) :: const
  integer :: l,a,b,i1,j1,i_temp,ispin

  if( Param%Option%nspin == 4 ) then
     call calc_charge_open_ls
     return
  end if

  allocate( ca(2,Param%Data%natom) )
  do a=1,Param%Data%natom
     do ispin=1,2
        ca(ispin,a)=0.d0
     end do
  end do

  do l=0,Param%Cell%nL-1
     do a=MPI%isatom,MPI%ieatom
        do b=1,Param%Data%natom
           if( .not. associated(Hamiltonian%vAtomMatrix(b,a,l)%Ptr) ) then
              cycle
           end if
           do i1=MPI%ispao(a), MPI%iepao(a)
              do j1=1,Base%vnpao(b)
                 do ispin=1,Param%Option%nspin
                    ca(ispin,a)                                                          &
                         =ca(ispin,a)+Hamiltonian%vAtomMatrix(b,a,l)%Ptr%CDM(j1,i1,ispin)  &
                         *Hamiltonian%vAtomMatrix(b,a,l)%Ptr%S(j1,i1)
                    if( l > 0 ) then
                       ca(ispin,b)                                                        &
                            =ca(ispin,b)+Hamiltonian%vAtomMatrix(b,a,l)%Ptr%CDM(j1,i1,ispin)  &
                            *Hamiltonian%vAtomMatrix(b,a,l)%Ptr%S(j1,i1)
                    end if
                 end do
              end do
           end do
        end do
     end do
  end do

  if( Param%Option%nspin == 1 ) then
     do a=MPI%isatom,MPI%ieatom
        ca(2,a)=ca(1,a)
     end do
  end if

  allocate(ca_sen(2,Param%Data%natom))
  allocate(ca_rec(2,Param%Data%natom))
  do a=1,Param%Data%natom
     do ispin=1,2
        ca_sen(ispin,a)=ca(ispin,a)
        ca_rec(ispin,a)=0.d0
     end do
  end do
  i_temp=2*Param%Data%natom
  call MPI_ALLREDUCE(ca_sen,ca_rec,i_temp,MPI_DOUBLE_PRECISION,MPI_SUM         &
       ,MPI_COMM_WORLD,MPI%info)
  do a=1,Param%Data%natom
     do ispin=1,2
        ca(ispin,a)=ca_rec(ispin,a)
     end do
  end do
  deallocate(ca_sen)
  deallocate(ca_rec)

  if( MPI%root ) then
     sum_u=0.d0
     sum_d=0.d0
     open(unit=37,file='charge_open.dat')
     write(37,*)                                                              &
          '--------------------------------------------------------------'
     write(37,*) '------------   Charge:'
     write(37,*)                                                              &
          '--------------------------------------------------------------'
     write(37,*)                                                              &
          '   number    up             down           total          diff'
     do a=numl_atom_scf,num_atom_scf-numr_atom_scf-1
        write(37,980) a,ca(1,a),ca(2,a),ca(1,a)+ca(2,a),ca(1,a)-ca(2,a)
980     format(5x,i5,4f15.6)
     end do
     write(37,*)                                                              &
          '--------------------------------------------------------------'
981  format(10x,4f15.6)
     close(37)
  end if

  deallocate(ca)

  return
end subroutine calc_charge_open

subroutine calc_charge_open_ls
  use scf_negf
  use ac_misc_module
  use ac_mpi_module

  implicit none
  complex(8), allocatable :: ca(:,:),ca_sen(:,:),ca_rec(:,:)
  real(8) :: sum_u,sum_d,sum_x,sum_y
  real(8) :: const
  integer :: l,a,b,i1,j1,i_temp,ispin

  allocate( ca(4,Param%Data%natom) )
  do a=1,Param%Data%natom
     do ispin=1,4
        ca(ispin,a)=dcmplx(0.d0,0.d0)
     end do
  end do
  const=0.5d0

  do l=0,Param%Cell%nL-1
     do a=MPI%isatom,MPI%ieatom
        do b=1,Param%Data%natom
           if( .not. associated(Hamiltonian%vAtomMatrix(b,a,l)%Ptr) ) then
              cycle
           end if
           do i1=MPI%ispao(a), MPI%iepao(a)
              do j1=1,Base%vnpao(b)
                 do ispin=1,4
                    ca(ispin,a)                                                      &
                         =ca(ispin,a)                                                  &
                         +Hamiltonian%vAtomMatrix(b,a,l)%Ptr%CDMLS(j1,i1,ispin)        &
                         *Hamiltonian%vAtomMatrix(b,a,l)%Ptr%S(j1,i1)*const
                    if( l > 0 ) then
                       ca(ispin,b)                                                    &
                            =ca(ispin,b)                                                  &
                            +Hamiltonian%vAtomMatrix(b,a,l)%Ptr%CDMLS(j1,i1,ispin)        &
                            *Hamiltonian%vAtomMatrix(b,a,l)%Ptr%S(j1,i1)*const
                    end if
                 end do
              end do
           end do
        end do
     end do
  end do

  allocate(ca_sen(4,Param%Data%natom))
  allocate(ca_rec(4,Param%Data%natom))
  do a=1,Param%Data%natom
     do ispin=1,4
        ca_sen(ispin,a)=ca(ispin,a)
        ca_rec(ispin,a)=dcmplx(0.d0,0.d0)
     end do
  end do
  i_temp=4*Param%Data%natom
  call MPI_ALLREDUCE(ca_sen,ca_rec,i_temp,MPI_DOUBLE_COMPLEX,MPI_SUM           &
       ,MPI_COMM_WORLD,MPI%info)
  do a=1,Param%Data%natom
     do ispin=1,4
        ca(ispin,a)=ca_rec(ispin,a)
     end do
  end do
  deallocate(ca_sen)
  deallocate(ca_rec)

  do a=1,Param%Data%natom
     ca(1,a)=ca(1,a)+dconjg(ca(1,a))
     ca(2,a)=ca(2,a)+dconjg(ca(3,a))
     ca(3,a)=dconjg(ca(2,a))
     ca(4,a)=ca(4,a)+dconjg(ca(4,a))
  end do

  if( MPI%root ) then
     sum_u=0.d0
     sum_d=0.d0
     sum_x=0.d0
     sum_y=0.d0
     open(unit=37,file='charge_open.dat')
     write(37,*)                                                              &
          '--------------------------------------------------------------'
     write(37,*) '------------   Charge:'
     write(37,*)                                                              &
          '--------------------------------------------------------------'
     write(37,*)                                                              &
          '   number    total          Mz             Mx             My'
     do a=numl_atom_scf,num_atom_scf-numr_atom_scf-1
        write(37,980) a,dreal(ca(1,a))+dreal(ca(4,a))                        &
             ,dreal(ca(1,a))-dreal(ca(4,a))                        &
             ,dreal(ca(2,a)+ca(3,a))                               &
             ,dimag(ca(2,a)-ca(3,a))
980     format(5x,i5,4f15.6)
     end do
     write(37,*)                                                              &
          '--------------------------------------------------------------'
981  format(10x,4f15.6)
     close(37)
  end if

  deallocate(ca)

  return
end subroutine calc_charge_open_ls

subroutine Force__calc__negf
  use ac_misc_module
  use ac_mpi_module
  use scf_negf

  implicit none
  integer :: a, b, l, i1, j1, ia0, ib0, ic0, ispin

  open(unit=16,file=Param%Option%file_ac_tempout,position='append')
  write(16,*)
  write(16,*) '**************************************************************'
  write(16,*) '************ start calculating forces on each atom'
  write(16,*) '**************************************************************'
  close(16)

  if( .not. Param%Option%spin_polar ) then
     do a=MPI%isatom,MPI%ieatom
        do b=1,Param%Data%natom
           do l=0,Param%Cell%nL-1
              if( .not. associated(Hamiltonian%vAtomMatrix(b,a,l)%Ptr) ) then
                 cycle
              end if
              do i1=MPI%ispao(a), MPI%iepao(a)
                 do j1=1, Base%vnpao(b)
                    Hamiltonian%vAtomMatrix(b,a,l)%Ptr%CDM(j1,i1,1)                &
                         =Hamiltonian%vAtomMatrix(b,a,l)%Ptr%CDM(j1,i1,1)*2.d0
                    if( Param%Option%optimize ) then
                       Hamiltonian%vAtomMatrix(b,a,l)%Ptr%EDM(j1,i1)                &
                            =Hamiltonian%vAtomMatrix(b,a,l)%Ptr%EDM(j1,i1)*2.d0
                    end if
                 end do
              end do
           end do
        end do
     end do
  end if

  do ic0=1,Param%Cell%Nc
     do ib0=1,Param%Cell%Nb
        do ia0=1,Param%Cell%Na
           Potential%dVhar(ia0,ib0,ic0) = v_hartree((ia0-1)*n_b*n_c+(ib0-1)*n_c+(ic0-1)+1)
           do ispin=1,Param%Option%nspin
              if( Param%Option%nspin == 1 ) then
                 Density%rho(ispin,ia0,ib0,ic0)                                         &
                      =rho_temp((ia0-1)*n_b*n_c+(ib0-1)*n_c+(ic0-1)+1,ispin)*2.d0
              else
                 if( Param%Option%nspin == 2 ) then
                    Density%rho(ispin,ia0,ib0,ic0)                                       &
                         =rho_temp((ia0-1)*n_b*n_c+(ib0-1)*n_c+(ic0-1)+1,ispin)
                 else
                    Density%rhoLS(ispin,ia0,ib0,ic0)                                     &
                         =rhols_temp(ia0*n_b*n_c+ib0*n_c+ic0+1,ispin)
                 end if
              end if
              Potential%Vtot(ispin,ia0,ib0,ic0)=v_tot((ia0-1)*n_b*n_c+(ib0-1)*n_c+(ic0-1)+1,ispin)
              if( .not. Param%Option%projection ) then
                 if( Param%Option%nspin < 2 ) then
                    Potential%Vexc(ispin,ia0,ib0,ic0)                                    &
                         = Potential%Vtot(ispin,ia0,ib0,ic0)                            &
                         - Potential%dVhar(ia0,ib0,ic0)-Potential%Vext(ia0,ib0,ic0)
                 else
                    if( ispin == 1 .or. ispin == 4 ) then
                       Potential%Vexc(ispin,ia0,ib0,ic0)                                  &
                            = Potential%Vtot(ispin,ia0,ib0,ic0)                         &
                            - Potential%dVhar(ia0,ib0,ic0)-Potential%Vext(ia0,ib0,ic0)
                    else
                       Potential%Vexc(ispin,ia0,ib0,ic0)                                  &
                            = Potential%Vtot(ispin,ia0,ib0,ic0)
                    end if
                 end if
              end if
           end do
        end do
     end do
  end do

  do a=1, Param%Data%natom
     Param%Data%vatom(a)%force = 0.d0
  end do

  call Force__calcSK
  call Force__calcT
  call Force__calcN
  if( Param%Option%projection ) then
     call Force__calcL
  end if
  call Force__calcI
  call Force__calcQ

  call MPI__Allreduce_Force( Param%Data%vatom )

  call Force__show__negf

  return
end subroutine Force__calc__negf

subroutine Force__show__negf
  use ac_misc_module
  use ac_mpi_module
  use scf_negf

  implicit none
  integer :: a

  if( MPI%root ) then
     open(unit=60,file='force_negf.dat')
     write(60,*) '--------------------------------------------------------------'
     write(60,*) '------------   Atoms:'
     write(60,*) '--------------------------------------------------------------'

     write(60,*) ' atom    Force'
     do a=numl_atom_scf+1,num_atom_scf-numr_atom_scf
        write(60,933) a,Param%Data%vatom(a)%name,                              &
             Param%Data%vatom(a)%force
     end do

     write(60,*) '--------------------------------------------------------------'
     write(60,*)
     close(60)
  end if
933 format(i4,'  ',a2,6f20.15)

  open(unit=16,file=Param%Option%file_ac_tempout,position='append')
  write(16,*) '--------------------------------------------------------------'
  write(16,*) '------------   Atoms:'
  write(16,*) '--------------------------------------------------------------'

  write(16,*) ' atom   Ro                            Force'
  do a=numl_atom_scf+1,num_atom_scf-numr_atom_scf
     write(16,932) a,Param%Data%vatom(a)%name,                              &
          Param%Data%vatom(a)%Ro*AU_TO_AA, Param%Data%vatom(a)%force
  end do

  write(16,*) '--------------------------------------------------------------'
  write(16,*)
932 format(i4,'  ',a2,6f10.5)
  close(16)

  return
end subroutine Force__show__negf
