Skip to content

Commit

Permalink
Merge pull request #517 from DeniseWorthen/feature/fbdstatus
Browse files Browse the repository at this point in the history 
update retrieval and writing of dststatus fields
  • Loading branch information
@jedwards4b
jedwards4b authored Dec 9, 2024
2 parents 63a4a31 + e1f50a2 commit d8b0155
Show file tree
Hide file tree
Showing 3 changed files with 207 additions and 84 deletions.
145 changes: 140 additions & 5 deletions mediator/med.F90
View file
Original file line number Diff line number Diff line change
Expand Up @@ -42,7 +42,7 @@ module MED
use med_internalstate_mod , only : med_internalstate_defaultmasks, logunit, maintask
use med_internalstate_mod , only : ncomps, compname
use med_internalstate_mod , only : compmed, compatm, compocn, compice, complnd, comprof, compwav, compglc
use med_internalstate_mod , only : coupling_mode, aoflux_code, aoflux_ccpp_suite
use med_internalstate_mod , only : coupling_mode, aoflux_code, aoflux_ccpp_suite, write_dststatus
use esmFlds , only : med_fldList_GetocnalbfldList, med_fldList_type
use esmFlds , only : med_fldList_GetNumFlds, med_fldList_GetFldNames, med_fldList_GetFldInfo
use esmFlds , only : med_fldList_Document_Mapping, med_fldList_Document_Merging
Expand All @@ -58,14 +58,15 @@ module MED
public SetServices
public SetVM
private InitializeP0
private AdvertiseFields ! advertise fields
private AdvertiseFields ! advertise fields
private RealizeFieldsWithTransferProvided ! realize connected Fields with transfer action "provide"
private ModifyDecompofMesh ! optionally modify the decomp/distr of transferred Grid/Mesh
private RealizeFieldsWithTransferAccept ! realize all Fields with transfer action "accept"
private DataInitialize ! finish initialization and resolve data dependencies
private ModifyDecompofMesh ! optionally modify the decomp/distr of transferred Grid/Mesh
private RealizeFieldsWithTransferAccept ! realize all Fields with transfer action "accept"
private DataInitialize ! finish initialization and resolve data dependencies
private SetRunClock
private med_meshinfo_create
private med_grid_write
private med_dststatus_write
private med_finalize

character(len=*), parameter :: u_FILE_u = &
Expand Down Expand Up @@ -2177,6 +2178,14 @@ subroutine DataInitialize(gcomp, rc)
call med_diag_zero(mode='all', rc=rc)
if (ChkErr(rc,__LINE__,u_FILE_u)) return

!---------------------------------------
! write dstStatus fields if requested
!---------------------------------------
if (write_dststatus) then
call med_dststatus_write(gcomp, rc)
if (ChkErr(rc,__LINE__,u_FILE_u)) return
end if

!---------------------------------------
! read mediator restarts
!---------------------------------------
Expand Down Expand Up @@ -2563,6 +2572,132 @@ subroutine med_grid_write(grid, fileName, rc)

end subroutine med_grid_write

!-----------------------------------------------------------------------------
subroutine med_dststatus_write (gcomp, rc)

use ESMF , only : ESMF_GridComp, ESMF_GridCompGet, ESMF_SUCCESS, ESMF_VM
use ESMF , only : ESMF_FieldBundleIsCreated, ESMF_FieldBundleDestroy
use ESMF , only : ESMF_FieldBundleAdd, ESMF_Array, ESMF_Field, ESMF_MeshGet
use ESMF , only : ESMF_FieldGet, ESMF_FieldCreate, ESMF_FieldDestroy
use ESMF , only : ESMF_Mesh, ESMF_MESHLOC_ELEMENT, ESMF_TYPEKIND_R8, ESMF_TYPEKIND_I4
use ESMF , only : ESMF_LOGMSG_INFO, ESMF_LogWrite
use NUOPC , only : NUOPC_CompAttributeGet
use med_kind_mod , only : I4=>SHR_KIND_I4, R8=>SHR_KIND_R8
use med_internalstate_mod , only : ncomps, compname
use med_io_mod , only : med_io_write, med_io_wopen, med_io_enddef, med_io_close
use pio , only : file_desc_t
use med_methods_mod , only : med_methods_FB_getFieldN


