Merge pull request #517 from DeniseWorthen/feature/fbdstatus

update retrieval and writing of dststatus fields

Author: jedwards4b

mediator/med.F90

@@ -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
@@ -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  = &
@@ -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
        !---------------------------------------
@@ -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)

mediator/med_internalstate_mod.F90

@@ -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
@@ -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
@@ -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.