subroutine init_ftlm()
use gndts_mod, only: gndts_all_sym_this_proc
use SystemData, only: nbasis, nel
use util_mod, only: choose_i64, get_free_unit
integer :: ndets_this_proc, ndets_tot, expected_ndets_tot
integer(MPIArg) :: mpi_temp
integer(n_int), allocatable :: ilut_list(:, :)
character(len=*), parameter :: t_r = 'init_ftlm'
integer :: i, ierr
write(stdout, '(/,1x,a49,/)') "Beginning finite-temperature Lanczos calculation."
call neci_flush(stdout)
expected_ndets_tot = int(choose_i64(nbasis, nel))
write(stdout, *) "Expected number:", expected_ndets_tot
call neci_flush(stdout)
ftlm_unit = get_free_unit()
open(ftlm_unit, file='FTLM_EIGV', status='replace')
allocate(ndets_ftlm(0:nProcessors - 1))
allocate(disps_ftlm(0:nProcessors - 1))
write(stdout, '(1x,a56)', advance='no') "Enumerating and storing all determinants in the space..."
call neci_flush(stdout)
! Generate and count all the determinants on this processor, but don't store them.
call gndts_all_sym_this_proc(ilut_list, .true., ndets_this_proc)
allocate(ilut_list(0:NIfTot, ndets_this_proc))
! Now generate them again and store them this time.
call gndts_all_sym_this_proc(ilut_list, .false., ndets_this_proc)
write(stdout, '(1x,a9)') "Complete."
call neci_flush(stdout)
mpi_temp = int(ndets_this_proc, MPIArg)
call MPIAllGather(mpi_temp, ndets_ftlm, ierr)
disps_ftlm(0) = 0
do i = 1, nProcessors - 1
disps_ftlm(i) = disps_ftlm(i - 1) + ndets_ftlm(i - 1)
end do
ndets_tot = int(sum(ndets_ftlm))
expected_ndets_tot = int(choose_i64(nbasis, nel))
if (ndets_tot /= expected_ndets_tot) then
write(stdout, *) "ndets counted:", ndets_tot, "ndets expected:", expected_ndets_tot
call stop_all('t_r', 'The number of determinants generated is not &
&consistent with the expected number.')
end if
write(stdout, '(1x,a44)', advance='no') "Allocating arrays to hold Lanczos vectors..."
call neci_flush(stdout)
allocate(ftlm_vecs(ndets_this_proc, n_lanc_vecs_ftlm))
allocate(full_vec_ftlm(ndets_tot))
write(stdout, '(1x,a9)') "Complete."
call neci_flush(stdout)
allocate(ftlm_hamil(n_lanc_vecs_ftlm, n_lanc_vecs_ftlm))
allocate(ftlm_trace(nbeta_ftlm + 1))
allocate(ftlm_e_num(nbeta_ftlm + 1))
allocate(ftlm_h_eigv(n_lanc_vecs_ftlm))
ftlm_trace = 0.0_dp
ftlm_e_num = 0.0_dp
ftlm_h_eigv = 0.0_dp
write(stdout, '(1x,a48)') "Allocating and calculating Hamiltonian matrix..."
call neci_flush(stdout)
call calculate_sparse_ham_par(ndets_ftlm, ilut_list, .true.)
write(stdout, '(1x,a48,/)') "Hamiltonian allocation and calculation complete."
call neci_flush(stdout)
deallocate(ilut_list)
end subroutine init_ftlm