! input/output variables
type(ESMF_GridComp) :: gcomp
integer, intent(out) :: rc

! local variables
type(file_desc_t) :: io_file
type(InternalState) :: is_local
type(ESMF_VM) :: vm
type(ESMF_Mesh) :: mesh_dst
type(ESMF_Field) :: flddst, lfield
type(ESMF_Field) :: maskfield
type(ESMF_Array) :: maskarray
integer(I4), pointer :: meshmask(:)
real(R8), pointer :: r8ptr(:)
integer :: m,n1,n2
character(CL) :: case_name, dststatusfile
logical :: elementMaskIsPresent
logical :: whead(2) = (/.true. , .false./)
logical :: wdata(2) = (/.false., .true. /)
character(len=*), parameter :: subname = '('//__FILE__//':med_dststatus_write)'
!-------------------------------------------------------------------------------

rc = ESMF_SUCCESS

! Get the internal state
nullify(is_local%wrap)
call ESMF_GridCompGetInternalState(gcomp, is_local, rc)
if (ChkErr(rc,__LINE__,u_FILE_u)) return

! Create dststatus file
call ESMF_GridCompGet(gcomp, vm=vm, rc=rc)
if (ChkErr(rc,__LINE__,u_FILE_u)) return
call NUOPC_CompAttributeGet(gcomp, name='case_name', value=case_name, rc=rc)
if (ChkErr(rc,__LINE__,u_FILE_u)) return
dststatusfile = trim(case_name)//'.dststatus.nc'

! add mesh masks for any destination component in the dststatusFB
do n2 = 2,ncomps
if (is_local%wrap%comp_present(n2)) then
if (ESMF_FieldBundleIsCreated(is_local%wrap%FBdststatus(n2),rc=rc)) then
call med_methods_FB_getFieldN(is_local%wrap%FBdststatus(n2), 1, flddst, rc=rc)
if (ChkErr(rc,__LINE__,u_FILE_u)) return
call ESMF_FieldGet(flddst, mesh=mesh_dst, rc=rc)
if (chkerr(rc,__LINE__,u_FILE_u)) return

