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, still_print_civec real(dp), parameter :: eps_high = 1.0e-7_dp type(ExcitationInformation_t) :: excitInfo integer :: civec_unit(inum_runs), null_unit, highpopwrite_unit allocate(GlobalLargestWalkers(0:NIfTot,max(iHighPopWrite, iNumCITermsPrinted)), source=0_n_int) allocate(GlobalHdiag(max(iHighPopWrite, iNumCITermsPrinted)), source=0.0_dp) allocate(GlobalProc(max(iHighPopWrite, iNumCITermsPrinted)), 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)) null_unit = get_free_unit() open(null_unit, file="/dev/null", status="old", action="write") replica_loop: 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(max(iNumCITermsPrinted, 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 if (tPrintCIVec) then civec_unit(run) = get_free_unit() open(civec_unit(run), file="NECIVEC_"//str(run), status="UNKNOWN") write(civec_unit(run), '(A15, A30)') '# CI coeff.', 'excitation' end if highpopwrite_unit = stdout do i=1, max(iNumCITermsPrinted, iHighPopWrite) if (i > iHighPopWrite) highpopwrite_unit = null_unit still_print_civec = tPrintCIVec .and. i <= iNumCITermsPrinted call extract_sign(GlobalLargestWalkers(:,i),SignCurr) HighSign = core_space_weight(SignCurr,this_run) if(HighSign < eps_high) cycle call WriteDetBit(highpopwrite_unit,GlobalLargestWalkers(:,i),.false.) if (tGUGA) then excitInfo = identify_excitation(iLutRef(:,run), GlobalLargestWalkers(:,i)) excitLev = excitInfo%excitLvl else Excitlev=FindBitExcitLevel(iLutRef(:,run),GlobalLargestWalkers(:,i),nEl,.true.) end if write(highpopwrite_unit,"(I5)",advance='no') Excitlev nopen=count_open_orbs(GlobalLargestWalkers(:,i)) write(highpopwrite_unit,"(I5)",advance='no') nopen do j=1,lenof_out write(highpopwrite_unit,"(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(highpopwrite_unit,"(F9.5)",advance='no') ((HighSign/sqrt(2.0_dp))/norm ) if (still_print_civec) then do j=1,lenof_out write(civec_unit(run), "(E30.12)", advance='no') ((SignCurr(j+offset)/sqrt(2.0_dp))/norm ) end do end if else write(highpopwrite_unit,"(F9.5)",advance='no') (HighSign/norm) if (still_print_civec) then do j=1,lenof_out write(civec_unit(run), "(E30.12)", advance='no') SignCurr(j+offset)/norm end do end if end if if (still_print_civec) then write(civec_unit(run), "(A4)", advance='no') " " call WriteDetBit(civec_unit(run), GlobalLargestWalkers(:,i), .true.) end if do j=1,lenof_out if(.not.tTruncInitiator) then write(highpopwrite_unit,"(A3)",advance='no') 'Y' else if(test_flag(GlobalLargestWalkers(:,i),get_initiator_flag(j+offset))) then write(highpopwrite_unit,"(A3)",advance='no') 'Y' else write(highpopwrite_unit,"(A3)",advance='no') 'N' end if end if end do write(highpopwrite_unit,"(1x,es16.8,1x)",advance='no') GlobalHdiag(i) if(tHPHF.and.(.not.TestClosedShellDet(GlobalLargestWalkers(:,i)))) then write(highpopwrite_unit,"(I7)",advance='no') GlobalProc(i) write(highpopwrite_unit,"(A3)") "*" else write(highpopwrite_unit,"(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 if(tPrintCIVec) then close(civec_unit(run)) end if ! Only continue if printing the replica-resolved output if(.not. t_replica_resolved_output) exit end do replica_loop deallocate(GlobalLargestWalkers,GlobalProc,GlobalHdiag) deallocate(walker_string, init_string) close(null_unit) 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