! @@@@@@@@@@@@@@@@@@@@@@@@@@@@@@@@@@@@@@@@@@@@@@@@@@@@@@@@@@@@@@@@@@@@ !
! @@                                                                @@ !
! @@       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 dens_atom2cell_lr(dif_max_rho,iter)

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

  implicit none
  real(8), intent(inout) :: dif_max_rho
  integer, intent(inout) :: iter

  integer, parameter :: i_write=20
  integer, parameter :: i_write_h=20
  integer, parameter :: i_write_p=1

  real(8) :: temp,rho_max
  integer :: gn,i1,i2,i3,i4,ii,gnj,i,ispin

  call calc_charge_open
  call dens_atom2cell_lr_accel(dif_max_rho,rho_max,iter)
  call ss_cube_charge

  if( iter_conv > 10 .and. iter_conv < 20 ) then
     i=iter
     call Hamiltonian__delDM(dif_max_rho,rho_max)
     if( dif_max_rho < eps_scf ) then
        iter=0
     else
        iter=1
     end if
     write(16,*)                                                                &
          '   ##################################################################'
     write(16,972) eps_scf
     write(16,973) i,dif_max_rho,rho_max
     write(16,*)                                                                &
          '   ##################################################################'
  end if

972 format('    ######  criterion:',f25.16,'                 ######')
973 format('    #dm###       ',i5,f25.16,f15.6,'  ###dm#')

  if( iter_conv > 20 .and. iter_conv < 30 ) then
     i=iter
     call Hamiltonian__delDR2(dif_max_rho,rho_max)
     if( dif_max_rho < eps_scf ) then
        iter=0
     else
        iter=1
     end if
     write(16,*)                                                                &
          '   ##################################################################'
     write(16,974) eps_scf
     write(16,975) i,dif_max_rho,rho_max
     write(16,*)                                                                &
          '   ##################################################################'
  end if

974 format('    ######  criterion:',f25.16,'                 ######')
975 format('    #dr###       ',i5,f25.16,f15.6,'  ###dr#')

  if( iter_conv == 1 ) then
     i=iter
     dif_max_rho=0.d0
     do i1=0,n_a-1
        do i2=0,n_b-1
           do i3=0,n_c-1
              gn=i1*n_b*n_c+i2*n_c+i3+1
              do ispin=1,ispin_pol_scf
                 temp=rho(gn,ispin)-rho_temp(gn,ispin)
                 rho(gn,ispin)=rho_temp(gn,ispin)+mixing_rho*temp
                 rho_temp(gn,ispin)=rho(gn,ispin)
                 if( dabs(temp) > dif_max_rho ) then
                    dif_max_rho=dabs(temp)
                    rho_max=rho_temp(gn,ispin)
                 end if
              end do
           end do
        end do
     end do

     if( dif_max_rho < eps_scf ) then
        iter=0
     else
        iter=1
     end if
     write(16,*)                                                                &
          '   ##################################################################'
     write(16,970) eps_scf
     write(16,971) i,dif_max_rho,rho_max
     write(16,*)                                                                &
          '   ##################################################################'
  end if

970 format('    ######  criterion:',f25.16,'                 ######')
971 format('    #dr###       ',i5,f25.16,f15.6,'  ###dr#')


  if( iter == 0 .or. (iter == 1 .and. mod(i,i_write_p) == 0)                     &
       .or. i == max_num_scf ) then
     write(16,*) '                               +++++ save Potential' 
     call dens_atom2cell_lr_save
  end if
  if( iter == 0 .or. (iter == 1 .and. mod(i,i_write_h) == 0)                     &
       .or. i == max_num_scf ) then
     write(16,*) '                               +++++ save Hamiltonian matrix' 
     call Hamiltonian__saveAM_ASCOT
  end if

  return
end subroutine dens_atom2cell_lr

