subroutine ESMF_OutputWeightFile (weightFile, factorList, factorIndexList, rc)
!
! !ARGUMENTS:
character(len=*), intent(in) :: weightFile
real(ESMF_KIND_R8), intent(in) :: factorList(:)
integer(ESMF_KIND_I4), intent(in) :: factorIndexList(:,:)
integer, intent(inout), optional :: rc
type(ESMF_DistGrid) :: distgridFL
type(ESMF_Array) :: arrayFL, arrayFIL1, arrayFIL2
type(ESMF_AttPack) :: attpack
integer :: lens(3), lens2(1), nfactors, ii, localPet, petCount, startIndex, &
stopIndex, localrc, memstat, hasFactors, nLivePETs(1), offset
character(len=23), parameter :: name = "ESMF:gridded_dim_labels"
character(len=3), parameter :: value = "n_s"
character(len=70), parameter :: noFactorsMsg = '"factorList" has size 0 and PET count is 1. There is nothing to write.'
integer(ESMF_KIND_I4), allocatable, dimension(:) :: col, row
type(ESMF_VM) :: vm
integer(ESMF_KIND_I4), dimension(1) :: sendData, recvData
integer(ESMF_KIND_I4), dimension(2) :: bcstData
integer(ESMF_KIND_I4), allocatable, dimension(:,:,:) :: deBlockList
type(ESMF_Info) :: idg
type(ESMF_Pointer) :: ptr
! ==============================================================================
if (present(rc)) then
localrc = rc
else
localrc = ESMF_RC_NOT_IMPL
endif
#if (!defined ESMF_PIO || (!defined ESMF_NETCDF && !defined ESMF_PNETCDF))
! Writing weights requires netCDF and the subroutine should not continue if
! the netCDF library is not available.
if (ESMF_LogFoundError(ESMF_RC_LIB_NOT_PRESENT, ESMF_ERR_PASSTHRU, &
ESMF_CONTEXT, rcToReturn=rc)) return
#endif
call ESMF_VMGetGlobal(vm, rc=localrc)
if (ESMF_LogFoundError(localrc, ESMF_ERR_PASSTHRU, &
ESMF_CONTEXT, rcToReturn=rc)) return
call ESMF_VMGet(vm, localPet=localPet, petCount=petCount, rc=localrc)
if (ESMF_LogFoundError(localrc, ESMF_ERR_PASSTHRU, &
ESMF_CONTEXT, rcToReturn=rc)) return
! ==============================================================================
! Create the DistGrid. The factors may be ragged (factor count differs between
! PETs). Synchronize min and max indices across PETs.
! Number of local factors.
nfactors = size(factorList, 1)
! Bail out if there are no factors and this is a single process.
if ((nfactors .eq. 0) .and. (petCount .eq. 1)) then
if (ESMF_LogFoundError(ESMF_RC_NOT_IMPL, msg=noFactorsMsg, &
ESMF_CONTEXT, rcToReturn=rc)) return
endif
! Determine if we need a redistribution. A redistribution is needed if one of
! the PETs does not have any factors.
if (nfactors .eq. 0) then
hasFactors = 0
else
hasFactors = 1
endif
call ESMF_VMAllReduce(vm, (/hasFactors/), nLivePETs, 1, ESMF_REDUCE_SUM, rc=localrc)
if (ESMF_LogFoundError(localrc, ESMF_ERR_PASSTHRU, ESMF_CONTEXT, &
rcToReturn=rc)) return
! Chain start and stop index calculation.
if (localPet .ne. 0) then
call ESMF_VMRecv(vm, recvData, 1, localPet-1, rc=localrc)
startIndex = recvData(1)
else
startIndex = 1
endif
if (nfactors .eq. 0) then
stopIndex = startIndex
else
stopIndex = startIndex + nfactors - 1
endif
if ((localPet .ne. petCount-1) .and. (petCount > 1)) then
if (nfactors == 0) then
offset = 0
else
offset = 1
endif
call ESMF_VMSend(vm, (/stopIndex+offset/), 1, localPet+1, rc=localrc)
if (ESMF_LogFoundError(localrc, ESMF_ERR_PASSTHRU, ESMF_CONTEXT, rcToReturn=rc)) return
endif
!-=-=-=-=-=-=-=-=-=-=-=-=-=-=-=-=-=-=-=-=-=-=-=-=-=-=-=-=-=-=-=-=-=-=-=-=-=-=-=-
! Some PETs do not have data. We need to gather and scatter to ensure the
! asynchronous write has data for each proc - or - we can use the simple weight
! file write implementation that can handle zero-length factor lists.
! TODO (bekozi): Array should be able to handle empty data and the write should
! correspondingly work.
if (nLivePETs(1) .ne. petCount) then
! This streams everything to a single PET for writing avoiding the need for an
! asynchronous write.
call ESMF_OutputSimpleWeightFile(weightFile, factorList, factorIndexList, &
rc=localrc)
if (ESMF_LogFoundError(localrc, ESMF_ERR_PASSTHRU, ESMF_CONTEXT, &
rcToReturn=rc)) return ! bail on error
! return successfully
if (present(rc)) rc = ESMF_SUCCESS
return
endif
!-=-=-=-=-=-=-=-=-=-=-=-=-=-=-=-=-=-=-=-=-=-=-=-=-=-=-=-=-=-=-=-=-=-=-=-=-=-=-=-
! Ragged factor counts may require a non-regular decomposition. This requires a
! custom block definition per DE.
allocate(deBlockList(1, 2, petCount), stat=memstat)
if (ESMF_LogFoundAllocError(memstat, &
ESMF_CONTEXT, rcToReturn=rc)) return
do ii=1,petCount
if (localPet .eq. ii-1) then
bcstData = (/startIndex, stopIndex/)
else
bcstData = (/0, 0/)
endif
call ESMF_VMBroadcast(vm, bcstData, 2, ii-1, rc=localrc)
if (ESMF_LogFoundError(localrc, ESMF_ERR_PASSTHRU, &
ESMF_CONTEXT, rcToReturn=rc)) return
deBlockList(1, :, ii) = bcstData
enddo
distgridFL = ESMF_DistGridCreate(minIndex=(/1/), &
maxIndex=(/deBlockList(1, 2, petCount)/), &
deBlockList=deBlockList, &
rc=localrc)
if (ESMF_LogFoundError(localrc, ESMF_ERR_PASSTHRU, &
ESMF_CONTEXT, rcToReturn=rc)) return
! ==============================================================================
! Set up attributes to allow variables to share a common dimension name in the
! output file.
!NOTE: removed distgridcreate from factorIndexList so that all
! Arrays could share the same DistGrid (i.e. dimensions)
call ESMF_DistGridGetThis(distgridFL, ptr, rc=localrc)
if (ESMF_LogFoundError(localrc, ESMF_ERR_PASSTHRU, &
ESMF_CONTEXT, rcToReturn=rc)) return
call ESMF_InfoGetFromPointer(ptr, idg, rc=localrc)
if (ESMF_LogFoundError(localrc, ESMF_ERR_PASSTHRU, &
ESMF_CONTEXT, rcToReturn=rc)) return
call ESMF_InfoSet(idg, "/netcdf/metadata/"//name, (/ value /), rc=localrc)
if (ESMF_LogFoundError(localrc, ESMF_ERR_PASSTHRU, &
ESMF_CONTEXT, rcToReturn=rc)) return
! ==============================================================================
! Create arrays.
arrayFL = ESMF_ArrayCreate(farray=factorList, distgrid=distgridFL, &
indexflag=ESMF_INDEX_DELOCAL, rc=localrc)
if (ESMF_LogFoundError(localrc, ESMF_ERR_PASSTHRU, &
ESMF_CONTEXT, rcToReturn=rc)) return
! Copy factor indexing before passing to array create. Passing an array section
! here causes undefined behavior in the array buffer access. "datacopyflag" does
! not work with this interface??
allocate(col(nfactors), row(nfactors), stat=memstat)
if (ESMF_LogFoundAllocError(memstat, &
ESMF_CONTEXT, rcToReturn=rc)) return
do ii=1,nfactors
col(ii) = factorIndexList(1, ii)
row(ii) = factorIndexList(2, ii)
enddo
arrayFIL1 = ESMF_ArrayCreate(farray=col, distgrid=distgridFL, &
indexflag=ESMF_INDEX_DELOCAL, rc=localrc)
if (ESMF_LogFoundError(localrc, ESMF_ERR_PASSTHRU, &
ESMF_CONTEXT, rcToReturn=rc)) return
arrayFIL2 = ESMF_ArrayCreate(farray=row, distgrid=distgridFL, &
indexflag=ESMF_INDEX_DELOCAL, rc=localrc)
if (ESMF_LogFoundError(localrc, ESMF_ERR_PASSTHRU, &
ESMF_CONTEXT, rcToReturn=rc)) return
! ==============================================================================
! Write arrays to file.
! Do not overwrite the output file by default.
call ESMF_ArrayWrite(arrayFL, weightFile, variableName="S", &
convention="netcdf", purpose="metadata", &
overwrite=.false., rc=localrc)
if (ESMF_LogFoundError(localrc, ESMF_ERR_PASSTHRU, &
ESMF_CONTEXT, rcToReturn=rc)) return
! Set overwrite to true for consecutive writes. The file is created on the first
! write.
call ESMF_ArrayWrite(arrayFIL1, weightFile, variableName="col", &
convention="netcdf", purpose="metadata", &
overwrite=.true., rc=localrc)
if (ESMF_LogFoundError(localrc, ESMF_ERR_PASSTHRU, &
ESMF_CONTEXT, rcToReturn=rc)) return
call ESMF_ArrayWrite(arrayFIL2, weightFile, variableName="row", &
convention="netcdf", purpose="metadata", &
overwrite=.true., rc=localrc)
if (ESMF_LogFoundError(localrc, ESMF_ERR_PASSTHRU, &
ESMF_CONTEXT, rcToReturn=rc)) return
! ==============================================================================
deallocate(col, row, deBlockList, stat=memstat)
if (ESMF_LogFoundDeallocError(memstat, &
ESMF_CONTEXT, rcToReturn=rc)) return
call ESMF_ArrayDestroy(arrayFL, rc=localrc)
call ESMF_ArrayDestroy(arrayFIL1, rc=localrc)
call ESMF_ArrayDestroy(arrayFIL2, rc=localrc)
call ESMF_DistGridDestroy(distgridFL, rc=localrc)
if (ESMF_LogFoundError(localrc, ESMF_ERR_PASSTHRU, &
ESMF_CONTEXT, rcToReturn=rc)) return
rc = localrc
end subroutine ESMF_OutputWeightFile