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