subroutine dens_atom2cell_lr_accel(del_den,rho_max,iter)

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

  implicit none
  real(8), intent(out) :: del_den,rho_max
  integer, intent(in) :: iter

  integer :: gn,i_con
  integer :: i1,i2,i3,ier,ispin
  integer :: i1_do,i2_do,i3_do
  real(8), allocatable :: temp_rho(:,:,:,:)
  complex(8), allocatable :: temp_rhols(:,:,:,:)

  rho_max=0.d0

  if( ispin_pol_scf < 4 ) then
     allocate(temp_rho(n_a,n_b,n_c,ispin_pol_scf),stat=ier)
  else
     allocate(temp_rhols(n_a,n_b,n_c,ispin_pol_scf),stat=ier)
  end if
  if( ier /= 0 ) then
     write(6,*) 'error allocate: dens_atom2cell_lr'
     stop
  end if

  do ispin=1,ispin_pol_scf
     do i1=1,n_a
        do i2=1,n_b
           do i3=1,n_c
              if( ispin_pol_scf < 4 ) then
                 temp_rho(i1,i2,i3,ispin)=0.d0
              else
                 temp_rhols(i1,i2,i3,ispin)=dcmplx(0.d0,0.d0)
              end if
           end do
        end do
     end do
  end do

  if( iter_conv > 10 .and. iter_conv < 20 ) then
     call DensityMatrix__update(del_den,iter)
  end if
  call Density__calc

  if( iter_conv > 20 .and. iter_conv < 30 ) then
     call Density__update(del_den,iter)
  end if
  if( ispin_pol_scf < 4 ) then
     call Hamiltonian__calcD__acbas(temp_rho)
  else
     call Hamiltonian__calcD_ls__acbas(temp_rhols)
  end if
  do ispin=1,ispin_pol_scf
     do i1=0,n_a-1
        do i2=0,n_b-1
           do i3=0,n_c-1
              if( i3+1 > l_cell_l_bound .and. i3+1 < r_cell_l_bound ) then
                 gn=i1*n_b*n_c+i2*n_c+i3+1
                 if( ispin_pol_scf < 4 ) then
                    rho(gn,ispin)=temp_rho(i1+1,i2+1,i3+1,ispin)
                 else
                    rhols(gn,ispin)=temp_rhols(i1+1,i2+1,i3+1,ispin)
                 end if
              end if
           end do
        end do
     end do
  end do

  call Hamiltonian__calcD__ac2as

  if( ispin_pol_scf < 4 ) then
     deallocate(temp_rho,stat=ier)
  else
     deallocate(temp_rhols,stat=ier)
  end if
  if( ier /= 0 ) then
     write(6,*) 'error allocate: dens_atom2cell_lr'
     stop
  end if

  return
end subroutine dens_atom2cell_lr_accel

