subroutine population_check()
use HPHFRandExcitMod, only: ReturnAlphaOpenDet
integer(int32) :: pop_highest(inum_runs), proc_highest(inum_runs)
real(dp) :: pop_change, old_Hii
integer :: det(nel), i, error, ierr, run
integer(int32) :: int_tmp(2)
logical :: tSwapped, allocate_temp_parts, changed_any
HElement_t(dp) :: h_tmp
character(*), parameter :: this_routine = 'population_check'
character(*), parameter :: t_r = this_routine
! If we aren't doing this, then bail out...
if (.not. tCheckHighestPop) return
! If we are accumulating RDMs, then a temporary spawning array is
! required of <~ the size of the largest occupied det.
!
! This memory holds walkers spawned from one determinant. This
! allows us to test if we are spawning onto the same Dj multiple
! times. If only using connections to the HF (tHF_Ref_Explicit)
! no stochastic RDM construction is done, and this is not
! necessary.
if (tRDMOnFly .and. .not. tExplicitAllRDM) then
! Test if we need to allocate or re-allocate the temporary
! spawned parts array
allocate_temp_parts = .false.
if (.not. allocated(TempSpawnedParts)) then
allocate_temp_parts = .true.
TempSpawnedPartsSize = 1000
end if
if (1.5 * maxval(iHighestPop) > TempSpawnedPartsSize) then
! This testing routine is only called once every update
! cycle. The 1.5 gives us a buffer to cope with particle
! growth
TempSpawnedPartsSize = int(maxval(iHighestPop) * 1.5)
allocate_temp_parts = .true.
!write(stdout,*) 1.5 * maxval(iHighestPop), TempSpawnedPartsSize
end if
! If we need to allocate this array, then do so.
if (allocate_temp_parts) then
if (allocated(TempSpawnedParts)) then
deallocate(TempSpawnedParts)
log_dealloc(TempSpawnedPartsTag)
end if
allocate(TempSpawnedParts(0:nifd, TempSpawnedPartsSize), &
stat=ierr, source=0_n_int)
call LogMemAlloc('TempSpawnedParts', size(TempSpawnedParts, kind=int64), size_per_element(TempSpawnedParts), &
this_routine, TempSpawnedPartsTag, ierr)
write (stdout, "(' Allocating temporary array for walkers spawned &
&from a particular Di.')")
write(stdout, "(a,f14.6,a)") " This requires ", &
real(((nifd + 1) * TempSpawnedPartsSize * size_n_int), dp) &
/ 1048576.0_dp, " Mb/Processor"
end if
end if ! Allocating memory for RDMs
! Obtain the determinant (and its processor) with the highest pop
! in each of the runs.
! n.b. the use of int(iHighestPop) obviously introduces a small amount
! of error here, by ignoring the fractional part...
! [Werner Dobrautz 15.5.2017:]
! maybe this samll error here is the cause of the failed test_suite
! runs..
if (tReplicaReferencesDiffer) then
do run = 1, inum_runs
call MPIAllReduceDatatype( &
(/int(iHighestPop(run), int32), int(iProcIndex, int32)/), 1, &
MPI_MAXLOC, MPI_2INTEGER, int_tmp)
pop_highest(run) = int_tmp(1)
proc_highest(run) = int_tmp(2)
end do
else
call MPIAllReduceDatatype( &
(/int(iHighestPop(1), int32), int(iProcIndex, int32)/), 1, &
MPI_MAXLOC, MPI_2INTEGER, int_tmp)
pop_highest = int_tmp(1)
proc_highest = int_tmp(2)
end if
changed_any = .false.
do run = 1, inum_runs
! If using the same reference for all, then we don't consider the
! populations seperately...
if (run /= 1 .and. .not. tReplicaReferencesDiffer) &
exit
! What are the change conditions?
#ifdef CMPLX_
if (tReplicaReferencesDiffer) then
pop_change = FracLargerDet * abs_sign(AllNoAtHF(min_part_type(run):max_part_type(run)))
else
pop_change = FracLargerDet * abs_sign(AllNoAtHF(1:(lenof_sign / inum_runs)))
end if
#else
if (tReplicaReferencesDiffer) then
pop_change = FracLargerDet * abs(AllNoAtHF(run))
else
pop_change = FracLargerDet * abs(AllNoAtHF(1))
end if
#endif
! write(stdout,*) "***",AllNoAtHF,FracLargerDet,pop_change, pop_highest,proc_highest
! Do we need to do a change?
! is this a valid comparison?? we ware comparing a real(dp) pop_change
! with a (now) 32 bit integer..
if (pop_change < real(pop_highest(run), dp) .and. &
real(pop_highest(run), dp) > pop_change_min) then
if (tChangeProjEDet) then
! Write out info!
changed_any = .true.
root_print 'Highest weighted determinant on run', run, &
'not reference det: ', pop_highest, abs_sign(AllNoAtHF( &
min_part_type(run):max_part_type(run)))
!
! Here we are changing the reference det on the fly.
! --> else block for restarting simulation.
!
! Communicate the change to all dets and print out.
! [W.D. 15.5.2017:]
! we are typecasting here too..
! we are casting a 32 bit int to a 64 bit ...
! that could cause troubles!
! call MPIBcast (HighestPopDet(0:NIfTot, run), NIfTot+1, &
! int(proc_highest(run),n_int))
call MPIBcast(HighestPopDet(0:NIfTot, run), NIfTot + 1, &
int(proc_highest(run)))
call update_run_reference(HighestPopDet(:, run), run)
! Reset averages
SumENum = 0.0_dp
sum_proje_denominator = 0.0_dp
cyc_proje_denominator = 0.0_dp
SumNoatHF = 0.0_dp
VaryShiftCycles = 0
SumDiagSft = 0.0_dp
root_print 'Zeroing all energy estimators.'
!Since we have a new reference, we must block only from after this point
iBlockingIter = Iter + PreviousCycles
! Reset values introduced in soft_exit (CHANGEVARS)
if (tCHeckHighestPopOnce) then
tChangeProjEDet = .false.
tCheckHighestPop = .false.
tCheckHighestPopOnce = .false.
end if
! Or are we restarting the calculation with the reference
! det switched?
#ifdef CMPLX_
else if (tRestartHighPop .and. &
iRestartWalkNum < sum(AllTotParts(1:2))) then
#else
else if (tRestartHighPop .and. &
iRestartWalkNum < AllTotParts(1)) then
#endif
!
! Here we are restarting the simulation with a new
! reference. See above block for doing it on the fly.
!
! Broadcast the changed det to all processors
! call MPIBcast (HighestPopDet(:,run), NIfTot+1, &
! int(proc_highest(run),n_int))
call MPIBcast(HighestPopDet(:, run), NIfTot + 1, &
int(proc_highest(run)))
call update_run_reference(HighestPopDet(:, run), run)
! Only update the global reference energies if they
! correspond to run 1 (which is used for those)
if (run == 1) then
call ChangeRefDet(ProjEDet(:, 1))
end if
! Reset values introduced in soft_exit (CHANGEVARS)
if (tCHeckHighestPopOnce) then
tChangeProjEDet = .false.
tCheckHighestPop = .false.
tCheckHighestPopOnce = .false.
end if
end if
end if
end do
end subroutine population_check