subroutine ESMF_ReconcileCompareNeeds (vm, id, vmid, id_info, rc)
!
! !ARGUMENTS:
type(ESMF_VM), intent(in) :: vm
integer, intent(in) :: id(0:)
integer, intent(in) :: vmid(0:)
type(ESMF_ReconcileIDInfo), intent(inout) :: id_info(0:)
integer, intent(out) :: rc
!
! !DESCRIPTION:
!
! Calculates which PETs have items that this PET needs. When a given item is
! offered by multiple PETs, a heuristic is used to determine which PET will
! provide it in order to try to avoid 'hot spotting' the offering PET.
!
! The arguments are:
! \begin{description}
! \item[vm]
! The current {\tt ESMF\_VM} (virtual machine).
! \item[id]
! The object ids of this PETs State itself (in element 0) and the items
! contained within it. It does not return the IDs of nested State
! items.
! \item[vmid]
! The integer VMIds of this PETs State itself (in element 0) and the items
! contained within it. It does not return the IDs of nested State
! items.
! \item[id_info]
! Array of arrays of global VMId info. Upon input, the array has a size
! of numPets, and each element points to Id/VMId arrays. Returns 'needed'
! flag for each desired object.
! \item[rc]
! Return code; equals {\tt ESMF\_SUCCESS} if there are no errors.
! \end{description}
!EOPI
integer :: localrc
integer :: memstat
integer :: mypet, npets
integer :: i, j, k
logical :: needed
character(ESMF_MAXSTR) :: msgstring
type NeedsList_t
integer :: id
integer :: vmid
logical, pointer :: offerers(:) => null ()
integer, pointer :: position(:) => null ()
type(NeedsList_t), pointer :: next => null ()
end type
type(NeedsList_t), pointer :: needs_list
logical, parameter :: debug = .false.
! Sanity checks
call ESMF_VMGet (vm, localPet=mypet, petCount=npets, rc=localrc)
if (ESMF_LogFoundError (localrc, ESMF_ERR_PASSTHRU, &
ESMF_CONTEXT, &
rcToReturn=rc)) return
if (size (id) /= size (vmid)) then
if (ESMF_LogFoundError (ESMF_RC_INTNRL_INCONS, msg='size (id) /= size (vmid)', &
ESMF_CONTEXT, &
rcToReturn=rc)) return
end if
if (size (id_info) /= npets) then
if (ESMF_LogFoundError (ESMF_RC_INTNRL_INCONS, msg='size (id_info) /= npets', &
ESMF_CONTEXT, &
rcToReturn=rc)) return
end if
if (debug) then
print *, ' PET ', mypet, ': id/vmid sizes =', size (id), size (vmid)
end if
! Check other PETs contents to see if there are objects this PET needs
! When 'needed' ID/VMId pairs are found, create a list of 'offering' PETs who can
! provide it.
needs_list => null ()
! call ESMF_ReconcileDebugPrint (ESMF_METHOD // &
! ': computing id_info%needed')
do, i=0, npets-1
id_info(i)%needed = .false.
if (i == mypet) cycle
do, j = 1, ubound (id_info(i)%id, 1)
needed = .true.
! print *, ' PET', mypet, ': setting needed to .true.', j, k
do, k = 1, ubound (id, 1)
if (id(k) == id_info(i)%id(j)) then
if (vmid(k) == id_info(i)%vmid(j)) then
! print *, ' PET', mypet, ': setting needed to .false.', j, k
needed = .false.
exit
end if
end if
end do
if (needed) then
! print *, ' PET', mypet, ': calling insert, associated =', associated (needs_list)
call needs_list_insert (needs_list, pet_1=i, &
id_1=id_info(i)%id(j), &
vmid_1=id_info(i)%vmid(j), &
position=j, rc_1=localrc)
if (ESMF_LogFoundError (localrc, ESMF_ERR_PASSTHRU, &
ESMF_CONTEXT, &
rcToReturn=rc)) return
end if
end do
end do
if (debug) call needs_list_print (needs_list)
! Go through the list of needed IDs/VMIds and select an offerer for each.
call needs_list_select (needs_list, id_info)
call needs_list_deallocate (needs_list, rc_1=localrc)
if (ESMF_LogFoundError (localrc, ESMF_ERR_PASSTHRU, &
ESMF_CONTEXT, &
rcToReturn=rc)) return
if (associated (needs_list)) then
deallocate (needs_list, stat=memstat)
if (ESMF_LogFoundDeallocError (memstat, ESMF_ERR_PASSTHRU, &
ESMF_CONTEXT, &
rcToReturn=rc)) return
end if
if (debug) then
do, j=0, npets-1
if (j == myPet) then
do, i=0, ubound (id_info, 1)
write (msgstring,'(2a,i0,a,i0,a)') ESMF_METHOD, &
': pet', j, ': id_info%needed(',i,') ='
write (6,*) msgstring, id_info(i)%needed
call ESMF_UtilIOUnitFlush (ESMF_UtilIOStdout)
end do
end if
call ESMF_VMBarrier (vm)
end do
end if
rc = localrc
contains
recursive subroutine needs_list_deallocate (needs_list_1, rc_1)
type(NeedsList_t), pointer :: needs_list_1 ! intent(inout)
integer :: rc_1
integer :: localrc_1
integer :: memstat_1
if (.not. associated (needs_list_1)) then
rc_1 = ESMF_SUCCESS
return
end if
deallocate ( &
needs_list_1%offerers, &
needs_list_1%position, &
stat=memstat_1)
if (ESMF_LogFoundDeallocError (memstat_1, ESMF_ERR_PASSTHRU, &
ESMF_CONTEXT, &
rcToReturn=rc_1)) return
if (associated (needs_list_1%next)) then
! print *, 'pet', mypet, ': needs_list_deallocate: recursing'
call needs_list_deallocate (needs_list_1%next, rc_1=localrc_1)
if (ESMF_LogFoundError (localrc_1, ESMF_ERR_PASSTHRU, &
ESMF_CONTEXT, &
rcToReturn=rc_1)) return
deallocate (needs_list_1%next, &
stat=memstat_1)
if (ESMF_LogFoundDeallocError (memstat_1, ESMF_ERR_PASSTHRU, &
ESMF_CONTEXT, &
rcToReturn=rc_1)) return
end if
rc_1 = ESMF_SUCCESS
end subroutine needs_list_deallocate
subroutine needs_list_insert (needs_list_1, pet_1, &
id_1, vmid_1, position, rc_1)
type(NeedsList_t), pointer :: needs_list_1 ! intent(inout)
integer, intent(in) :: pet_1
integer, intent(in) :: id_1
integer, intent(in) :: vmid_1
integer, intent(in) :: position
integer, intent(out):: rc_1
type(NeedsList_t), pointer :: needslist_p
integer :: memstat_1
! Called when a Id/VMId is offered by some remote PET, and is needed
! by the local PET.
!
! If the Id/VMId is not in the needs list, create a new needs_list
! entry. If it is present, add that this PET is also offering it.
rc_1 = ESMF_SUCCESS
if (.not. associated (needs_list_1)) then
! print *, 'pet', mypet, ': needs_list_insert: creating needs_list_1'
allocate (needs_list_1, stat=memstat_1)
if (ESMF_LogFoundAllocError (memstat_1, ESMF_ERR_PASSTHRU, &
ESMF_CONTEXT, &
rcToReturn=rc_1)) return
allocate ( &
needs_list_1%offerers(0:npets-1), &
needs_list_1%position(0:npets-1), &
stat=memstat_1)
if (ESMF_LogFoundAllocError (memstat_1, ESMF_ERR_PASSTHRU, &
ESMF_CONTEXT, &
rcToReturn=rc_1)) return
needs_list_1%offerers = .false.
needs_list_1%position = 0
needs_list_1%id = id_1
needs_list_1%vmid = vmid_1
needs_list_1%offerers(pet_1) = .true.
needs_list_1%position(pet_1) = position
return
end if
needslist_p => needs_list_1
do
if (id_1 == needslist_p%id .and. &
vmid_1 == needslist_p%vmid) then
! print *, 'pet', mypet, ': needs_list_insert: marking match and returing'
needslist_p%offerers(pet_1) = .true.
needslist_p%position(pet_1) = position
return
end if
if (.not. associated (needslist_p%next)) exit
! print *, 'pet', mypet, ': needs_list_insert: advancing to next entry'
needslist_p => needslist_p%next
end do
! At the end of the list, but no matches found. So add new entry.
! print *, 'pet', mypet, ': needs_list_insert: creating needslist_p entry'
allocate (needslist_p%next, stat=memstat_1)
if (ESMF_LogFoundAllocError (memstat_1, ESMF_ERR_PASSTHRU, &
ESMF_CONTEXT, &
rcToReturn=rc_1)) return
needslist_p => needslist_p%next
allocate ( &
needslist_p%offerers(0:npets-1), &
needslist_p%position(0:npets-1), &
stat=memstat_1)
if (ESMF_LogFoundAllocError (memstat_1, ESMF_ERR_PASSTHRU, &
ESMF_CONTEXT, &
rcToReturn=rc_1)) return
needslist_p%offerers = .false.
needslist_p%position = 0
needslist_p%id = id_1
needslist_p%vmid = vmid_1
needslist_p%offerers(pet_1) = .true.
needslist_p%position(pet_1) = position
end subroutine needs_list_insert
subroutine needs_list_print (needs_list_1)
type(NeedsList_t), pointer :: needs_list_1 ! intent(in)
type(NeedsList_t), pointer :: needs_list_next
integer :: i
call ESMF_UtilIOUnitFlush (ESMF_UtilIOStdout)
call ESMF_VMBarrier (vm)
do, i=0, npets-1
if (i == mypet) then
if (associated (needs_list_1)) then
needs_list_next => needs_list_1
do
print *, 'PET', mypet, ': offerers =', needs_list_next%offerers, &
', position =', needs_list_next%position
if (.not. associated (needs_list_next%next)) exit
needs_list_next => needs_list_next%next
end do
else
print *, 'PET', mypet, ': Needs list empty'
end if
call ESMF_UtilIOUnitFlush (ESMF_UtilIOStdout)
end if
call ESMF_VMBarrier (vm)
end do
end subroutine needs_list_print
subroutine needs_list_select (needs_list_1, id_info_1)
type(needsList_t), pointer :: needs_list_1 ! intent(in)
type(ESMF_ReconcileIDInfo), intent(inout) :: id_info_1(0:)
! For each needed Id/VMId pair, select an offering PET and set it in
! the id_info_array.
type(needsList_t), pointer :: needslist_p
integer :: i, idx
integer :: offer_first, offer_last
logical :: found_first
real :: rand_nos(0:npets-1)
needslist_p => needs_list_1
#if 1
! Try to load distribute by starting at a point in the offerer list
! bounded by the first and last offering PETs, and using a hash based
! on PETs position in a pseudo-random number table.
call random_number (rand_nos)
do
if (.not. associated (needslist_p)) exit
! Find first and last offering PETs
offer_first = 0
offer_last = npets-1
found_first = .false.
do, i=0, npets-1
if (needslist_p%offerers(i)) then
if (.not. found_first) then
offer_first = i
found_first = .true.
end if
offer_last = i
end if
end do
! Use a hash to select a starting index between the bounds
idx = int (rand_nos(myPet) * (offer_last-offer_first) + offer_first)
! print *, 'pet', mypet, ': offer_first, offer_last, starting idx =', offer_first, offer_last, idx
do, i=0, npets-1
if (needslist_p%offerers(idx)) then
! print *, 'pet', mypet, ': needs_list_select: setting position', idx, ' to true'
id_info_1(idx)%needed(needslist_p%position(idx)) = .true.
exit
end if
idx = mod (idx+1, npets)
end do
needslist_p => needslist_p%next
end do
#else
! Simply select the first offering PET.
do
if (.not. associated (needslist_p)) exit
do, i=0, npets-1
if (needslist_p%offerers(i)) then
! print *, 'pet', mypet, ': needs_list_select: setting position', i, ' to true'
id_info_1(i)%needed(needslist_p%position(i)) = .true.
exit
end if
end do
needslist_p => needslist_p%next
end do
#endif
end subroutine needs_list_select
end subroutine ESMF_ReconcileCompareNeeds