SUBROUTINE PrintHighPops()
use adi_references, only: update_ref_signs, print_reference_notification, nRefs
use adi_data, only: tSetupSIs
use guga_data, only: ExcitationInformation_t
use guga_bitrepops, only: identify_excitation, write_guga_list
real(dp), dimension(lenof_sign) :: SignCurr
integer :: ierr,i,j,counter,ExcitLev,nopen
integer :: full_orb, run
real(dp) :: HighSign, norm
integer(n_int) , allocatable :: GlobalLargestWalkers(:, :)
integer, allocatable :: GlobalProc(:), tmp_ni(:)
real(dp), allocatable :: GlobalHdiag(:)
character(100) :: bufEnd, bufStart
integer :: lenEnd, lenStart
character(len=*), parameter :: t_r='PrintHighPops'
character(1024) :: header
character(11), allocatable :: walker_string(:)
character(13), allocatable :: amplitude_string(:)
character(9), allocatable :: init_string(:)
integer :: lenof_out, this_run, offset
logical :: t_replica_resolved_output
real(dp), parameter :: eps_high = 1.0e-7_dp
type(ExcitationInformation_t) :: excitInfo
allocate(GlobalLargestWalkers(0:NIfTot,iHighPopWrite), source=0_n_int)
allocate(GlobalHdiag(iHighPopWrite), source=0.0_dp)
allocate(GlobalProc(iHighPopWrite), source=0)
! Decide if each replica shall have its own output
t_replica_resolved_output = tOrthogonaliseReplicas .or. t_force_replica_output
if(t_replica_resolved_output) then
lenof_out = rep_size
else
lenof_out = lenof_sign
end if
! Walkers(replica) Amplitude(replica) Init?(replica)
allocate(walker_string(lenof_out))
allocate(init_string(lenof_out))
do run = 1, inum_runs
! If t_replica_resolved_output is set:
! Execute this once per run with run instead of GLOBAL_RUN -> prints the highest
! determinants for each replica
if(t_replica_resolved_output) then
write(stdout,*) "============================================================="
write(stdout,*) "Reference and leading determinants for replica",run
write(stdout,*) "============================================================="
end if
if(t_replica_resolved_output) then
this_run = run
offset = rep_size * (run - 1)
else
this_run = GLOBAL_RUN
offset = 0
end if
call global_most_populated_states(iHighPopWrite, this_run, GlobalLargestWalkers, &
norm, rank_of_largest=GlobalProc, hdiag_largest=GlobalHdiag)
! This has to be done by all procs
if(tAdiActive) call update_ref_signs()
if(iProcIndex.eq.Root) then
!Now print out the info contained in GlobalLargestWalkers and GlobalProc
counter=0
do i=1,iHighPopWrite
!How many non-zero determinants do we actually have?
call extract_sign(GlobalLargestWalkers(:,i),SignCurr)
HighSign = core_space_weight(SignCurr,this_run)
if (HighSign > eps_high) counter = counter + 1
end do
write(stdout,*) ""
if (tReplicaReferencesDiffer) then
write(stdout,'(A)') "Current references: "
call write_det(stdout, ProjEDet(:,run), .true.)
call writeDetBit(stdout, ilutRef(:, run), .true.)
else
write(stdout,'(A)') "Current reference: "
call write_det (stdout, ProjEDet(:,1), .true.)
if(tSetupSIs) call print_reference_notification(&
1,nRefs,"Used Superinitiator",.true.)
write(stdout,*) "Number of superinitiators", nRefs
end if
write(stdout,*)
write(stdout,'("Input DEFINEDET line (includes frozen orbs):")')
write(stdout,'("definedet ")', advance='no')
if (allocated(frozen_orb_list)) then
allocate(tmp_ni(nel_pre_freezing))
tmp_ni(1:nel) = frozen_orb_reverse_map(ProjEDet(:,run))
if (nel /= nel_pre_freezing) &
tmp_ni(nel+1:nel_pre_freezing) = frozen_orb_list
call sort(tmp_ni)
call writeDefDet(tmp_ni, nel_pre_freezing)
! do i = 1, nel_pre_freezing
! write(stdout, '(i3," ")', advance='no') tmp_ni(i)
! end do
deallocate(tmp_ni)
else
call writeDefDet(ProjEDet(:,run), nel)
! do i = 1, nel
! write(stdout, '(i3," ")', advance='no') ProjEDet(i, run)
! end do
end if
do i = 1, nel
full_orb = ProjEDet(i, run)
if (allocated(frozen_orb_list)) &
full_orb = full_orb + count(frozen_orb_list <= ProjEDet(i, run))
end do
write(stdout,*)
write(stdout,*) ""
write(stdout,"(A,I10,A)") "Most occupied ",counter," determinants as excitations from reference: "
write(stdout,*)
if(lenof_sign.eq.1) then
if(tHPHF) then
write(stdout,"(A)") " Excitation ExcitLevel Seniority Walkers Amplitude Init? <D|H|D> Proc Spin-Coup?"
else
write(stdout,"(A)") " Excitation ExcitLevel Seniority Walkers Amplitude Init? <D|H|D> Proc"
end if
else
#ifdef CMPLX_
if(tHPHF) then
write(stdout,"(A)") " Excitation ExcitLevel Seniority Walkers(Re) Walkers(Im) Weight &
&Init?(Re) Init?(Im) <D|H|D> Proc Spin-Coup?"
else
write(stdout,"(A)") " Excitation ExcitLevel Seniority Walkers(Re) Walkers(Im) Weight &
&Init?(Re) Init?(Im) <D|H|D> Proc"
end if
#else
! output the weight of every replica, and do not only assume
! it is a complex run
do i = 1, lenof_out
write(walker_string(i), '(a,i0,a)') "Walkers(", i, ")"
! write(amplitude_string(i), '(a,i0,a)') "Amplitude(", i, ")"
write(init_string(i), '(a,i0,a)') "Init?(", i, ")"
end do
block
character(:), allocatable :: fmt_str
fmt_str = '(3a11,' // str(lenof_out) // 'a11, a13,' // str(lenof_out) // 'a9,1x,16a,1x,a)'
write(header, fmt_str) "Excitation ", "ExcitLevel ", "Seniority ", &
walker_string, "Amplitude ", init_string, "<D|H|D>", "Proc "
end block
if (tHPHF) then
header = trim(header) // " Spin-Coup?"
end if
write(stdout, '(a)') trim(header)
#endif
end if
do i=1,iHighPopWrite
call extract_sign(GlobalLargestWalkers(:,i),SignCurr)
HighSign = core_space_weight(SignCurr,this_run)
if(HighSign < eps_high) cycle
call WriteDetBit(stdout,GlobalLargestWalkers(:,i),.false.)
if (tGUGA) then
excitInfo = identify_excitation(iLutRef(:,1), GlobalLargestWalkers(:,i))
excitLev = excitInfo%excitLvl
else
Excitlev=FindBitExcitLevel(iLutRef(:,1),GlobalLargestWalkers(:,i),nEl,.true.)
end if
write(stdout,"(I5)",advance='no') Excitlev
nopen=count_open_orbs(GlobalLargestWalkers(:,i))
write(stdout,"(I5)",advance='no') nopen
do j=1,lenof_out
write(stdout,"(G16.7)",advance='no') SignCurr(j+offset)
end do
if(tHPHF.and.(.not.TestClosedShellDet(GlobalLargestWalkers(:,i)))) then
!Weight is proportional to (nw/sqrt(2))**2
write(stdout,"(F9.5)",advance='no') ((HighSign/sqrt(2.0_dp))/norm )
else
write(stdout,"(F9.5)",advance='no') (HighSign/norm)
end if
do j=1,lenof_out
if(.not.tTruncInitiator) then
write(stdout,"(A3)",advance='no') 'Y'
else
if(test_flag(GlobalLargestWalkers(:,i),get_initiator_flag(j+offset))) then
write(stdout,"(A3)",advance='no') 'Y'
else
write(stdout,"(A3)",advance='no') 'N'
end if
end if
end do
write(stdout,"(1x,es16.8,1x)",advance='no') GlobalHdiag(i)
if(tHPHF.and.(.not.TestClosedShellDet(GlobalLargestWalkers(:,i)))) then
write(stdout,"(I7)",advance='no') GlobalProc(i)
write(stdout,"(A3)") "*"
else
write(stdout,"(I7)") GlobalProc(i)
end if
end do
! Keep the reference weight in a separate output variable
! which can be accessed from the library wrappers
call extract_sign(GlobalLargestWalkers(:,1),SignCurr)
fciqmc_run_ref_weight = SignCurr(1)
if(tHPHF) then
write(stdout,"(A)") " * = Spin-coupled function implicitly has time-reversed determinant with same weight."
end if
write(stdout,*) ""
end if
! Only continue if printing the replica-resolved output
if(.not. t_replica_resolved_output) exit
end do
deallocate(GlobalLargestWalkers,GlobalProc,GlobalHdiag)
deallocate(walker_string, init_string)
contains
subroutine writeDefDet(defdet, numEls)
implicit none
integer, intent(in) :: numEls
integer, intent(in) :: defdet(:)
logical :: nextInRange, previousInRange
do i = 1, numEls
! if the previous orbital is in the same contiguous range
if (i == 1) then
! for the first one, there is no previous one
previousInRange = .false.
else
previousInRange = defdet(i) == defdet(i-1) + 1
end if
! if the following orbital is in the same contiguous range
if(i.eq.numEls) then
! there is no following orbital
nextInRange = .false.
else
nextInRange = defdet(i).eq.defdet(i+1)-1
end if
! there are three cases that need output:
! the last orbital of a contigous range of orbs
if(previousInRange .and. .not.nextInRange) then
write(bufEnd,'(i3)') defdet(i)
lenEnd = len_trim(bufEnd)
bufStart(lenStart+2:lenStart+lenEnd+1) = adjustl(trim(bufEnd))
write(stdout,'(A7)',advance='no') trim(adjustl(bufStart))
! the first orbital of a contiguous range of orbs
else if(.not.previousInRange .and. nextInRange) then
write(bufStart,'(i3)') defdet(i)
lenStart = len_trim(bufStart)
bufStart(lenStart+1:lenStart+1) = "-"
! and an orbital not in any range
else if(.not.previousInRange .and. .not.nextInRange) then
write(stdout,'(i3," ")', advance='no') defdet(i)
end if
end do
end subroutine writeDefDet
END SUBROUTINE PrintHighPops