subroutine dens_atom2cell_lr_save

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

  implicit none
  integer :: gn,i_con
  integer :: i1,i2,i3,ier,ispin
  integer :: i1_do,i2_do,i3_do
  real(8), allocatable :: temp_rho(:,:,:,:)
  complex(8), allocatable :: temp_rhols(:,:,:,:)

  if( MPI%root ) then

     open(unit=36,file=file_parameter_out_pot)
     write(36,*) spin_switch_cc-1,ka_scf,kb_scf
     write(36,*)
     write(36,*) n_a,n_b,n_c
     write(36,*)
     write(36,*) cell_labc(1,1),cell_labc(1,2),cell_labc(1,3)
     write(36,*) cell_labc(2,1),cell_labc(2,2),cell_labc(2,3)
     write(36,*) cell_labc(3,1),cell_labc(3,2),cell_labc(3,3)
     write(36,*)
     write(36,*) cp_scf_c,'     = Chemical Potential'
     write(36,*) min_level_c,'     = minimum energy'
     write(36,*)
     do i1_do=0,n_a-1
        do i2_do=0,n_b-1
           do i3_do=0,n_c-1
              write(36,991) v_hartree(i1_do*n_b*n_c+i2_do*n_c+i3_do+1)
           end do
        end do
     end do
     write(36,*)
     do i1_do=0,n_a-1
        do i2_do=0,n_b-1
           do i3_do=0,n_c-1
              if( spin_switch_cc == 1 ) then
                 write(36,991) v_tot(i1_do*n_b*n_c+i2_do*n_c+i3_do+1,1)
              else
                 if( spin_switch_cc == 2 ) then
                    write(36,992) v_tot(i1_do*n_b*n_c+i2_do*n_c+i3_do+1,1)           &
                         ,v_tot(i1_do*n_b*n_c+i2_do*n_c+i3_do+1,2)
                 else
                    write(36,994) v_tot(i1_do*n_b*n_c+i2_do*n_c+i3_do+1,1)           &
                         ,v_tot(i1_do*n_b*n_c+i2_do*n_c+i3_do+1,2)           &
                         ,v_tot(i1_do*n_b*n_c+i2_do*n_c+i3_do+1,3)           &
                         ,v_tot(i1_do*n_b*n_c+i2_do*n_c+i3_do+1,4)
                 end if
              end if
           end do
        end do
     end do
     write(36,*)
     do i1_do=0,n_a-1
        do i2_do=0,n_b-1
           do i3_do=0,n_c-1
              if( spin_switch_cc == 1 ) then
                 write(36,991) rho(i1_do*n_b*n_c+i2_do*n_c+i3_do+1,1)
              else
                 if( spin_switch_cc == 2 ) then
                    write(36,992) rho(i1_do*n_b*n_c+i2_do*n_c+i3_do+1,1)           &
                         ,rho(i1_do*n_b*n_c+i2_do*n_c+i3_do+1,2)
                 else
                    write(36,994) rhols(i1_do*n_b*n_c+i2_do*n_c+i3_do+1,1)         &
                         ,rhols(i1_do*n_b*n_c+i2_do*n_c+i3_do+1,2)
                    write(36,994) rhols(i1_do*n_b*n_c+i2_do*n_c+i3_do+1,3)         &
                         ,rhols(i1_do*n_b*n_c+i2_do*n_c+i3_do+1,4)
                 end if
              end if
           end do
        end do
     end do
     close(36)

  end if

994 format(4d25.15)
993 format(3d25.15)
992 format(2d25.15)
991 format(1d25.15)

  return
end subroutine dens_atom2cell_lr_save

