subroutine ESMF_ReconcileSerialize (state, vm, siwrap, &
needs_list, attreconflag, &
id_info, rc)
!
! !ARGUMENTS:
type (ESMF_State), intent(in) :: state
type (ESMF_VM), intent(in) :: vm
type (ESMF_StateItemWrap), intent(in) :: siwrap(:)
logical, intent(in) :: needs_list(:,0:)
type(ESMF_AttReconcileFlag),intent(in) :: attreconflag
type(ESMF_ReconcileIDInfo), intent(inout) :: id_info(0:)
integer, intent(out) :: rc
!
! !DESCRIPTION:
!
! The arguments are:
! \begin{description}
! \item[state]
! {\tt ESMF\_State} to collect information from.
! \item[siwrap]
! State items in the state.
! \item[needs\_list]
! List of State items that need to be sent to other PETs
! \item[attreconflag]
! Flag to indicate attribute reconciliation.
! \item[id\_info]
! IDInfo array containing buffers of serialized State objects (intent(out))
! \item[rc]
! Return code; equals {\tt ESMF\_SUCCESS} if there are no errors.
! \end{description}
!EOPI
integer :: localrc
integer :: memstat
type PetNeeds_t
logical :: needed = .false.
integer :: obj_type
character(1), pointer :: obj_buffer(:) => null ()
integer :: buffer_size = 0 ! Actual space used in obj_buffer. May be
! smaller than size(obj_buffer)
end type
type(PetNeeds_t), allocatable :: pet_needs(:)
character(1), pointer :: obj_buffer(:)
integer, allocatable :: type_table(:)
type(ESMF_StateItem), pointer :: stateitem
type(ESMF_InquireFlag) :: inqflag
type(ESMF_State) :: wrapper
integer :: buffer_offset
integer :: needs_count
integer :: item, nitems
integer :: lbufsize
integer :: pass
character(ESMF_MAXSTR) :: errstring
integer :: i
integer :: mypet, npets, pet
logical, parameter :: debug=.false.
logical, parameter :: trace=.false.
character(len=ESMF_MAXSTR) :: logmsg
integer :: needs_count_debug
localrc = ESMF_RC_NOT_IMPL
call ESMF_VMGet(vm, localPet=mypet, petCount=npets, rc=localrc)
if (ESMF_LogFoundError(localrc, ESMF_ERR_PASSTHRU, &
ESMF_CONTEXT, &
rcToReturn=rc)) return
! Sanity check: siwrap and needs list must be the same size.
if (ubound (siwrap, 1) /= ubound (needs_list, 1)) then
write (errstring, '(a,i0,a,i0)') &
'siwrap ubound =', ubound (siwrap, 1), &
'/= needs_list ubound =', ubound (needs_list, 1)
call ESMF_LogWrite (msg=errstring, logmsgFlag=ESMF_LOGMSG_ERROR, ESMF_CONTEXT)
if (ESMF_LogFoundError(ESMF_RC_INTNRL_INCONS, &
msg="ubound (siwrap) /= ubound (needs_list)", &
ESMF_CONTEXT, &
rcToReturn=rc)) return
end if
nitems = size (siwrap)
! Find the union of all the needs for this PET.
if (trace) then
call ESMF_ReconcileDebugPrint (ESMF_METHOD // &
': *** Step 1 - Find union of needs')
end if
allocate (pet_needs(nitems), &
stat=memstat)
if (ESMF_LogFoundAllocError(memstat, ESMF_ERR_PASSTHRU, &
ESMF_CONTEXT, &
rcToReturn=rc)) return
do, i=1, nitems
pet_needs(i)%needed = any (needs_list(i,:))
end do
if (debug) then
print *, ' PET', mypet, &
': needed_items array: ', pet_needs%needed
end if
! Serialize all needed objects
if (trace) then
call ESMF_ReconcileDebugPrint (ESMF_METHOD // &
': *** Step 2 - Serialize all needed objects')
end if
allocate (type_table(nitems), &
stat=memstat)
if (ESMF_LogFoundAllocError(memstat, ESMF_ERR_PASSTHRU, &
ESMF_CONTEXT, &
rcToReturn=rc)) return
item_loop: &
do, item = 1, nitems
! Make two passes through each needed item. The first time to calculate
! the size of the buffer, and the second time to perform the actual
! serialization.
if (.not. pet_needs(item)%needed) cycle item_loop
pass_loop: &
do, pass = 1, 2
select case (pass)
! Pass 1 finds the required buffer length to serialize the item.
case (1)
! Allocate a very small buffer to avoid possible null pointer
! references in the serialization routines.
inqflag = ESMF_INQUIREONLY
allocate (obj_buffer(0:ESMF_SIZEOF_DEFINT-1), stat=memstat)
if (ESMF_LogFoundAllocError(memstat, ESMF_ERR_PASSTHRU, &
ESMF_CONTEXT, &
rcToReturn=rc)) return
buffer_offset = 0
! Pass 2 performs the actual serialization.
case (2)
inqflag = ESMF_NOINQUIRE
deallocate (obj_buffer, stat=memstat)
if (ESMF_LogFoundDeallocError(memstat, ESMF_ERR_PASSTHRU, &
ESMF_CONTEXT, &
rcToReturn=rc)) return
if (debug) then
print *, ESMF_METHOD, ': allocating obj_buffer bounds = (0:', buffer_offset-1, ')'
end if
allocate (obj_buffer(0:buffer_offset-1), stat=memstat)
if (ESMF_LogFoundAllocError(memstat, ESMF_ERR_PASSTHRU, &
ESMF_CONTEXT, &
rcToReturn=rc)) return
buffer_offset = 0
end select
lbufsize = size (obj_buffer)
stateitem => siwrap(item)%si
type_table(item) = stateitem%otype%ot
! serialize item
select case (stateitem%otype%ot)
case (ESMF_STATEITEM_FIELDBUNDLE%ot)
if (debug) then
print *, ' PET', mypet, &
': serializing FieldBundle, pass =', pass, ', offset =', buffer_offset
end if
call ESMF_FieldBundleSerialize(stateitem%datap%fbp, &
obj_buffer, lbufsize, buffer_offset, &
attreconflag=attreconflag, inquireflag=inqflag, &
rc=localrc)
if (ESMF_LogFoundError(localrc, ESMF_ERR_PASSTHRU, &
ESMF_CONTEXT, &
rcToReturn=rc)) return
case (ESMF_STATEITEM_FIELD%ot)
if (debug) then
print *, ' PET', mypet, &
': serializing Field, pass =', pass, ', offset =', buffer_offset
end if
call ESMF_FieldSerialize(stateitem%datap%fp, &
obj_buffer, lbufsize, buffer_offset, &
attreconflag=attreconflag, inquireflag=inqflag, &
rc=localrc)
if (ESMF_LogFoundError(localrc, ESMF_ERR_PASSTHRU, &
ESMF_CONTEXT, &
rcToReturn=rc)) return
case (ESMF_STATEITEM_ARRAY%ot)
if (debug) then
print *, ' PET', mypet, &
': serialized Array, pass =', pass, ', offset =', buffer_offset
end if
call c_ESMC_ArraySerialize(stateitem%datap%ap, &
obj_buffer, lbufsize, buffer_offset, &
attreconflag, inqflag, &
localrc)
if (ESMF_LogFoundError(localrc, ESMF_ERR_PASSTHRU, &
ESMF_CONTEXT, &
rcToReturn=rc)) return
case (ESMF_STATEITEM_ARRAYBUNDLE%ot)
if (debug) then
print *, ' PET', mypet, &
': serializing ArrayBundle, pass =', pass, ', offset =', buffer_offset
end if
call c_ESMC_ArrayBundleSerialize(stateitem%datap%abp, &
obj_buffer, lbufsize, buffer_offset, &
attreconflag, inqflag, &
localrc)
if (ESMF_LogFoundError(localrc, ESMF_ERR_PASSTHRU, &
ESMF_CONTEXT, &
rcToReturn=rc)) return
case (ESMF_STATEITEM_STATE%ot)
if (debug) then
print *, ' PET', mypet, &
': serializing subState, pass =', pass, ', offset =', buffer_offset
end if
wrapper%statep => stateitem%datap%spp
ESMF_INIT_SET_CREATED(wrapper)
call ESMF_StateSerialize(wrapper, &
obj_buffer, lbufsize, buffer_offset, &
attreconflag=attreconflag, inquireflag=inqflag, &
rc=localrc)
if (ESMF_LogFoundError(localrc, ESMF_ERR_PASSTHRU, &
ESMF_CONTEXT, &
rcToReturn=rc)) return
case (ESMF_STATEITEM_ROUTEHANDLE%ot)
if (debug) then
print *, ' PET', mypet, &
': ignoring RouteHandle, pass =', pass
end if
! Do nothing for RouteHandles. There is no need to reconcile them.
case (ESMF_STATEITEM_UNKNOWN%ot)
if (debug) then
print *, ESMF_METHOD, ': serializing unknown: ', trim (stateitem%namep)
end if
call c_ESMC_StringSerialize(stateitem%namep, &
obj_buffer, lbufsize, buffer_offset, &
inqflag, &
localrc)
if (ESMF_LogFoundError(localrc, ESMF_ERR_PASSTHRU, &
ESMF_CONTEXT, &
rcToReturn=rc)) return
case default
localrc = ESMF_RC_INTNRL_INCONS
if (debug) then
print *, ' PET', mypet, &
': serialization error in default case. Returning ESMF_RC_INTNRL_INCONS'
end if
end select
if (ESMF_LogFoundError(localrc, ESMF_ERR_PASSTHRU, &
ESMF_CONTEXT, &
rcToReturn=rc)) return
#if defined (ALIGN_FIX)
buffer_offset = ((buffer_offset+7)/8)*8
#endif
if (debug) then
print *, ' PET', mypet, &
': item serialized, pass =', pass, ', new offset =', buffer_offset, &
merge (" (calc'ed)", " (actual) ", pass == 1)
end if
end do pass_loop
pet_needs(item)%obj_buffer => obj_buffer
pet_needs(item)%buffer_size = buffer_offset
obj_buffer => null ()
end do item_loop
if (debug) &
print *, ESMF_METHOD, ': buffer_sizes =', pet_needs(:)%buffer_size
! For each PET, create a buffer containing its serialized needs. The buffer
! consists of a count of items, a table of the offsets (in bytes) of each
! serialized item, and the serialized items themselves.
if (trace) then
call ESMF_ReconcileDebugPrint (ESMF_METHOD // &
': *** Step 3 - Create per-PET serialized buffers')
end if
do, pet=0, npets-1
needs_count = count (needs_list(:,pet))
if (debug .and. needs_count > 0) then
print *, ' PET', mypet, &
': needs_count =', needs_count, ', for PET', pet
end if
if (needs_count == 0) then
id_info(pet)%item_buffer => null ()
cycle
end if
! Calculate size needed for serialized item buffer, including
! space for needs_count, and size/type table
buffer_offset = ESMF_SIZEOF_DEFINT * (2 + needs_count*2)
do, item=1, nitems
if (needs_list(item, pet)) &
buffer_offset = buffer_offset + pet_needs(item)%buffer_size
end do
if (debug) then
print *, ' PET', mypet, &
': computed buffer_offset =', buffer_offset, ', for PET', pet
end if
! Fill serialized item buffer
allocate (id_info(pet)%item_buffer(0:buffer_offset-1), &
stat=memstat)
if (ESMF_LogFoundAllocError(memstat, ESMF_ERR_PASSTHRU, &
ESMF_CONTEXT, &
rcToReturn=rc)) return
obj_buffer => id_info(pet)%item_buffer
if (debug) then
write(logmsg, *) "ESMF_SIZEOF_DEFINT=", ESMF_SIZEOF_DEFINT
call ESMF_LogWrite(trim(logmsg))
write(logmsg, *) "needs_count=", needs_count
call ESMF_LogWrite(trim(logmsg))
end if
obj_buffer(0:ESMF_SIZEOF_DEFINT-1) = transfer ( &
source=needs_count, &
mold =obj_buffer(0:ESMF_SIZEOF_DEFINT-1))
if (debug) then
needs_count_debug = transfer(source=obj_buffer(0:ESMF_SIZEOF_DEFINT-1), &
mold=needs_count_debug)
write(logmsg, *) "needs_count_debug=", needs_count_debug
call ESMF_LogWrite(trim(logmsg))
end if
! space for needs_count, padding, and size/type table
buffer_offset = ESMF_SIZEOF_DEFINT * (2 + needs_count*2)
i = 2 * ESMF_SIZEOF_DEFINT ! space for needs_count and a pad
do, item=1, nitems
if (.not. needs_list(item, pet)) cycle
lbufsize = pet_needs(item)%buffer_size
if (lbufsize == 0) cycle
if (debug) then
print *, ' PET', mypet, &
': packing at buffer_offset =', buffer_offset, ', for PET', pet, &
', item =', item
end if
obj_buffer(i:i+ESMF_SIZEOF_DEFINT-1) = & ! Buffer offset
transfer ( &
source=buffer_offset, &
mold =obj_buffer(0:ESMF_SIZEOF_DEFINT-1))
i = i + ESMF_SIZEOF_DEFINT
obj_buffer(i:i+ESMF_SIZEOF_DEFINT-1) = & ! Item type
transfer ( &
source=type_table(item), &
mold =obj_buffer(0:ESMF_SIZEOF_DEFINT-1))
i = i + ESMF_SIZEOF_DEFINT
obj_buffer(buffer_offset:buffer_offset+lbufsize-1) = & ! Serialized item
pet_needs(item)%obj_buffer(:lbufsize-1)
buffer_offset = buffer_offset + lbufsize
end do ! items
end do ! pets
if (trace) then
call ESMF_ReconcileDebugPrint (ESMF_METHOD // &
': *** Step 4 - Deallocate memory')
end if
if (allocated (pet_needs)) then
do, i=1, nitems
if (associated (pet_needs(i)%obj_buffer)) then
deallocate (pet_needs(i)%obj_buffer, stat=memstat)
if (ESMF_LogFoundDeallocError(memstat, ESMF_ERR_PASSTHRU, &
ESMF_CONTEXT, &
rcToReturn=rc)) return
end if
end do
deallocate (pet_needs, stat=memstat)
if (ESMF_LogFoundDeallocError(memstat, ESMF_ERR_PASSTHRU, &
ESMF_CONTEXT, &
rcToReturn=rc)) return
end if
rc = ESMF_SUCCESS
end subroutine ESMF_ReconcileSerialize