call ESMF_MeshGet(mesh_dst, elementMaskIsPresent=elementMaskIsPresent, rc=rc)
if (chkerr(rc,__LINE__,u_FILE_u)) return
if (elementMaskIsPresent) then
maskfield = ESMF_FieldCreate(mesh_dst, ESMF_TYPEKIND_I4, meshloc=ESMF_MESHLOC_ELEMENT, rc=rc)
if (ChkErr(rc,__LINE__,u_FILE_u)) return
! get mask Array
call ESMF_FieldGet(maskfield, array=maskarray, rc=rc)
if (ChkErr(rc,__LINE__,u_FILE_u)) return
call ESMF_MeshGet(mesh_dst, elemMaskArray=maskarray, rc=rc)
if (ChkErr(rc,__LINE__,u_FILE_u)) return
call ESMF_FieldGet(maskfield, localDe=0, farrayPtr=meshmask, rc=rc)
if (ChkErr(rc,__LINE__,u_FILE_u)) return
! now create an R8 mask for writing
lfield = ESMF_FieldCreate(mesh_dst, ESMF_TYPEKIND_R8, meshloc=ESMF_MESHLOC_ELEMENT, &
name=trim(compname(n2))//'mask', rc=rc)
if (ChkErr(rc,__LINE__,u_FILE_u)) return
call ESMF_FieldGet(lfield, farrayPtr=r8ptr, rc=rc)
if (ChkErr(rc,__LINE__,u_FILE_u)) return
r8ptr = real(meshmask,R8)
call ESMF_FieldBundleAdd(is_local%wrap%FBdststatus(n2), (/lfield/), rc=rc)
if (ChkErr(rc,__LINE__,u_FILE_u)) return
call ESMF_FieldDestroy(maskfield, rc=rc)
if (ChkErr(rc,__LINE__,u_FILE_u)) return
end if
end if
end if
end do

! write the FB
call med_io_wopen(trim(dststatusfile), io_file, vm, rc, clobber=.true.)
if (ChkErr(rc,__LINE__,u_FILE_u)) return

! Loop over whead/wdata phases
do m = 1,2
if (m == 2) then
call med_io_enddef(io_file)
end if

! write dststatusfields for each dst component
do n2 = 2,ncomps
if (is_local%wrap%comp_present(n2)) then
if (ESMF_FieldBundleIsCreated(is_local%wrap%FBdststatus(n2),rc=rc)) then
call med_io_write(io_file, is_local%wrap%FBdststatus(n2), whead(m), wdata(m), &
is_local%wrap%nx(n2), is_local%wrap%ny(n2), pre='dst'//trim(compname(n2)), &
use_float=.true., ntile=is_local%wrap%ntile(n2), rc=rc)
if (ChkErr(rc,__LINE__,u_FILE_u)) return
endif
end if
end do
end do ! do m = 1,2
! Close file
call med_io_close(io_file, rc=rc)
if (ChkErr(rc,__LINE__,u_FILE_u)) return

! Destroy the dststatus FBs
do n2 = 2,ncomps
if (ESMF_FieldBundleIsCreated(is_local%wrap%FBdststatus(n2),rc=rc)) then
call ESMF_FieldBundleDestroy(is_local%wrap%FBdststatus(n2), rc=rc)
if (chkerr(rc,__LINE__,u_FILE_u)) return
end if
end do

end subroutine med_dststatus_write

!-----------------------------------------------------------------------------

subroutine med_finalize(gcomp, rc)
Expand Down
15 changes: 10 additions & 5 deletions mediator/med_internalstate_mod.F90
View file
Original file line number Diff line number Diff line change
Expand Up @@ -106,7 +106,7 @@ module med_internalstate_mod
type(ESMF_Field) :: field_fracdst
end type packed_data_type

logical, public :: dststatus_print = .false.
logical, public :: write_dststatus = .false.

! Mesh info
type, public :: mesh_info_type
Expand Down Expand Up @@ -189,6 +189,8 @@ module med_internalstate_mod

! Data
type(ESMF_FieldBundle) , pointer :: FBData(:) ! Background data for various components, on their grid, provided by CDEPS inline
! DstStatus
type(ESMF_FieldBundle) , pointer :: FBDstStatus(:) ! DstStatus fields for components for each source component and maptype

! Accumulators for export field bundles
type(ESMF_FieldBundle) :: FBExpAccumOcn ! Accumulator for Ocn export on Ocn grid
Expand Down Expand Up @@ -429,12 +431,15 @@ subroutine med_internalstate_init(gcomp, rc)
write(logunit,*)
end if

! Obtain dststatus_print setting if present
call NUOPC_CompAttributeGet(gcomp, name='dststatus_print', value=cvalue, isPresent=isPresent, isSet=isSet, rc=rc)
! Allocate dststatus FB if needed
call NUOPC_CompAttributeGet(gcomp, name='write_dststatus', value=cvalue, isPresent=isPresent, isSet=isSet, rc=rc)
if (ChkErr(rc,__LINE__,u_FILE_u)) return
if (isPresent .and. isSet) dststatus_print=(trim(cvalue) == "true")
write(msgString,*) trim(subname)//': Mediator dststatus_print is ',dststatus_print
if (isPresent .and. isSet) write_dststatus=(trim(cvalue) == "true")
write(msgString,*) trim(subname)//': Mediator write_dststatus is ',write_dststatus
call ESMF_LogWrite(trim(msgString), ESMF_LOGMSG_INFO)
if (write_dststatus) then
allocate(is_local%wrap%FBDstStatus(ncomps))
end if

! Initialize flag for background fill using data
is_local%wrap%med_data_active(:,:) = .false.
Expand Down
Loading

0 comments on commit d8b0155

Please sign in to comment.