subroutine ss_cube_charge

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

  implicit none
  real(8) :: temp,rho_max
  integer :: gn,i1,i2,i3,i4,ii,gnj,i,ispin


  if( MPI%root ) then

     if( ispin_pol_scf == 1 ) then
        open(unit=90,file='negf_den.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) (2.0*rho(gnj+i4,1),i4=1,6)
                 else
                    if( ii == 5 ) write(90,998) (2.0*rho(gnj+i4,1),i4=1,ii)
                    if( ii == 4 ) write(90,997) (2.0*rho(gnj+i4,1),i4=1,ii)
                    if( ii == 3 ) write(90,996) (2.0*rho(gnj+i4,1),i4=1,ii)
                    if( ii == 2 ) write(90,995) (2.0*rho(gnj+i4,1),i4=1,ii)
                    if( ii == 1 ) write(90,994) (2.0*rho(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_den_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) (rho(gnj+i4,1),i4=1,6)
                 else
                    if( ii == 5 ) write(90,998) (rho(gnj+i4,1),i4=1,ii)
                    if( ii == 4 ) write(90,997) (rho(gnj+i4,1),i4=1,ii)
                    if( ii == 3 ) write(90,996) (rho(gnj+i4,1),i4=1,ii)
                    if( ii == 2 ) write(90,995) (rho(gnj+i4,1),i4=1,ii)
                    if( ii == 1 ) write(90,994) (rho(gnj+i4,1),i4=1,ii)
                 end if
              end do
           end do
        end do
        close(90)
        open(unit=90,file='negf_den_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) (rho(gnj+i4,2),i4=1,6)
                 else
                    if( ii == 5 ) write(90,998) (rho(gnj+i4,2),i4=1,ii)
                    if( ii == 4 ) write(90,997) (rho(gnj+i4,2),i4=1,ii)
                    if( ii == 3 ) write(90,996) (rho(gnj+i4,2),i4=1,ii)
                    if( ii == 2 ) write(90,995) (rho(gnj+i4,2),i4=1,ii)
                    if( ii == 1 ) write(90,994) (rho(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_den_to.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) (dreal(rhols(gnj+i4,1)+rhols(gnj+i4,4)),i4=1,6)
                 else
                    if( ii == 5 ) write(90,998)                                    &
                         (dreal(rhols(gnj+i4,1)+rhols(gnj+i4,4)),i4=1,ii)
                    if( ii == 4 ) write(90,997)                                    &
                         (dreal(rhols(gnj+i4,1)+rhols(gnj+i4,4)),i4=1,ii)
                    if( ii == 3 ) write(90,996)                                    &
                         (dreal(rhols(gnj+i4,1)+rhols(gnj+i4,4)),i4=1,ii)
                    if( ii == 2 ) write(90,995)                                    &
                         (dreal(rhols(gnj+i4,1)+rhols(gnj+i4,4)),i4=1,ii)
                    if( ii == 1 ) write(90,994)                                    &
                         (dreal(rhols(gnj+i4,1)+rhols(gnj+i4,4)),i4=1,ii)
                 end if
              end do
           end do
        end do
        close(90)
        open(unit=90,file='negf_den_sz.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) (dreal(rhols(gnj+i4,1)-rhols(gnj+i4,4)),i4=1,6)
                 else
                    if( ii == 5 ) write(90,998)                                    &
                         (dreal(rhols(gnj+i4,1)-rhols(gnj+i4,4)),i4=1,ii)
                    if( ii == 4 ) write(90,997)                                    &
                         (dreal(rhols(gnj+i4,1)-rhols(gnj+i4,4)),i4=1,ii)
                    if( ii == 3 ) write(90,996)                                    &
                         (dreal(rhols(gnj+i4,1)-rhols(gnj+i4,4)),i4=1,ii)
                    if( ii == 2 ) write(90,995)                                    &
                         (dreal(rhols(gnj+i4,1)-rhols(gnj+i4,4)),i4=1,ii)
                    if( ii == 1 ) write(90,994)                                    &
                         (dreal(rhols(gnj+i4,1)-rhols(gnj+i4,4)),i4=1,ii)
                 end if
              end do
           end do
        end do
        close(90)
        open(unit=90,file='negf_den_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) (dreal(rhols(gnj+i4,2)+rhols(gnj+i4,3)),i4=1,6)
                 else
                    if( ii == 5 ) write(90,998)                                    &
                         (dreal(rhols(gnj+i4,2)+rhols(gnj+i4,3)),i4=1,ii)
                    if( ii == 4 ) write(90,997)                                    &
                         (dreal(rhols(gnj+i4,2)+rhols(gnj+i4,3)),i4=1,ii)
                    if( ii == 3 ) write(90,996)                                    &
                         (dreal(rhols(gnj+i4,2)+rhols(gnj+i4,3)),i4=1,ii)
                    if( ii == 2 ) write(90,995)                                    &
                         (dreal(rhols(gnj+i4,2)+rhols(gnj+i4,3)),i4=1,ii)
                    if( ii == 1 ) write(90,994)                                    &
                         (dreal(rhols(gnj+i4,2)+rhols(gnj+i4,3)),i4=1,ii)
                 end if
              end do
           end do
        end do
        close(90)
        open(unit=90,file='negf_den_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) (dimag(rhols(gnj+i4,2)-rhols(gnj+i4,3)),i4=1,6)
                 else
                    if( ii == 5 ) write(90,998)                                    &
                         (dimag(rhols(gnj+i4,2)-rhols(gnj+i4,3)),i4=1,ii)
                    if( ii == 4 ) write(90,997)                                    &
                         (dimag(rhols(gnj+i4,2)-rhols(gnj+i4,3)),i4=1,ii)
                    if( ii == 3 ) write(90,996)                                    &
                         (dimag(rhols(gnj+i4,2)-rhols(gnj+i4,3)),i4=1,ii)
                    if( ii == 2 ) write(90,995)                                    &
                         (dimag(rhols(gnj+i4,2)-rhols(gnj+i4,3)),i4=1,ii)
                    if( ii == 1 ) write(90,994)                                    &
                         (dimag(rhols(gnj+i4,2)-rhols(gnj+i4,3)),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 ss_cube_charge
