From cead26741449605411eff10bfa6e71bb7b038cfd Mon Sep 17 00:00:00 2001 From: Daniel Rosen Date: Sat, 31 Jul 2021 16:18:46 +0000 Subject: [PATCH] Update NUOPC cap exchange fields * Move fields utilities to WRFHydro_NUOPC_Fields.F90 * Add 3 dimensional soil fields smc, slc, stc * Remove fields that aren't connected * Update LSM forcings check * Update NUOPC cap fill values * Add options for memory copy or pointer * Add options to initialize with prescribed values * Add options to check for missing values * Add options to fill missing values with prescribed values * Cleanup field creation and fill * Cleanup ESMF extension utilities * Update error flags * Set field timestamp to invalid for coldstarts * Add WRFHYDRO model state debugging * Fix WRFHYDRO NUOPC cap installation dependencies --- trunk/NDHMS/CPL/NUOPC_cpl/CMakeLists.txt | 2 + trunk/NDHMS/CPL/NUOPC_cpl/Makefile | 15 +- .../NUOPC_cpl/WRFHydro_ESMF_Extensions.F90 | 1803 ----------------- .../CPL/NUOPC_cpl/WRFHydro_NUOPC_Cap.F90 | 775 +++---- .../CPL/NUOPC_cpl/WRFHydro_NUOPC_Fields.F90 | 1479 ++++++++++++++ .../CPL/NUOPC_cpl/WRFHydro_NUOPC_Flags.F90 | 305 +++ .../CPL/NUOPC_cpl/WRFHydro_NUOPC_Gluecode.F90 | 443 +--- .../CPL/NUOPC_cpl/WRFHydro_NUOPC_Macros.h | 2 +- 8 files changed, 2269 insertions(+), 2555 deletions(-) create mode 100644 trunk/NDHMS/CPL/NUOPC_cpl/WRFHydro_NUOPC_Fields.F90 create mode 100644 trunk/NDHMS/CPL/NUOPC_cpl/WRFHydro_NUOPC_Flags.F90 diff --git a/trunk/NDHMS/CPL/NUOPC_cpl/CMakeLists.txt b/trunk/NDHMS/CPL/NUOPC_cpl/CMakeLists.txt index 381b5e928..95816d970 100644 --- a/trunk/NDHMS/CPL/NUOPC_cpl/CMakeLists.txt +++ b/trunk/NDHMS/CPL/NUOPC_cpl/CMakeLists.txt @@ -9,6 +9,8 @@ endif (NOT TARGET esmf) list(APPEND wrfhydro_nuopc_files WRFHydro_NUOPC_Cap.F90 WRFHydro_NUOPC_Gluecode.F90 + WRFHydro_NUOPC_Fields.F90 + WRFHydro_NUOPC_Flags.F90 WRFHydro_ESMF_Extensions.F90 ) diff --git a/trunk/NDHMS/CPL/NUOPC_cpl/Makefile b/trunk/NDHMS/CPL/NUOPC_cpl/Makefile index 656499206..78aa70f80 100644 --- a/trunk/NDHMS/CPL/NUOPC_cpl/Makefile +++ b/trunk/NDHMS/CPL/NUOPC_cpl/Makefile @@ -108,10 +108,14 @@ CAP_MK := wrfhydro.mk CAP_OBJS := WRFHydro_NUOPC_Cap.o CAP_OBJS += WRFHydro_NUOPC_Gluecode.o +CAP_OBJS += WRFHydro_NUOPC_Fields.o +CAP_OBJS += WRFHydro_NUOPC_Flags.o CAP_OBJS += WRFHydro_ESMF_Extensions.o CAP_MODS := wrfhydro_nuopc.mod CAP_MODS += wrfhydro_nuopc_gluecode.mod +CAP_MODS += wrfhydro_nuopc_fields.mod +CAP_MODS += wrfhydro_nuopc_flags.mod CAP_MODS += wrfhydro_esmf_extensions.mod CAP_FILES := $(CAP_OBJS) $(CAP_MODS) $(CAP_LIB) $(CAP_VERS) $(CAP_MK) @@ -143,12 +147,19 @@ nuopcinstall: $(CAP_LIB) $(CAP_MODS) $(CAP_VERS) \ # ############ WRFHydro_NUOPC_Cap.o: WRFHydro_NUOPC_Macros.h \ - WRFHydro_NUOPC_Gluecode.o WRFHydro_ESMF_Extensions.o + WRFHydro_NUOPC_Gluecode.o WRFHydro_NUOPC_Fields.o \ + WRFHydro_NUOPC_Flags.o WRFHydro_ESMF_Extensions.o WRFHydro_NUOPC_Gluecode.o: WRFHydro_NUOPC_Macros.h \ + WRFHydro_NUOPC_Fields.o WRFHydro_NUOPC_Flags.o \ WRFHydro_ESMF_Extensions.o $(MODEL_MODS) +WRFHydro_NUOPC_Fields.o: WRFHydro_NUOPC_Macros.h \ + WRFHydro_NUOPC_Flags.o WRFHydro_ESMF_Extensions.o \ + $(MODEL_MODS) wrfhydro_nuopc.mod: WRFHydro_NUOPC_Cap.o wrfhydro_nuopc_gluecode.mod: WRFHydro_NUOPC_Gluecode.o +wrfhydro_nuopc_fields.mod: WRFHydro_NUOPC_Fields.o +wrfhydro_nuopc_flags.mod: WRFHydro_NUOPC_Flags.o wrfhydro_esmf_extensions.mod: WRFHydro_ESMF_Extensions.o # ############### @@ -253,7 +264,7 @@ $(CAP_MK): # Install Library, Modules, and Makefile Fragment # ----------------------------------------------------------------------------- -$(INSTPATH)/%: +$(INSTPATH)/%: % @echo $(HR) @echo "Installing $(notdir $@)" @echo diff --git a/trunk/NDHMS/CPL/NUOPC_cpl/WRFHydro_ESMF_Extensions.F90 b/trunk/NDHMS/CPL/NUOPC_cpl/WRFHydro_ESMF_Extensions.F90 index c9a830cd9..831bd24b3 100644 --- a/trunk/NDHMS/CPL/NUOPC_cpl/WRFHydro_ESMF_Extensions.F90 +++ b/trunk/NDHMS/CPL/NUOPC_cpl/WRFHydro_ESMF_Extensions.F90 @@ -41,11 +41,6 @@ module WRFHydro_ESMF_Extensions public :: WRFHYDRO_ESMF_MAPPRESET_CONUS public :: WRFHYDRO_ESMF_MAPPRESET_IRENE public :: WRFHYDRO_ESMF_MAPPRESET_FRONTRANGE - public :: WRFHYDRO_ESMF_FieldFill - public :: WRFHYDRO_ESMF_FillField - public :: WRFHYDRO_ESMF_FillArray - public :: WRFHYDRO_ESMF_FillFieldBundle - public :: WRFHYDRO_ESMF_FillState public :: WRFHYDRO_ESMF_NetcdfReadIXJX public :: WRFHYDRO_ESMF_NetcdfIsPresent public :: WRFHYDRO_ESMF_LogStateList @@ -85,36 +80,6 @@ module WRFHydro_ESMF_Extensions module procedure WRFHYDRO_ESMF_FerretScriptWrite_default end interface - interface WRFHYDRO_ESMF_FillState - module procedure WRFHYDRO_ESMF_FillState_I4 - module procedure WRFHYDRO_ESMF_FillState_I8 - module procedure WRFHYDRO_ESMF_FillState_R4 - module procedure WRFHYDRO_ESMF_FillState_R8 - module procedure WRFHYDRO_ESMF_FillState_SCHEME - end interface - - interface WRFHYDRO_ESMF_FillFieldBundle - module procedure WRFHYDRO_ESMF_FillFieldBundle_I4 - module procedure WRFHYDRO_ESMF_FillFieldBundle_I8 - module procedure WRFHYDRO_ESMF_FillFieldBundle_R4 - module procedure WRFHYDRO_ESMF_FillFieldBundle_R8 - module procedure WRFHYDRO_ESMF_FillFieldBundle_SCHEME - end interface - - interface WRFHYDRO_ESMF_FillField - module procedure WRFHYDRO_ESMF_FillField_I4 - module procedure WRFHYDRO_ESMF_FillField_I8 - module procedure WRFHYDRO_ESMF_FillField_R4 - module procedure WRFHYDRO_ESMF_FillField_R8 - end interface - - interface WRFHYDRO_ESMF_FillArray - module procedure WRFHYDRO_ESMF_FillArray_I4 - module procedure WRFHYDRO_ESMF_FillArray_I8 - module procedure WRFHYDRO_ESMF_FillArray_R4 - module procedure WRFHYDRO_ESMF_FillArray_R8 - end interface - interface WRFHYDRO_ESMF_NetcdfReadIXJX module procedure WRFHYDRO_ESMF_NetcdfReadIXJX_Field module procedure WRFHYDRO_ESMF_NetcdfReadIXJX_Array @@ -1241,1774 +1206,6 @@ subroutine WRFHYDRO_ESMF_FerretScriptWrite_default(varName, dataFile, gridFile, !----------------------------------------------------------------------------- -#define METHOD "WRFHYDRO_ESMF_FieldFill" -!BOP -! !IROUTINE: WRFHYDRO_ESMF_FieldFill - Fill data into a Field -! !INTERFACE: - subroutine WRFHYDRO_ESMF_FieldFill(field, keywordEnforcer, & - dataFillScheme, member, step, amplitude, meanValue, rc) -! !ARGUMENTS: - type(ESMF_Field), intent(inout) :: field -type(ESMF_KeywordEnforcer), optional:: keywordEnforcer ! must use keywords below - character(len=*), intent(in), optional :: dataFillScheme - integer, intent(in), optional :: member - integer, intent(in), optional :: step - real, intent(in), optional :: amplitude - real, intent(in), optional :: meanValue - integer, intent(out), optional :: rc -! !DESCRIPTION: -! Fill {\tt field} with data according to {\tt dataFillScheme}. Depending -! on the chosen fill scheme, the {\tt member} and {\tt step} arguments are -! used to provide differing fill data patterns. -! -! The arguments are: -! \begin{description} -! \item[field] -! The {\tt ESMF\_Field} object to fill with data. -! \item[{[dataFillScheme]}] -! The fill scheme. The available options are "sincos", and "one". -! Defaults to "sincos". -! \item[{[member]}] -! Member incrementor. Defaults to 1. -! \item[{[step]}] -! Step incrementor. Defaults to 1. -! \item[{[amplitude]}] -! Magnitude of change. Defaults to 1. -! \item[{[meanValue]}] -! Mean value. Defaults to 0. -! \item[{[rc]}] -! Return code; equals {\tt ESMF\_SUCCESS} if there are no errors. -! \end{description} -! -!EOP - !----------------------------------------------------------------------------- - ! local variables - type(ESMF_Grid) :: grid - type(ESMF_TypeKind_Flag) :: typekind - type(ESMF_TypeKind_Flag) :: coordTypeKind - integer :: rank - integer, allocatable :: coordDimCount(:) - real(ESMF_KIND_R8), pointer :: dataPtrR8D1(:) - real(ESMF_KIND_R8), pointer :: dataPtrR8D2(:,:) - real(ESMF_KIND_R8), pointer :: dataPtrR8D3(:,:,:) - real(ESMF_KIND_R4), pointer :: dataPtrR4D1(:) - real(ESMF_KIND_R4), pointer :: dataPtrR4D2(:,:) - real(ESMF_KIND_R4), pointer :: dataPtrR4D3(:,:,:) - real(ESMF_KIND_R8), pointer :: coord1PtrR8D1(:) - real(ESMF_KIND_R8), pointer :: coord2PtrR8D1(:) - real(ESMF_KIND_R8), pointer :: coord1PtrR8D2(:,:) - real(ESMF_KIND_R8), pointer :: coord2PtrR8D2(:,:) - real(ESMF_KIND_R8), pointer :: coord1PtrR8D3(:,:,:) - real(ESMF_KIND_R8), pointer :: coord2PtrR8D3(:,:,:) - real(ESMF_KIND_R8), pointer :: coord3PtrR8D3(:,:,:) - real(ESMF_KIND_R4), pointer :: coord1PtrR4D1(:) - real(ESMF_KIND_R4), pointer :: coord2PtrR4D1(:) - real(ESMF_KIND_R4), pointer :: coord1PtrR4D2(:,:) - real(ESMF_KIND_R4), pointer :: coord2PtrR4D2(:,:) - real(ESMF_KIND_R4), pointer :: coord1PtrR4D3(:,:,:) - real(ESMF_KIND_R4), pointer :: coord2PtrR4D3(:,:,:) - real(ESMF_KIND_R4), pointer :: coord3PtrR4D3(:,:,:) - integer :: i, j, k - - integer :: l_member, l_step - real :: l_amplitude, l_meanValue - character(len=16) :: l_dataFillScheme - integer :: stat - - if (present(rc)) rc = ESMF_SUCCESS - - call ESMF_FieldGet(field, typekind=typekind, rank=rank, rc=rc) - if (ESMF_LogFoundError(rcToCheck=rc, PASSTHRU)) return ! bail out - - l_member = 1 - if(present(member)) l_member = member - l_step = 1 - if(present(step)) l_step = step - l_dataFillScheme = "sincos" - if(present(dataFillScheme)) l_dataFillScheme = dataFillScheme - l_amplitude = 1.0 - if(present(amplitude)) l_amplitude = amplitude - l_meanValue = 0.0 - if(present(meanValue)) l_meanValue = meanValue - - allocate(coordDimCount(rank)) - if (ESMF_LogFoundAllocError(statusToCheck=stat, & - msg="Allocation of coordinate dimensions memory failed.", & - CONTEXT, rcToReturn=rc)) return ! bail out - - if (trim(l_dataFillScheme)=="sincos") then - call ESMF_FieldGet(field, grid=grid, rc=rc) - if (ESMF_LogFoundError(rcToCheck=rc, PASSTHRU)) return ! bail out - call ESMF_GridGet(grid,coordTypeKind=coordTypeKind, & - coordDimCount=coordDimCount, rc=rc) - if (ESMF_LogFoundError(rcToCheck=rc, PASSTHRU)) return ! bail out - if (rank==1) then - ! 1D sin pattern - ! TODO: support Meshes - call ESMF_GridGetCoord(grid, coordDim=1, farrayPtr=coord1PtrR8D1, rc=rc) - if (ESMF_LogFoundError(rcToCheck=rc, PASSTHRU)) return ! bail out - if (typekind==ESMF_TYPEKIND_R4) then - call ESMF_FieldGet(field, farrayPtr=dataPtrR4D1, rc=rc) - if (ESMF_LogFoundError(rcToCheck=rc, PASSTHRU)) return ! bail out - do i=lbound(dataPtrR4D1,1),ubound(dataPtrR4D1,1) - dataPtrR4D1(i) = & - (sin(real(l_member)*3.1416*(coord1PtrR8D1(i)+real(l_step))/180.)) * & - l_amplitude+l_meanValue - enddo - elseif (typekind==ESMF_TYPEKIND_R8) then - call ESMF_FieldGet(field, farrayPtr=dataPtrR8D1, rc=rc) - if (ESMF_LogFoundError(rcToCheck=rc, PASSTHRU)) return ! bail out - do i=lbound(dataPtrR8D1,1),ubound(dataPtrR8D1,1) - dataPtrR8D1(i) = & - (sin(real(l_member)*3.1416*(coord1PtrR8D1(i)+real(l_step))/180.)) * & - l_amplitude+l_meanValue - enddo - else - call ESMF_LogSetError(ESMF_RC_ARG_BAD, & - msg="Unsupported typekind-rank and scheme combination requested.", & - CONTEXT, rcToReturn=rc) - return ! bail out - endif - elseif (rank==2) then - ! 2D sin*cos pattern - ! TODO: support Meshes - if (coordTypeKind==ESMF_TYPEKIND_R4) then - if (coordDimCount(1)==1) then - call ESMF_GridGetCoord(grid, coordDim=1, farrayPtr=coord1PtrR4D1, rc=rc) - if (ESMF_LogFoundError(rcToCheck=rc, PASSTHRU)) return ! bail out - else - ! assume the only other choice here is 2D, if not will trigger error - call ESMF_GridGetCoord(grid, coordDim=1, farrayPtr=coord1PtrR4D2, rc=rc) - if (ESMF_LogFoundError(rcToCheck=rc, PASSTHRU)) return ! bail out - endif - if (coordDimCount(2)==1) then - call ESMF_GridGetCoord(grid, coordDim=2, farrayPtr=coord2PtrR4D1, rc=rc) - if (ESMF_LogFoundError(rcToCheck=rc, PASSTHRU)) return ! bail out - else - ! assume the only other choice here is 2D, if not will trigger error - call ESMF_GridGetCoord(grid, coordDim=2, farrayPtr=coord2PtrR4D2, rc=rc) - if (ESMF_LogFoundError(rcToCheck=rc, PASSTHRU)) return ! bail out - endif - elseif (coordTypeKind==ESMF_TYPEKIND_R8) then - if (coordDimCount(1)==1) then - call ESMF_GridGetCoord(grid, coordDim=1, farrayPtr=coord1PtrR8D1, rc=rc) - if (ESMF_LogFoundError(rcToCheck=rc, PASSTHRU)) return ! bail out - else - ! assume the only other choice here is 2D, if not will trigger error - call ESMF_GridGetCoord(grid, coordDim=1, farrayPtr=coord1PtrR8D2, rc=rc) - if (ESMF_LogFoundError(rcToCheck=rc, PASSTHRU)) return ! bail out - endif - if (coordDimCount(2)==1) then - call ESMF_GridGetCoord(grid, coordDim=2, farrayPtr=coord2PtrR8D1, rc=rc) - if (ESMF_LogFoundError(rcToCheck=rc, PASSTHRU)) return ! bail out - else - ! assume the only other choice here is 2D, if not will trigger error - call ESMF_GridGetCoord(grid, coordDim=2, farrayPtr=coord2PtrR8D2, rc=rc) - if (ESMF_LogFoundError(rcToCheck=rc, PASSTHRU)) return ! bail out - endif - else - call ESMF_LogSetError(ESMF_RC_ARG_BAD, & - msg="Unsupported coordinate typekind.", & - CONTEXT, rcToReturn=rc) - return ! bail out - endif - - if (typekind==ESMF_TYPEKIND_R4) then - call ESMF_FieldGet(field, farrayPtr=dataPtrR4D2, rc=rc) - if (ESMF_LogFoundError(rcToCheck=rc, PASSTHRU)) return ! bail out - if (coordDimCount(1)==1 .and. coordDimCount(2)==1) then - if (coordTypeKind==ESMF_TYPEKIND_R4) then - do j=lbound(dataPtrR4D2,2),ubound(dataPtrR4D2,2) - do i=lbound(dataPtrR4D2,1),ubound(dataPtrR4D2,1) - dataPtrR4D2(i,j) = & - (sin(real(l_member)*3.1416*(coord1PtrR4D1(i)+real(l_step))/180.) * & - cos(real(l_member)*3.1416*(coord2PtrR4D1(j)+real(l_step))/180.)) * & - l_amplitude+l_meanValue - enddo - enddo - elseif (coordTypeKind==ESMF_TYPEKIND_R8) then - do j=lbound(dataPtrR4D2,2),ubound(dataPtrR4D2,2) - do i=lbound(dataPtrR4D2,1),ubound(dataPtrR4D2,1) - dataPtrR4D2(i,j) = & - (sin(real(l_member)*3.1416*(coord1PtrR8D1(i)+real(l_step))/180.) * & - cos(real(l_member)*3.1416*(coord2PtrR8D1(j)+real(l_step))/180.)) * & - l_amplitude+l_meanValue - enddo - enddo - endif - else if (coordDimCount(1)==2 .and. coordDimCount(2)==1) then - if (coordTypeKind==ESMF_TYPEKIND_R4) then - do j=lbound(dataPtrR4D2,2),ubound(dataPtrR4D2,2) - do i=lbound(dataPtrR4D2,1),ubound(dataPtrR4D2,1) - dataPtrR4D2(i,j) = & - (sin(real(l_member)*3.1416*(coord1PtrR4D2(i,j)+real(l_step))/180.) * & - cos(real(l_member)*3.1416*(coord2PtrR4D1(j)+real(l_step))/180.)) * & - l_amplitude+l_meanValue - enddo - enddo - elseif (coordTypeKind==ESMF_TYPEKIND_R8) then - do j=lbound(dataPtrR4D2,2),ubound(dataPtrR4D2,2) - do i=lbound(dataPtrR4D2,1),ubound(dataPtrR4D2,1) - dataPtrR4D2(i,j) = & - (sin(real(l_member)*3.1416*(coord1PtrR8D2(i,j)+real(l_step))/180.) * & - cos(real(l_member)*3.1416*(coord2PtrR8D1(j)+real(l_step))/180.)) * & - l_amplitude+l_meanValue - enddo - enddo - endif - else if (coordDimCount(1)==1 .and. coordDimCount(2)==2) then - if (coordTypeKind==ESMF_TYPEKIND_R4) then - do j=lbound(dataPtrR4D2,2),ubound(dataPtrR4D2,2) - do i=lbound(dataPtrR4D2,1),ubound(dataPtrR4D2,1) - dataPtrR4D2(i,j) = & - (sin(real(l_member)*3.1416*(coord1PtrR4D1(i)+real(l_step))/180.) * & - cos(real(l_member)*3.1416*(coord2PtrR4D2(i,j)+real(l_step))/180.)) * & - l_amplitude+l_meanValue - enddo - enddo - elseif (coordTypeKind==ESMF_TYPEKIND_R8) then - do j=lbound(dataPtrR4D2,2),ubound(dataPtrR4D2,2) - do i=lbound(dataPtrR4D2,1),ubound(dataPtrR4D2,1) - dataPtrR4D2(i,j) = & - (sin(real(l_member)*3.1416*(coord1PtrR8D1(i)+real(l_step))/180.) * & - cos(real(l_member)*3.1416*(coord2PtrR8D2(i,j)+real(l_step))/180.)) * & - l_amplitude+l_meanValue - enddo - enddo - endif - else - ! only choice left is both 2d coordinate arrays - if (coordTypeKind==ESMF_TYPEKIND_R4) then - do j=lbound(dataPtrR4D2,2),ubound(dataPtrR4D2,2) - do i=lbound(dataPtrR4D2,1),ubound(dataPtrR4D2,1) - dataPtrR4D2(i,j) = & - (sin(real(l_member)*3.1416*(coord1PtrR4D2(i,j)+real(l_step))/180.) * & - cos(real(l_member)*3.1416*(coord2PtrR4D2(i,j)+real(l_step))/180.)) * & - l_amplitude+l_meanValue - enddo - enddo - elseif (coordTypeKind==ESMF_TYPEKIND_R8) then - do j=lbound(dataPtrR4D2,2),ubound(dataPtrR4D2,2) - do i=lbound(dataPtrR4D2,1),ubound(dataPtrR4D2,1) - dataPtrR4D2(i,j) = & - (sin(real(l_member)*3.1416*(coord1PtrR8D2(i,j)+real(l_step))/180.) * & - cos(real(l_member)*3.1416*(coord2PtrR8D2(i,j)+real(l_step))/180.)) * & - l_amplitude+l_meanValue - enddo - enddo - endif - endif - elseif (typekind==ESMF_TYPEKIND_R8) then - call ESMF_FieldGet(field, farrayPtr=dataPtrR8D2, rc=rc) - if (ESMF_LogFoundError(rcToCheck=rc, PASSTHRU)) return ! bail out - if (coordDimCount(1)==1 .and. coordDimCount(2)==1) then - if (coordTypeKind==ESMF_TYPEKIND_R4) then - do j=lbound(dataPtrR8D2,2),ubound(dataPtrR8D2,2) - do i=lbound(dataPtrR8D2,1),ubound(dataPtrR8D2,1) - dataPtrR8D2(i,j) = & - (sin(real(l_member)*3.1416*(coord1PtrR4D1(i)+real(l_step))/180.) * & - cos(real(l_member)*3.1416*(coord2PtrR4D1(j)+real(l_step))/180.)) * & - l_amplitude+l_meanValue - enddo - enddo - elseif (coordTypeKind==ESMF_TYPEKIND_R8) then - do j=lbound(dataPtrR8D2,2),ubound(dataPtrR8D2,2) - do i=lbound(dataPtrR8D2,1),ubound(dataPtrR8D2,1) - dataPtrR8D2(i,j) = & - (sin(real(l_member)*3.1416*(coord1PtrR8D1(i)+real(l_step))/180.) * & - cos(real(l_member)*3.1416*(coord2PtrR8D1(j)+real(l_step))/180.)) * & - l_amplitude+l_meanValue - enddo - enddo - endif - else if (coordDimCount(1)==2 .and. coordDimCount(2)==1) then - if (coordTypeKind==ESMF_TYPEKIND_R4) then - do j=lbound(dataPtrR8D2,2),ubound(dataPtrR8D2,2) - do i=lbound(dataPtrR8D2,1),ubound(dataPtrR8D2,1) - dataPtrR8D2(i,j) = & - (sin(real(l_member)*3.1416*(coord1PtrR4D2(i,j)+real(l_step))/180.) * & - cos(real(l_member)*3.1416*(coord2PtrR4D1(j)+real(l_step))/180.)) * & - l_amplitude+l_meanValue - enddo - enddo - elseif (coordTypeKind==ESMF_TYPEKIND_R8) then - do j=lbound(dataPtrR8D2,2),ubound(dataPtrR8D2,2) - do i=lbound(dataPtrR8D2,1),ubound(dataPtrR8D2,1) - dataPtrR8D2(i,j) = & - (sin(real(l_member)*3.1416*(coord1PtrR8D2(i,j)+real(l_step))/180.) * & - cos(real(l_member)*3.1416*(coord2PtrR8D1(j)+real(l_step))/180.)) * & - l_amplitude+l_meanValue - enddo - enddo - endif - else if (coordDimCount(1)==1 .and. coordDimCount(2)==2) then - if (coordTypeKind==ESMF_TYPEKIND_R4) then - do j=lbound(dataPtrR8D2,2),ubound(dataPtrR8D2,2) - do i=lbound(dataPtrR8D2,1),ubound(dataPtrR8D2,1) - dataPtrR8D2(i,j) = & - (sin(real(l_member)*3.1416*(coord1PtrR4D1(i)+real(l_step))/180.) * & - cos(real(l_member)*3.1416*(coord2PtrR4D2(i,j)+real(l_step))/180.)) * & - l_amplitude+l_meanValue - enddo - enddo - elseif (coordTypeKind==ESMF_TYPEKIND_R8) then - do j=lbound(dataPtrR8D2,2),ubound(dataPtrR8D2,2) - do i=lbound(dataPtrR8D2,1),ubound(dataPtrR8D2,1) - dataPtrR8D2(i,j) = & - (sin(real(l_member)*3.1416*(coord1PtrR8D1(i)+real(l_step))/180.) * & - cos(real(l_member)*3.1416*(coord2PtrR8D2(i,j)+real(l_step))/180.)) * & - l_amplitude+l_meanValue - enddo - enddo - endif - else - ! only choice left is both 2d coordinate arrays - if (coordTypeKind==ESMF_TYPEKIND_R4) then - do j=lbound(dataPtrR8D2,2),ubound(dataPtrR8D2,2) - do i=lbound(dataPtrR8D2,1),ubound(dataPtrR8D2,1) - dataPtrR8D2(i,j) = & - (sin(real(l_member)*3.1416*(coord1PtrR4D2(i,j)+real(l_step))/180.) * & - cos(real(l_member)*3.1416*(coord2PtrR4D2(i,j)+real(l_step))/180.)) * & - l_amplitude+l_meanValue - enddo - enddo - elseif (coordTypeKind==ESMF_TYPEKIND_R8) then - do j=lbound(dataPtrR8D2,2),ubound(dataPtrR8D2,2) - do i=lbound(dataPtrR8D2,1),ubound(dataPtrR8D2,1) - dataPtrR8D2(i,j) = & - (sin(real(l_member)*3.1416*(coord1PtrR8D2(i,j)+real(l_step))/180.) * & - cos(real(l_member)*3.1416*(coord2PtrR8D2(i,j)+real(l_step))/180.)) * & - l_amplitude+l_meanValue - enddo - enddo - endif - endif - else - call ESMF_LogSetError(ESMF_RC_ARG_BAD, & - msg="Unsupported typekind-rank and scheme combination requested.", & - CONTEXT, rcToReturn=rc) - return ! bail out - endif - elseif (rank==3) then - ! 3D sin*cos*sin pattern - ! TODO: support Meshes - call ESMF_GridGetCoord(grid, coordDim=1, farrayPtr=coord1PtrR8D3, rc=rc) - if (ESMF_LogFoundError(rcToCheck=rc, PASSTHRU)) return ! bail out - call ESMF_GridGetCoord(grid, coordDim=2, farrayPtr=coord2PtrR8D3, rc=rc) - if (ESMF_LogFoundError(rcToCheck=rc, PASSTHRU)) & - return ! bail out - call ESMF_GridGetCoord(grid, coordDim=3, farrayPtr=coord3PtrR8D3, rc=rc) - if (ESMF_LogFoundError(rcToCheck=rc, PASSTHRU)) return ! bail out - if (typekind==ESMF_TYPEKIND_R4) then - call ESMF_FieldGet(field, farrayPtr=dataPtrR4D3, rc=rc) - if (ESMF_LogFoundError(rcToCheck=rc, PASSTHRU)) return ! bail out - do k=lbound(dataPtrR4D3,3),ubound(dataPtrR4D3,3) - do j=lbound(dataPtrR4D3,2),ubound(dataPtrR4D3,2) - do i=lbound(dataPtrR4D3,1),ubound(dataPtrR4D3,1) - dataPtrR4D3(i,j,k) = & - (sin(real(l_member)*3.1416*(coord1PtrR8D3(i,j,k)+real(l_step))/180.) * & - cos(real(l_member)*3.1416*(coord2PtrR8D3(i,j,k)+real(l_step))/180.) * & - sin(real(l_member)*3.1416*(coord3PtrR8D3(i,j,k)+real(l_step))/180.)) * & - l_amplitude+l_meanValue - enddo - enddo - enddo - elseif (typekind==ESMF_TYPEKIND_R8) then - call ESMF_FieldGet(field, farrayPtr=dataPtrR8D3, rc=rc) - if (ESMF_LogFoundError(rcToCheck=rc, PASSTHRU)) return ! bail out - do k=lbound(dataPtrR8D3,3),ubound(dataPtrR8D3,3) - do j=lbound(dataPtrR8D3,2),ubound(dataPtrR8D3,2) - do i=lbound(dataPtrR8D3,1),ubound(dataPtrR8D3,1) - dataPtrR8D3(i,j,k) = & - (sin(real(l_member)*3.1416*(coord1PtrR8D3(i,j,k)+real(l_step))/180.) * & - cos(real(l_member)*3.1416*(coord2PtrR8D3(i,j,k)+real(l_step))/180.) * & - sin(real(l_member)*3.1416*(coord3PtrR8D3(i,j,k)+real(l_step))/180.)) * & - l_amplitude+l_meanValue - enddo - enddo - enddo - else - call ESMF_LogSetError(ESMF_RC_ARG_BAD, & - msg="Unsupported typekind-rank and scheme combination requested.", & - CONTEXT, rcToReturn=rc) - return ! bail out - endif - else - call ESMF_LogSetError(ESMF_RC_ARG_BAD, & - msg="Unsupported typekind-rank and scheme combination requested.", & - CONTEXT, rcToReturn=rc) - return ! bail out - endif - else if (trim(dataFillScheme)=="one") then - if (typekind==ESMF_TYPEKIND_R8 .and. rank==1) then - ! 1D all 1. - call ESMF_FieldGet(field, farrayPtr=dataPtrR8D1, rc=rc) - if (ESMF_LogFoundError(rcToCheck=rc, PASSTHRU)) return ! bail out - ! initialize the entire array - dataPtrR8D1 = 1._ESMF_KIND_R8 - elseif (typekind==ESMF_TYPEKIND_R4 .and. rank==1) then - ! 1D all 1. - call ESMF_FieldGet(field, farrayPtr=dataPtrR4D1, rc=rc) - if (ESMF_LogFoundError(rcToCheck=rc, PASSTHRU)) return ! bail out - ! initialize the entire array - dataPtrR4D1 = 1._ESMF_KIND_R4 - elseif (typekind==ESMF_TYPEKIND_R8 .and. rank==2) then - ! 2D all 1. - call ESMF_FieldGet(field, farrayPtr=dataPtrR8D2, rc=rc) - if (ESMF_LogFoundError(rcToCheck=rc, PASSTHRU)) return ! bail out - ! initialize the entire array - dataPtrR8D2 = 1._ESMF_KIND_R8 - elseif (typekind==ESMF_TYPEKIND_R4 .and. rank==2) then - ! 2D all 1. - call ESMF_FieldGet(field, farrayPtr=dataPtrR4D2, rc=rc) - if (ESMF_LogFoundError(rcToCheck=rc, PASSTHRU)) return ! bail out - ! initialize the entire array - dataPtrR4D2 = 1._ESMF_KIND_R4 - elseif (typekind==ESMF_TYPEKIND_R8 .and. rank==3) then - ! 3D all 1. - call ESMF_FieldGet(field, farrayPtr=dataPtrR8D3, rc=rc) - if (ESMF_LogFoundError(rcToCheck=rc, PASSTHRU)) return ! bail out - ! initialize the entire array - dataPtrR8D3 = 1._ESMF_KIND_R8 - elseif (typekind==ESMF_TYPEKIND_R4 .and. rank==3) then - ! 3D all 1. - call ESMF_FieldGet(field, farrayPtr=dataPtrR4D3, rc=rc) - if (ESMF_LogFoundError(rcToCheck=rc, PASSTHRU)) return ! bail out - ! initialize the entire array - dataPtrR4D3 = 1._ESMF_KIND_R4 - endif - else - call ESMF_LogSetError(ESMF_RC_ARG_BAD, & - msg="Unknown dataFillScheme requested.", & - CONTEXT, rcToReturn=rc) - return ! bail out - endif - - deallocate(coordDimCount,stat=stat) - if (ESMF_LogFoundDeallocError(statusToCheck=stat, & - msg="Deallocation of coordinate dimensions memory failed.", & - CONTEXT, rcToReturn=rc)) return ! bail out - - end subroutine -#undef METHOD - -!------------------------------------------------------------------------------ - -#define METHOD "WRFHYDRO_ESMF_FillState" -!BOP -! !IROUTINE: WRFHYDRO_ESMF_FillState_I4 - Fill data into State -! !INTERFACE: - ! call using generic interface: WRFHYDRO_ESMF_FillState - subroutine WRFHYDRO_ESMF_FillState_I4(state,value,rc) -! ! ARGUMENTS - type(ESMF_State), intent(in) :: state - integer(ESMF_KIND_I4),intent(in) :: value - integer, intent(out),optional :: rc -! !DESCRIPTION: -! Fill data into ESMF_State. -! -! The arguments are: -! \begin{description} -! \end{description} -! -!EOP - !----------------------------------------------------------------------------- - ! local variables - integer :: iIndex - integer :: itemCount - character(len=64),allocatable :: itemNameList(:) - type(ESMF_StateItem_Flag), allocatable :: itemTypeList(:) - type(ESMF_Field) :: field - integer :: stat - - if (present(rc)) rc = ESMF_SUCCESS - - call ESMF_StateGet(state,itemCount=itemCount, rc=rc) - if (ESMF_LogFoundError(rcToCheck=rc, PASSTHRU)) return ! bail out - - allocate(itemNameList(itemCount), itemTypeList(itemCount), stat=stat) - if (ESMF_LogFoundAllocError(statusToCheck=stat, & - msg="Allocation of state item list memory failed.", & - CONTEXT, rcToReturn=rc)) return ! bail out - - call ESMF_StateGet(state,itemNameList=itemNameList, & - itemTypeList=itemTypeList,rc=rc) - if (ESMF_LogFoundError(rcToCheck=rc, PASSTHRU)) return ! bail out - - do iIndex = 1, itemCount - if ( itemTypeList(iIndex) == ESMF_STATEITEM_FIELD) then - call ESMF_StateGet(state,field=field, & - itemName=itemNameList(iIndex),rc=rc) - if (ESMF_LogFoundError(rcToCheck=rc, PASSTHRU)) return ! bail out - call WRFHYDRO_ESMF_FillField(field,value=value,rc=rc) - if (ESMF_LogFoundError(rcToCheck=rc, PASSTHRU)) return ! bail out - endif - enddo - - deallocate(itemNameList, itemTypeList, stat=stat) - if (ESMF_LogFoundDeallocError(statusToCheck=stat, & - msg="Deallocation of state item list memory failed.", & - CONTEXT, rcToReturn=rc)) return ! bail out - - end subroutine -#undef METHOD - - !----------------------------------------------------------------------------- - -#define METHOD "WRFHYDRO_ESMF_FillState" -!BOP -! !IROUTINE: WRFHYDRO_ESMF_FillState_I8 - Fill data into State -! !INTERFACE: - ! call using generic interface: WRFHYDRO_ESMF_FillState - subroutine WRFHYDRO_ESMF_FillState_I8(state,value,rc) -! ! ARGUMENTS - type(ESMF_State), intent(in) :: state - integer(ESMF_KIND_I8),intent(in) :: value - integer, intent(out),optional :: rc -! !DESCRIPTION: -! Fill data into ESMF_State. -! -! The arguments are: -! \begin{description} -! \end{description} -! -!EOP - !----------------------------------------------------------------------------- - ! local variables - integer :: iIndex - integer :: itemCount - character(len=64),allocatable :: itemNameList(:) - type(ESMF_StateItem_Flag), allocatable :: itemTypeList(:) - type(ESMF_Field) :: field - integer :: stat - - if (present(rc)) rc = ESMF_SUCCESS - - call ESMF_StateGet(state,itemCount=itemCount, rc=rc) - if (ESMF_LogFoundError(rcToCheck=rc, PASSTHRU)) return ! bail out - - allocate(itemNameList(itemCount), itemTypeList(itemCount), stat=stat) - if (ESMF_LogFoundAllocError(statusToCheck=stat, & - msg="Allocation of state item list memory failed.", & - CONTEXT, rcToReturn=rc)) return ! bail out - - call ESMF_StateGet(state,itemNameList=itemNameList, & - itemTypeList=itemTypeList,rc=rc) - if (ESMF_LogFoundError(rcToCheck=rc, PASSTHRU)) return ! bail out - - do iIndex = 1, itemCount - if ( itemTypeList(iIndex) == ESMF_STATEITEM_FIELD) then - call ESMF_StateGet(state,field=field, & - itemName=itemNameList(iIndex),rc=rc) - if (ESMF_LogFoundError(rcToCheck=rc, PASSTHRU)) return ! bail out - call WRFHYDRO_ESMF_FillField(field,value=value,rc=rc) - if (ESMF_LogFoundError(rcToCheck=rc, PASSTHRU)) return ! bail out - endif - enddo - - deallocate(itemNameList, itemTypeList, stat=stat) - if (ESMF_LogFoundDeallocError(statusToCheck=stat, & - msg="Deallocation of state item list memory failed.", & - CONTEXT, rcToReturn=rc)) return ! bail out - - end subroutine -#undef METHOD - - !----------------------------------------------------------------------------- - -#define METHOD "WRFHYDRO_ESMF_FillState" -!BOP -! !IROUTINE: WRFHYDRO_ESMF_FillState_R4 - Fill data into State -! !INTERFACE: - ! call using generic interface: WRFHYDRO_ESMF_FillState - subroutine WRFHYDRO_ESMF_FillState_R4(state,value,rc) -! ! ARGUMENTS - type(ESMF_State), intent(in) :: state - real(ESMF_KIND_R4),intent(in) :: value - integer, intent(out),optional :: rc -! !DESCRIPTION: -! Fill data into ESMF_State. -! -! The arguments are: -! \begin{description} -! \end{description} -! -!EOP - !----------------------------------------------------------------------------- - ! local variables - integer :: iIndex - integer :: itemCount - character(len=64),allocatable :: itemNameList(:) - type(ESMF_StateItem_Flag), allocatable :: itemTypeList(:) - type(ESMF_Field) :: field - integer :: stat - - if (present(rc)) rc = ESMF_SUCCESS - - call ESMF_StateGet(state,itemCount=itemCount, rc=rc) - if (ESMF_LogFoundError(rcToCheck=rc, PASSTHRU)) return ! bail out - - allocate(itemNameList(itemCount), itemTypeList(itemCount), stat=stat) - if (ESMF_LogFoundAllocError(statusToCheck=stat, & - msg="Allocation of state item list memory failed.", & - CONTEXT, rcToReturn=rc)) return ! bail out - - call ESMF_StateGet(state,itemNameList=itemNameList, & - itemTypeList=itemTypeList,rc=rc) - if (ESMF_LogFoundError(rcToCheck=rc, PASSTHRU)) return ! bail out - - do iIndex = 1, itemCount - if ( itemTypeList(iIndex) == ESMF_STATEITEM_FIELD) then - call ESMF_StateGet(state,field=field, & - itemName=itemNameList(iIndex),rc=rc) - if (ESMF_LogFoundError(rcToCheck=rc, PASSTHRU)) return ! bail out - call WRFHYDRO_ESMF_FillField(field,value=value,rc=rc) - if (ESMF_LogFoundError(rcToCheck=rc, PASSTHRU)) return ! bail out - endif - enddo - - deallocate(itemNameList, itemTypeList, stat=stat) - if (ESMF_LogFoundDeallocError(statusToCheck=stat, & - msg="Deallocation of state item list memory failed.", & - CONTEXT, rcToReturn=rc)) return ! bail out - - end subroutine -#undef METHOD - - !----------------------------------------------------------------------------- - -#define METHOD "WRFHYDRO_ESMF_FillState" -!BOP -! !IROUTINE: WRFHYDRO_ESMF_FillState_R8 - Fill data into State -! !INTERFACE: - ! call using generic interface: WRFHYDRO_ESMF_FillState - subroutine WRFHYDRO_ESMF_FillState_R8(state,value,rc) -! ! ARGUMENTS - type(ESMF_State), intent(in) :: state - real(ESMF_KIND_R8),intent(in) :: value - integer, intent(out),optional :: rc -! !DESCRIPTION: -! Fill data into ESMF_State. -! -! The arguments are: -! \begin{description} -! \end{description} -! -!EOP - !----------------------------------------------------------------------------- - ! local variables - integer :: iIndex - integer :: itemCount - character(len=64),allocatable :: itemNameList(:) - type(ESMF_StateItem_Flag), allocatable :: itemTypeList(:) - type(ESMF_Field) :: field - integer :: stat - - if (present(rc)) rc = ESMF_SUCCESS - - call ESMF_StateGet(state,itemCount=itemCount, rc=rc) - if (ESMF_LogFoundError(rcToCheck=rc, PASSTHRU)) return ! bail out - - allocate(itemNameList(itemCount), itemTypeList(itemCount), stat=stat) - if (ESMF_LogFoundAllocError(statusToCheck=stat, & - msg="Allocation of state item list memory failed.", & - CONTEXT, rcToReturn=rc)) return ! bail out - - call ESMF_StateGet(state,itemNameList=itemNameList, & - itemTypeList=itemTypeList,rc=rc) - if (ESMF_LogFoundError(rcToCheck=rc, PASSTHRU)) return ! bail out - - do iIndex = 1, itemCount - if ( itemTypeList(iIndex) == ESMF_STATEITEM_FIELD) then - call ESMF_StateGet(state,field=field, & - itemName=itemNameList(iIndex),rc=rc) - if (ESMF_LogFoundError(rcToCheck=rc, PASSTHRU)) return ! bail out - call WRFHYDRO_ESMF_FillField(field,value=value,rc=rc) - if (ESMF_LogFoundError(rcToCheck=rc, PASSTHRU)) return ! bail out - endif - enddo - - deallocate(itemNameList, itemTypeList, stat=stat) - if (ESMF_LogFoundDeallocError(statusToCheck=stat, & - msg="Deallocation of state item list memory failed.", & - CONTEXT, rcToReturn=rc)) return ! bail out - - end subroutine -#undef METHOD - - !----------------------------------------------------------------------------- - -#define METHOD "WRFHYDRO_ESMF_FillState" -!BOP -! !IROUTINE: WRFHYDRO_ESMF_FillState_SCHEME - Fill data into State -! !INTERFACE: - ! call using generic interface: WRFHYDRO_ESMF_FillState - subroutine WRFHYDRO_ESMF_FillState_SCHEME(state,dataFillScheme,step,rc) -! ! ARGUMENTS - type(ESMF_State), intent(in) :: state - character(len=*), intent(in) :: dataFillScheme - integer, intent(in), optional :: step - integer, intent(out),optional :: rc -! !DESCRIPTION: -! Fill data into ESMF_State. -! -! The arguments are: -! \begin{description} -! \end{description} -! -!EOP - !----------------------------------------------------------------------------- - ! local variables - integer :: k - integer :: iIndex - integer :: itemCount - character(len=64),allocatable :: itemNameList(:) - type(ESMF_StateItem_Flag), allocatable :: itemTypeList(:) - type(ESMF_Field) :: field - integer :: stat - - if (present(rc)) rc = ESMF_SUCCESS - - call ESMF_StateGet(state,itemCount=itemCount,rc=rc) - if (ESMF_LogFoundError(rcToCheck=rc, PASSTHRU)) return ! bail out - - allocate(itemNameList(itemCount), itemTypeList(itemCount), stat=stat) - if (ESMF_LogFoundAllocError(statusToCheck=stat, & - msg="Allocation of state item list memory failed.", & - CONTEXT, rcToReturn=rc)) return ! bail out - - call ESMF_StateGet(state,itemNameList=itemNameList, & - itemTypeList=itemTypeList,rc=rc) - if (ESMF_LogFoundError(rcToCheck=rc, PASSTHRU)) return ! bail out - - k=1 ! initialize - do iIndex = 1, itemCount - if ( itemTypeList(iIndex) == ESMF_STATEITEM_FIELD) then - call ESMF_StateGet(state,field=field, & - itemName=itemNameList(iIndex),rc=rc) - if (ESMF_LogFoundError(rcToCheck=rc, PASSTHRU)) return ! bail out - call ESMF_FieldFill(field, dataFillScheme=dataFillScheme, & - member=k, step=step, rc=rc) - if (ESMF_LogFoundError(rcToCheck=rc, PASSTHRU)) return ! bail out - k=k+1 ! increment the member counter - endif - enddo - - deallocate(itemNameList, itemTypeList, stat=stat) - if (ESMF_LogFoundDeallocError(statusToCheck=stat, & - msg="Deallocation of state item list memory failed.", & - CONTEXT, rcToReturn=rc)) return ! bail out - - end subroutine -#undef METHOD - - !----------------------------------------------------------------------------- - -#define METHOD "WRFHYDRO_ESMF_FillFieldBundle" -!BOP -! !IROUTINE: WRFHYDRO_ESMF_FillFieldBundle_I4 - Fill data into FieldBundle -! !INTERFACE: - ! call using generic interface: WRFHYDRO_ESMF_FillFieldBundle - subroutine WRFHYDRO_ESMF_FillFieldBundle_I4(fieldbundle,value,rc) -! ! ARGUMENTS - type(ESMF_FieldBundle), intent(in) :: fieldbundle - integer(ESMF_KIND_I4),intent(in) :: value - integer, intent(out),optional :: rc -! !DESCRIPTION: -! Fill data into ESMF_FieldBundle. -! -! The arguments are: -! \begin{description} -! \end{description} -! -!EOP - !----------------------------------------------------------------------------- - ! local variables - integer :: fIndex - integer :: fieldCount - type(ESMF_Field),pointer :: fieldList(:) - integer :: stat - - if (present(rc)) rc = ESMF_SUCCESS - - call ESMF_FieldBundleGet(fieldbundle, & - fieldCount=fieldCount, rc=rc) - if (ESMF_LogFoundError(rcToCheck=rc, PASSTHRU)) return ! bail out - - allocate(fieldList(fieldCount),stat=stat) - if (ESMF_LogFoundAllocError(statusToCheck=stat, & - msg="Allocation of field lists failed.", & - CONTEXT, rcToReturn=rc)) return ! bail out - - call ESMF_FieldBundleGet(fieldbundle, & - fieldList=fieldList, rc=rc) - if (ESMF_LogFoundError(rcToCheck=rc, PASSTHRU)) return ! bail out - - do fIndex=1,fieldCount - call WRFHYDRO_ESMF_FillField(fieldList(fIndex),value=value,rc=rc) - if (ESMF_LogFoundError(rcToCheck=rc, PASSTHRU)) return ! bail out - enddo - - deallocate(fieldList,stat=stat) - if (ESMF_LogFoundDeallocError(statusToCheck=stat, & - msg="Deallocation of field lists failed.", & - CONTEXT, rcToReturn=rc)) return ! bail out - - end subroutine -#undef METHOD - - !----------------------------------------------------------------------------- - -#define METHOD "WRFHYDRO_ESMF_FillFieldBundle" -!BOP -! !IROUTINE: WRFHYDRO_ESMF_FillFieldBundle_I8 - Fill data into FieldBundle -! !INTERFACE: - ! call using generic interface: WRFHYDRO_ESMF_FillFieldBundle - subroutine WRFHYDRO_ESMF_FillFieldBundle_I8(fieldbundle,value,rc) -! ! ARGUMENTS - type(ESMF_FieldBundle), intent(in) :: fieldbundle - integer(ESMF_KIND_I8),intent(in) :: value - integer, intent(out),optional :: rc -! !DESCRIPTION: -! Fill data into ESMF_FieldBundle. -! -! The arguments are: -! \begin{description} -! \end{description} -! -!EOP - !----------------------------------------------------------------------------- - ! local variables - integer :: fIndex - integer :: fieldCount - type(ESMF_Field),pointer :: fieldList(:) - integer :: stat - - if (present(rc)) rc = ESMF_SUCCESS - - call ESMF_FieldBundleGet(fieldbundle, & - fieldCount=fieldCount, rc=rc) - if (ESMF_LogFoundError(rcToCheck=rc, PASSTHRU)) return ! bail out - - allocate(fieldList(fieldCount),stat=stat) - if (ESMF_LogFoundAllocError(statusToCheck=stat, & - msg="Allocation of field lists failed.", & - CONTEXT, rcToReturn=rc)) return ! bail out - - call ESMF_FieldBundleGet(fieldbundle, & - fieldList=fieldList, rc=rc) - if (ESMF_LogFoundError(rcToCheck=rc, PASSTHRU)) return ! bail out - - do fIndex=1,fieldCount - call WRFHYDRO_ESMF_FillField(fieldList(fIndex),value=value,rc=rc) - if (ESMF_LogFoundError(rcToCheck=rc, PASSTHRU)) return ! bail out - enddo - - deallocate(fieldList,stat=stat) - if (ESMF_LogFoundDeallocError(statusToCheck=stat, & - msg="Deallocation of field lists failed.", & - CONTEXT, rcToReturn=rc)) return ! bail out - - end subroutine -#undef METHOD - - !----------------------------------------------------------------------------- - -#define METHOD "WRFHYDRO_ESMF_FillFieldBundle" -!BOP -! !IROUTINE: WRFHYDRO_ESMF_FillFieldBundle_R4 - Fill data into FieldBundle -! !INTERFACE: - ! call using generic interface: WRFHYDRO_ESMF_FillFieldBundle - subroutine WRFHYDRO_ESMF_FillFieldBundle_R4(fieldbundle,value,rc) -! ! ARGUMENTS - type(ESMF_FieldBundle), intent(in) :: fieldbundle - real(ESMF_KIND_R4),intent(in) :: value - integer, intent(out),optional :: rc -! !DESCRIPTION: -! Fill data into ESMF_FieldBundle. -! -! The arguments are: -! \begin{description} -! \end{description} -! -!EOP - !----------------------------------------------------------------------------- - ! local variables - integer :: fIndex - integer :: fieldCount - type(ESMF_Field),pointer :: fieldList(:) - integer :: stat - - if (present(rc)) rc = ESMF_SUCCESS - - call ESMF_FieldBundleGet(fieldbundle, & - fieldCount=fieldCount, rc=rc) - if (ESMF_LogFoundError(rcToCheck=rc, PASSTHRU)) return ! bail out - - allocate(fieldList(fieldCount),stat=stat) - if (ESMF_LogFoundAllocError(statusToCheck=stat, & - msg="Allocation of field lists failed.", & - CONTEXT, rcToReturn=rc)) return ! bail out - - call ESMF_FieldBundleGet(fieldbundle, & - fieldList=fieldList, rc=rc) - if (ESMF_LogFoundError(rcToCheck=rc, PASSTHRU)) return ! bail out - - do fIndex=1,fieldCount - call WRFHYDRO_ESMF_FillField(fieldList(fIndex),value=value,rc=rc) - if (ESMF_LogFoundError(rcToCheck=rc, PASSTHRU)) return ! bail out - enddo - - deallocate(fieldList,stat=stat) - if (ESMF_LogFoundDeallocError(statusToCheck=stat, & - msg="Deallocation of field lists failed.", & - CONTEXT, rcToReturn=rc)) return ! bail out - - end subroutine -#undef METHOD - - !----------------------------------------------------------------------------- - -#define METHOD "WRFHYDRO_ESMF_FillFieldBundle" -!BOP -! !IROUTINE: WRFHYDRO_ESMF_FillFieldBundle_R8 - Fill data into FieldBundle -! !INTERFACE: - ! call using generic interface: WRFHYDRO_ESMF_FillFieldBundle - subroutine WRFHYDRO_ESMF_FillFieldBundle_R8(fieldbundle,value,rc) -! ! ARGUMENTS - type(ESMF_FieldBundle), intent(in) :: fieldbundle - real(ESMF_KIND_R8),intent(in) :: value - integer, intent(out),optional :: rc -! !DESCRIPTION: -! Fill data into ESMF_FieldBundle. -! -! The arguments are: -! \begin{description} -! \end{description} -! -!EOP - !----------------------------------------------------------------------------- - ! local variables - integer :: fIndex - integer :: fieldCount - type(ESMF_Field),pointer :: fieldList(:) - integer :: stat - - if (present(rc)) rc = ESMF_SUCCESS - - call ESMF_FieldBundleGet(fieldbundle, & - fieldCount=fieldCount, rc=rc) - if (ESMF_LogFoundError(rcToCheck=rc, PASSTHRU)) return ! bail out - - allocate(fieldList(fieldCount),stat=stat) - if (ESMF_LogFoundAllocError(statusToCheck=stat, & - msg="Allocation of field lists failed.", & - CONTEXT, rcToReturn=rc)) return ! bail out - - call ESMF_FieldBundleGet(fieldbundle, & - fieldList=fieldList, rc=rc) - if (ESMF_LogFoundError(rcToCheck=rc, PASSTHRU)) return ! bail out - - do fIndex=1,fieldCount - call WRFHYDRO_ESMF_FillField(fieldList(fIndex),value=value,rc=rc) - if (ESMF_LogFoundError(rcToCheck=rc, PASSTHRU)) return ! bail out - enddo - - deallocate(fieldList,stat=stat) - if (ESMF_LogFoundDeallocError(statusToCheck=stat, & - msg="Deallocation of field lists failed.", & - CONTEXT, rcToReturn=rc)) return ! bail out - - end subroutine -#undef METHOD - - !----------------------------------------------------------------------------- - -#define METHOD "WRFHYDRO_ESMF_FillFieldBundle" -!BOP -! !IROUTINE: WRFHYDRO_ESMF_FillFieldBundle_SCHEME - Fill data into FieldBundle -! !INTERFACE: - ! call using generic interface: WRFHYDRO_ESMF_FillFieldBundle - subroutine WRFHYDRO_ESMF_FillFieldBundle_SCHEME(fieldbundle,dataFillScheme,step,rc) -! ! ARGUMENTS - type(ESMF_FieldBundle), intent(in) :: fieldbundle - character(len=*), intent(in) :: dataFillScheme - integer, intent(in), optional :: step - integer, intent(out),optional :: rc -! !DESCRIPTION: -! Fill data into ESMF_FieldBundle. -! -! The arguments are: -! \begin{description} -! \end{description} -! -!EOP - !----------------------------------------------------------------------------- - ! local variables - integer :: fIndex - integer :: fieldCount - type(ESMF_Field),pointer :: fieldList(:) - integer :: stat - - if (present(rc)) rc = ESMF_SUCCESS - - call ESMF_FieldBundleGet(fieldbundle, & - fieldCount=fieldCount, rc=rc) - if (ESMF_LogFoundError(rcToCheck=rc, PASSTHRU)) return ! bail out - - allocate(fieldList(fieldCount),stat=stat) - if (ESMF_LogFoundAllocError(statusToCheck=stat, & - msg="Allocation of field lists failed.", & - CONTEXT, rcToReturn=rc)) return ! bail out - - call ESMF_FieldBundleGet(fieldbundle, & - fieldList=fieldList, rc=rc) - if (ESMF_LogFoundError(rcToCheck=rc, PASSTHRU)) return ! bail out - - do fIndex=1,fieldCount - call ESMF_FieldFill(fieldList(fIndex), dataFillScheme=dataFillScheme, & - member=fIndex, step=step, rc=rc) - if (ESMF_LogFoundError(rcToCheck=rc, PASSTHRU)) return ! bail out - enddo - - deallocate(fieldList,stat=stat) - if (ESMF_LogFoundDeallocError(statusToCheck=stat, & - msg="Deallocation of field lists failed.", & - CONTEXT, rcToReturn=rc)) return ! bail out - - end subroutine -#undef METHOD - - !----------------------------------------------------------------------------- - -#define METHOD "WRFHYDRO_ESMF_FillField" -!BOP -! !IROUTINE: WRFHYDRO_ESMF_FillField_I4 - Fill data into Field -! !INTERFACE: - ! call using generic interface: WRFHYDRO_ESMF_FillField - subroutine WRFHYDRO_ESMF_FillField_I4(field,value,rc) -! ! ARGUMENTS - type(ESMF_Field), intent(in) :: field - integer(ESMF_KIND_I4),intent(in) :: value - integer, intent(out),optional :: rc -! !DESCRIPTION: -! Fill data into ESMF_Field. -! -! The arguments are: -! \begin{description} -! \end{description} -! -!EOP - !----------------------------------------------------------------------------- - ! local variables - type(ESMF_Array) :: array - - if (present(rc)) rc = ESMF_SUCCESS - - call ESMF_FieldGet(field,array=array,rc=rc) - if (ESMF_LogFoundError(rcToCheck=rc, PASSTHRU)) return ! bail out - - call WRFHYDRO_ESMF_FillArray(array,value=value,rc=rc) - if (ESMF_LogFoundError(rcToCheck=rc, PASSTHRU)) return ! bail out - - end subroutine -#undef METHOD - - !----------------------------------------------------------------------------- - -#define METHOD "WRFHYDRO_ESMF_FillField" -!BOP -! !IROUTINE: WRFHYDRO_ESMF_FillField_I8 - Fill data into Field -! !INTERFACE: - ! call using generic interface: WRFHYDRO_ESMF_FillField - subroutine WRFHYDRO_ESMF_FillField_I8(field,value,rc) -! ! ARGUMENTS - type(ESMF_Field), intent(in) :: field - integer(ESMF_KIND_I8),intent(in) :: value - integer, intent(out),optional :: rc -! !DESCRIPTION: -! Fill data into ESMF_Field. -! -! The arguments are: -! \begin{description} -! \end{description} -! -!EOP - !----------------------------------------------------------------------------- - ! local variables - type(ESMF_Array) :: array - - if (present(rc)) rc = ESMF_SUCCESS - - call ESMF_FieldGet(field,array=array,rc=rc) - if (ESMF_LogFoundError(rcToCheck=rc, PASSTHRU)) return ! bail out - - call WRFHYDRO_ESMF_FillArray(array,value=value,rc=rc) - if (ESMF_LogFoundError(rcToCheck=rc, PASSTHRU)) return ! bail out - - end subroutine -#undef METHOD - - !----------------------------------------------------------------------------- - -#define METHOD "WRFHYDRO_ESMF_FillField" -!BOP -! !IROUTINE: WRFHYDRO_ESMF_FillField_R4 - Fill data into Field -! !INTERFACE: - ! call using generic interface: WRFHYDRO_ESMF_FillField - subroutine WRFHYDRO_ESMF_FillField_R4(field,value,rc) -! ! ARGUMENTS - type(ESMF_Field), intent(in) :: field - real(ESMF_KIND_R4),intent(in) :: value - integer, intent(out),optional :: rc -! !DESCRIPTION: -! Fill data into ESMF_Field. -! -! The arguments are: -! \begin{description} -! \end{description} -! -!EOP - !----------------------------------------------------------------------------- - ! local variables - type(ESMF_Array) :: array - - if (present(rc)) rc = ESMF_SUCCESS - - call ESMF_FieldGet(field,array=array,rc=rc) - if (ESMF_LogFoundError(rcToCheck=rc, PASSTHRU)) return ! bail out - - call WRFHYDRO_ESMF_FillArray(array,value=value,rc=rc) - if (ESMF_LogFoundError(rcToCheck=rc, PASSTHRU)) return ! bail out - - end subroutine -#undef METHOD - - !----------------------------------------------------------------------------- - -#define METHOD "WRFHYDRO_ESMF_FillField" -!BOP -! !IROUTINE: WRFHYDRO_ESMF_FillField_R8 - Fill data into Field -! !INTERFACE: - ! call using generic interface: WRFHYDRO_ESMF_FillField - subroutine WRFHYDRO_ESMF_FillField_R8(field,value,rc) -! ! ARGUMENTS - type(ESMF_Field), intent(in) :: field - real(ESMF_KIND_R8),intent(in) :: value - integer, intent(out),optional :: rc -! !DESCRIPTION: -! Fill data into ESMF_Field. -! -! The arguments are: -! \begin{description} -! \end{description} -! -!EOP - !----------------------------------------------------------------------------- - ! local variables - type(ESMF_Array) :: array - - if (present(rc)) rc = ESMF_SUCCESS - - call ESMF_FieldGet(field,array=array,rc=rc) - if (ESMF_LogFoundError(rcToCheck=rc, PASSTHRU)) return ! bail out - - call WRFHYDRO_ESMF_FillArray(array,value=value,rc=rc) - if (ESMF_LogFoundError(rcToCheck=rc, PASSTHRU)) return ! bail out - - end subroutine -#undef METHOD - - !----------------------------------------------------------------------------- - -#define METHOD "WRFHYDRO_ESMF_FillArray" -!BOP -! !IROUTINE: WRFHYDRO_ESMF_FillArray_I4 - Fill data into Array -! !INTERFACE: - ! call using generic interface: WRFHYDRO_ESMF_FillArray - subroutine WRFHYDRO_ESMF_FillArray_I4(array,value,rc) -! ! ARGUMENTS - type(ESMF_Array), intent(in) :: array - integer(ESMF_KIND_I4),intent(in) :: value - integer, intent(out),optional :: rc -! !DESCRIPTION: -! Fill data into ESMF_Array. -! -! The arguments are: -! \begin{description} -! \end{description} -! -!EOP - !----------------------------------------------------------------------------- - ! local variables - integer(ESMF_KIND_I4),pointer :: farray_I41D(:) - integer(ESMF_KIND_I4),pointer :: farray_I42D(:,:) - integer(ESMF_KIND_I4),pointer :: farray_I43D(:,:,:) - integer(ESMF_KIND_I8),pointer :: farray_I81D(:) - integer(ESMF_KIND_I8),pointer :: farray_I82D(:,:) - integer(ESMF_KIND_I8),pointer :: farray_I83D(:,:,:) - real(ESMF_KIND_R4),pointer :: farray_R41D(:) - real(ESMF_KIND_R4),pointer :: farray_R42D(:,:) - real(ESMF_KIND_R4),pointer :: farray_R43D(:,:,:) - real(ESMF_KIND_R8),pointer :: farray_R81D(:) - real(ESMF_KIND_R8),pointer :: farray_R82D(:,:) - real(ESMF_KIND_R8),pointer :: farray_R83D(:,:,:) - type(ESMF_TypeKind_Flag) :: typekind - integer :: rank - integer :: localDeCount - integer :: deIndex - - if (present(rc)) rc = ESMF_SUCCESS - - call ESMF_ArrayGet(array,typekind=typekind,rank=rank,localDeCount=localDeCount,rc=rc) - if (ESMF_LogFoundError(rcToCheck=rc, PASSTHRU)) return ! bail out - - if (rank == 1) then - if (typekind == ESMF_TYPEKIND_I4) then - do deIndex=0,localDeCount-1 - call ESMF_ArrayGet(array,farrayPtr=farray_I41D,localDe=deIndex,rc=rc) - if (ESMF_LogFoundError(rcToCheck=rc, PASSTHRU)) return ! bail out - farray_I41D = value - enddo - elseif (typekind == ESMF_TYPEKIND_I8) then - do deIndex=0,localDeCount-1 - call ESMF_ArrayGet(array,farrayPtr=farray_I81D,localDe=deIndex,rc=rc) - if (ESMF_LogFoundError(rcToCheck=rc, PASSTHRU)) return ! bail out - farray_I81D = value - enddo - elseif (typekind == ESMF_TYPEKIND_R4) then - do deIndex=0,localDeCount-1 - call ESMF_ArrayGet(array,farrayPtr=farray_R41D,localDe=deIndex,rc=rc) - if (ESMF_LogFoundError(rcToCheck=rc, PASSTHRU)) return ! bail out - farray_R41D = value - enddo - elseif (typekind == ESMF_TYPEKIND_R8) then - do deIndex=0,localDeCount-1 - call ESMF_ArrayGet(array,farrayPtr=farray_R81D,localDe=deIndex,rc=rc) - if (ESMF_LogFoundError(rcToCheck=rc, PASSTHRU)) return ! bail out - farray_R81D = value - enddo - else - call ESMF_LogSetError(rcToCheck=ESMF_RC_ARG_RANK, & - msg="Cannot fill ESMF Array because typekind is not supported", & - CONTEXT, rcToReturn=rc) - return - endif - elseif (rank == 2) then - if (typekind == ESMF_TYPEKIND_I4) then - do deIndex=0,localDeCount-1 - call ESMF_ArrayGet(array,farrayPtr=farray_I42D,localDe=deIndex,rc=rc) - if (ESMF_LogFoundError(rcToCheck=rc, PASSTHRU)) return ! bail out - farray_I42D = value - enddo - elseif (typekind == ESMF_TYPEKIND_I8) then - do deIndex=0,localDeCount-1 - call ESMF_ArrayGet(array,farrayPtr=farray_I82D,localDe=deIndex,rc=rc) - if (ESMF_LogFoundError(rcToCheck=rc, PASSTHRU)) return ! bail out - farray_I82D = value - enddo - elseif (typekind == ESMF_TYPEKIND_R4) then - do deIndex=0,localDeCount-1 - call ESMF_ArrayGet(array,farrayPtr=farray_R42D,localDe=deIndex,rc=rc) - if (ESMF_LogFoundError(rcToCheck=rc, PASSTHRU)) return ! bail out - farray_R42D = value - enddo - elseif (typekind == ESMF_TYPEKIND_R8) then - do deIndex=0,localDeCount-1 - call ESMF_ArrayGet(array,farrayPtr=farray_R82D,localDe=deIndex,rc=rc) - if (ESMF_LogFoundError(rcToCheck=rc, PASSTHRU)) return ! bail out - farray_R82D = value - enddo - else - call ESMF_LogSetError(rcToCheck=ESMF_RC_ARG_RANK, & - msg="Cannot fill ESMF Array because typekind is not supported", & - CONTEXT, rcToReturn=rc) - return - endif - elseif (rank == 3) then - if (typekind == ESMF_TYPEKIND_I4) then - do deIndex=0,localDeCount-1 - call ESMF_ArrayGet(array,farrayPtr=farray_I43D,localDe=deIndex,rc=rc) - if (ESMF_LogFoundError(rcToCheck=rc, PASSTHRU)) return ! bail out - farray_I43D = value - enddo - elseif (typekind == ESMF_TYPEKIND_I8) then - do deIndex=0,localDeCount-1 - call ESMF_ArrayGet(array,farrayPtr=farray_I83D,localDe=deIndex,rc=rc) - if (ESMF_LogFoundError(rcToCheck=rc, PASSTHRU)) return ! bail out - farray_I83D = value - enddo - elseif (typekind == ESMF_TYPEKIND_R4) then - do deIndex=0,localDeCount-1 - call ESMF_ArrayGet(array,farrayPtr=farray_R43D,localDe=deIndex,rc=rc) - if (ESMF_LogFoundError(rcToCheck=rc, PASSTHRU)) return ! bail out - farray_R43D = value - enddo - elseif (typekind == ESMF_TYPEKIND_R8) then - do deIndex=0,localDeCount-1 - call ESMF_ArrayGet(array,farrayPtr=farray_R83D,localDe=deIndex,rc=rc) - if (ESMF_LogFoundError(rcToCheck=rc, PASSTHRU)) return ! bail out - farray_R83D = value - enddo - else - call ESMF_LogSetError(rcToCheck=ESMF_RC_ARG_RANK, & - msg="Cannot fill ESMF Array because typekind is not supported", & - CONTEXT, rcToReturn=rc) - return - endif - else - call ESMF_LogSetError(rcToCheck=ESMF_RC_ARG_RANK, & - msg="Cannot fill ESMF Array because rank is not supported", & - CONTEXT, rcToReturn=rc) - return - endif - - end subroutine -#undef METHOD - - !----------------------------------------------------------------------------- - -#define METHOD "WRFHYDRO_ESMF_FillArray" -!BOP -! !IROUTINE: WRFHYDRO_ESMF_FillArray_I8 - Fill data into Array -! !INTERFACE: - ! call using generic interface: WRFHYDRO_ESMF_FillArray - subroutine WRFHYDRO_ESMF_FillArray_I8(array,value,rc) -! ! ARGUMENTS - type(ESMF_Array), intent(in) :: array - integer(ESMF_KIND_I8),intent(in) :: value - integer, intent(out),optional :: rc -! !DESCRIPTION: -! Fill data into ESMF_Array. -! -! The arguments are: -! \begin{description} -! \end{description} -! -!EOP - !----------------------------------------------------------------------------- - ! local variables - integer(ESMF_KIND_I4),pointer :: farray_I41D(:) - integer(ESMF_KIND_I4),pointer :: farray_I42D(:,:) - integer(ESMF_KIND_I4),pointer :: farray_I43D(:,:,:) - integer(ESMF_KIND_I8),pointer :: farray_I81D(:) - integer(ESMF_KIND_I8),pointer :: farray_I82D(:,:) - integer(ESMF_KIND_I8),pointer :: farray_I83D(:,:,:) - real(ESMF_KIND_R4),pointer :: farray_R41D(:) - real(ESMF_KIND_R4),pointer :: farray_R42D(:,:) - real(ESMF_KIND_R4),pointer :: farray_R43D(:,:,:) - real(ESMF_KIND_R8),pointer :: farray_R81D(:) - real(ESMF_KIND_R8),pointer :: farray_R82D(:,:) - real(ESMF_KIND_R8),pointer :: farray_R83D(:,:,:) - type(ESMF_TypeKind_Flag) :: typekind - integer :: rank - integer :: localDeCount - integer :: deIndex - - if (present(rc)) rc = ESMF_SUCCESS - - call ESMF_ArrayGet(array,typekind=typekind,rank=rank,localDeCount=localDeCount,rc=rc) - if (ESMF_LogFoundError(rcToCheck=rc, PASSTHRU)) return ! bail out - - if (rank == 1) then - if (typekind == ESMF_TYPEKIND_I4) then - do deIndex=0,localDeCount-1 - call ESMF_ArrayGet(array,farrayPtr=farray_I41D,localDe=deIndex,rc=rc) - if (ESMF_LogFoundError(rcToCheck=rc, PASSTHRU)) return ! bail out - farray_I41D = value - enddo - elseif (typekind == ESMF_TYPEKIND_I8) then - do deIndex=0,localDeCount-1 - call ESMF_ArrayGet(array,farrayPtr=farray_I81D,localDe=deIndex,rc=rc) - if (ESMF_LogFoundError(rcToCheck=rc, PASSTHRU)) return ! bail out - farray_I81D = value - enddo - elseif (typekind == ESMF_TYPEKIND_R4) then - do deIndex=0,localDeCount-1 - call ESMF_ArrayGet(array,farrayPtr=farray_R41D,localDe=deIndex,rc=rc) - if (ESMF_LogFoundError(rcToCheck=rc, PASSTHRU)) return ! bail out - farray_R41D = value - enddo - elseif (typekind == ESMF_TYPEKIND_R8) then - do deIndex=0,localDeCount-1 - call ESMF_ArrayGet(array,farrayPtr=farray_R81D,localDe=deIndex,rc=rc) - if (ESMF_LogFoundError(rcToCheck=rc, PASSTHRU)) return ! bail out - farray_R81D = value - enddo - else - call ESMF_LogSetError(rcToCheck=ESMF_RC_ARG_RANK, & - msg="Cannot fill ESMF Array because typekind is not supported", & - CONTEXT, rcToReturn=rc) - return - endif - elseif (rank == 2) then - if (typekind == ESMF_TYPEKIND_I4) then - do deIndex=0,localDeCount-1 - call ESMF_ArrayGet(array,farrayPtr=farray_I42D,localDe=deIndex,rc=rc) - if (ESMF_LogFoundError(rcToCheck=rc, PASSTHRU)) return ! bail out - farray_I42D = value - enddo - elseif (typekind == ESMF_TYPEKIND_I8) then - do deIndex=0,localDeCount-1 - call ESMF_ArrayGet(array,farrayPtr=farray_I82D,localDe=deIndex,rc=rc) - if (ESMF_LogFoundError(rcToCheck=rc, PASSTHRU)) return ! bail out - farray_I82D = value - enddo - elseif (typekind == ESMF_TYPEKIND_R4) then - do deIndex=0,localDeCount-1 - call ESMF_ArrayGet(array,farrayPtr=farray_R42D,localDe=deIndex,rc=rc) - if (ESMF_LogFoundError(rcToCheck=rc, PASSTHRU)) return ! bail out - farray_R42D = value - enddo - elseif (typekind == ESMF_TYPEKIND_R8) then - do deIndex=0,localDeCount-1 - call ESMF_ArrayGet(array,farrayPtr=farray_R82D,localDe=deIndex,rc=rc) - if (ESMF_LogFoundError(rcToCheck=rc, PASSTHRU)) return ! bail out - farray_R82D = value - enddo - else - call ESMF_LogSetError(rcToCheck=ESMF_RC_ARG_RANK, & - msg="Cannot fill ESMF Array because typekind is not supported", & - CONTEXT, rcToReturn=rc) - return - endif - elseif (rank == 3) then - if (typekind == ESMF_TYPEKIND_I4) then - do deIndex=0,localDeCount-1 - call ESMF_ArrayGet(array,farrayPtr=farray_I43D,localDe=deIndex,rc=rc) - if (ESMF_LogFoundError(rcToCheck=rc, PASSTHRU)) return ! bail out - farray_I43D = value - enddo - elseif (typekind == ESMF_TYPEKIND_I8) then - do deIndex=0,localDeCount-1 - call ESMF_ArrayGet(array,farrayPtr=farray_I83D,localDe=deIndex,rc=rc) - if (ESMF_LogFoundError(rcToCheck=rc, PASSTHRU)) return ! bail out - farray_I83D = value - enddo - elseif (typekind == ESMF_TYPEKIND_R4) then - do deIndex=0,localDeCount-1 - call ESMF_ArrayGet(array,farrayPtr=farray_R43D,localDe=deIndex,rc=rc) - if (ESMF_LogFoundError(rcToCheck=rc, PASSTHRU)) return ! bail out - farray_R43D = value - enddo - elseif (typekind == ESMF_TYPEKIND_R8) then - do deIndex=0,localDeCount-1 - call ESMF_ArrayGet(array,farrayPtr=farray_R83D,localDe=deIndex,rc=rc) - if (ESMF_LogFoundError(rcToCheck=rc, PASSTHRU)) return ! bail out - farray_R83D = value - enddo - else - call ESMF_LogSetError(rcToCheck=ESMF_RC_ARG_RANK, & - msg="Cannot fill ESMF Array because typekind is not supported", & - CONTEXT, rcToReturn=rc) - return - endif - else - call ESMF_LogSetError(rcToCheck=ESMF_RC_ARG_RANK, & - msg="Cannot fill ESMF Array because rank is not supported", & - CONTEXT, rcToReturn=rc) - return - endif - - end subroutine -#undef METHOD - - !----------------------------------------------------------------------------- - -#define METHOD "WRFHYDRO_ESMF_FillArray" -!BOP -! !IROUTINE: WRFHYDRO_ESMF_FillArray_R4 - Fill data into Array -! !INTERFACE: - ! call using generic interface: WRFHYDRO_ESMF_FillArray - subroutine WRFHYDRO_ESMF_FillArray_R4(array,value,rc) -! ! ARGUMENTS - type(ESMF_Array), intent(in) :: array - real(ESMF_KIND_R4),intent(in) :: value - integer, intent(out),optional :: rc -! !DESCRIPTION: -! Fill data into ESMF_Array. -! -! The arguments are: -! \begin{description} -! \end{description} -! -!EOP - !----------------------------------------------------------------------------- - ! local variables - integer(ESMF_KIND_I4),pointer :: farray_I41D(:) - integer(ESMF_KIND_I4),pointer :: farray_I42D(:,:) - integer(ESMF_KIND_I4),pointer :: farray_I43D(:,:,:) - integer(ESMF_KIND_I8),pointer :: farray_I81D(:) - integer(ESMF_KIND_I8),pointer :: farray_I82D(:,:) - integer(ESMF_KIND_I8),pointer :: farray_I83D(:,:,:) - real(ESMF_KIND_R4),pointer :: farray_R41D(:) - real(ESMF_KIND_R4),pointer :: farray_R42D(:,:) - real(ESMF_KIND_R4),pointer :: farray_R43D(:,:,:) - real(ESMF_KIND_R8),pointer :: farray_R81D(:) - real(ESMF_KIND_R8),pointer :: farray_R82D(:,:) - real(ESMF_KIND_R8),pointer :: farray_R83D(:,:,:) - type(ESMF_TypeKind_Flag) :: typekind - integer :: rank - integer :: localDeCount - integer :: deIndex - - if (present(rc)) rc = ESMF_SUCCESS - - call ESMF_ArrayGet(array,typekind=typekind,rank=rank,localDeCount=localDeCount,rc=rc) - if (ESMF_LogFoundError(rcToCheck=rc, PASSTHRU)) return ! bail out - - if (rank == 1) then - if (typekind == ESMF_TYPEKIND_I4) then - do deIndex=0,localDeCount-1 - call ESMF_ArrayGet(array,farrayPtr=farray_I41D,localDe=deIndex,rc=rc) - if (ESMF_LogFoundError(rcToCheck=rc, PASSTHRU)) return ! bail out - farray_I41D = value - enddo - elseif (typekind == ESMF_TYPEKIND_I8) then - do deIndex=0,localDeCount-1 - call ESMF_ArrayGet(array,farrayPtr=farray_I81D,localDe=deIndex,rc=rc) - if (ESMF_LogFoundError(rcToCheck=rc, PASSTHRU)) return ! bail out - farray_I81D = value - enddo - elseif (typekind == ESMF_TYPEKIND_R4) then - do deIndex=0,localDeCount-1 - call ESMF_ArrayGet(array,farrayPtr=farray_R41D,localDe=deIndex,rc=rc) - if (ESMF_LogFoundError(rcToCheck=rc, PASSTHRU)) return ! bail out - farray_R41D = value - enddo - elseif (typekind == ESMF_TYPEKIND_R8) then - do deIndex=0,localDeCount-1 - call ESMF_ArrayGet(array,farrayPtr=farray_R81D,localDe=deIndex,rc=rc) - if (ESMF_LogFoundError(rcToCheck=rc, PASSTHRU)) return ! bail out - farray_R81D = value - enddo - else - call ESMF_LogSetError(rcToCheck=ESMF_RC_ARG_RANK, & - msg="Cannot fill ESMF Array because typekind is not supported", & - CONTEXT, rcToReturn=rc) - return - endif - elseif (rank == 2) then - if (typekind == ESMF_TYPEKIND_I4) then - do deIndex=0,localDeCount-1 - call ESMF_ArrayGet(array,farrayPtr=farray_I42D,localDe=deIndex,rc=rc) - if (ESMF_LogFoundError(rcToCheck=rc, PASSTHRU)) return ! bail out - farray_I42D = value - enddo - elseif (typekind == ESMF_TYPEKIND_I8) then - do deIndex=0,localDeCount-1 - call ESMF_ArrayGet(array,farrayPtr=farray_I82D,localDe=deIndex,rc=rc) - if (ESMF_LogFoundError(rcToCheck=rc, PASSTHRU)) return ! bail out - farray_I82D = value - enddo - elseif (typekind == ESMF_TYPEKIND_R4) then - do deIndex=0,localDeCount-1 - call ESMF_ArrayGet(array,farrayPtr=farray_R42D,localDe=deIndex,rc=rc) - if (ESMF_LogFoundError(rcToCheck=rc, PASSTHRU)) return ! bail out - farray_R42D = value - enddo - elseif (typekind == ESMF_TYPEKIND_R8) then - do deIndex=0,localDeCount-1 - call ESMF_ArrayGet(array,farrayPtr=farray_R82D,localDe=deIndex,rc=rc) - if (ESMF_LogFoundError(rcToCheck=rc, PASSTHRU)) return ! bail out - farray_R82D = value - enddo - else - call ESMF_LogSetError(rcToCheck=ESMF_RC_ARG_RANK, & - msg="Cannot fill ESMF Array because typekind is not supported", & - CONTEXT, rcToReturn=rc) - return - endif - elseif (rank == 3) then - if (typekind == ESMF_TYPEKIND_I4) then - do deIndex=0,localDeCount-1 - call ESMF_ArrayGet(array,farrayPtr=farray_I43D,localDe=deIndex,rc=rc) - if (ESMF_LogFoundError(rcToCheck=rc, PASSTHRU)) return ! bail out - farray_I43D = value - enddo - elseif (typekind == ESMF_TYPEKIND_I8) then - do deIndex=0,localDeCount-1 - call ESMF_ArrayGet(array,farrayPtr=farray_I83D,localDe=deIndex,rc=rc) - if (ESMF_LogFoundError(rcToCheck=rc, PASSTHRU)) return ! bail out - farray_I83D = value - enddo - elseif (typekind == ESMF_TYPEKIND_R4) then - do deIndex=0,localDeCount-1 - call ESMF_ArrayGet(array,farrayPtr=farray_R43D,localDe=deIndex,rc=rc) - if (ESMF_LogFoundError(rcToCheck=rc, PASSTHRU)) return ! bail out - farray_R43D = value - enddo - elseif (typekind == ESMF_TYPEKIND_R8) then - do deIndex=0,localDeCount-1 - call ESMF_ArrayGet(array,farrayPtr=farray_R83D,localDe=deIndex,rc=rc) - if (ESMF_LogFoundError(rcToCheck=rc, PASSTHRU)) return ! bail out - farray_R83D = value - enddo - else - call ESMF_LogSetError(rcToCheck=ESMF_RC_ARG_RANK, & - msg="Cannot fill ESMF Array because typekind is not supported", & - CONTEXT, rcToReturn=rc) - return - endif - else - call ESMF_LogSetError(rcToCheck=ESMF_RC_ARG_RANK, & - msg="Cannot fill ESMF Array because rank is not supported", & - CONTEXT, rcToReturn=rc) - return - endif - - end subroutine -#undef METHOD - - !----------------------------------------------------------------------------- - -#define METHOD "WRFHYDRO_ESMF_FillArray" -!BOP -! !IROUTINE: WRFHYDRO_ESMF_FillArray_R8 - Fill data into Array -! !INTERFACE: - ! call using generic interface: WRFHYDRO_ESMF_FillArray - subroutine WRFHYDRO_ESMF_FillArray_R8(array,value,rc) -! ! ARGUMENTS - type(ESMF_Array), intent(in) :: array - real(ESMF_KIND_R8),intent(in) :: value - integer, intent(out),optional :: rc -! !DESCRIPTION: -! Fill data into ESMF_Array. -! -! The arguments are: -! \begin{description} -! \end{description} -! -!EOP - !----------------------------------------------------------------------------- - ! local variables - integer(ESMF_KIND_I4),pointer :: farray_I41D(:) - integer(ESMF_KIND_I4),pointer :: farray_I42D(:,:) - integer(ESMF_KIND_I4),pointer :: farray_I43D(:,:,:) - integer(ESMF_KIND_I8),pointer :: farray_I81D(:) - integer(ESMF_KIND_I8),pointer :: farray_I82D(:,:) - integer(ESMF_KIND_I8),pointer :: farray_I83D(:,:,:) - real(ESMF_KIND_R4),pointer :: farray_R41D(:) - real(ESMF_KIND_R4),pointer :: farray_R42D(:,:) - real(ESMF_KIND_R4),pointer :: farray_R43D(:,:,:) - real(ESMF_KIND_R8),pointer :: farray_R81D(:) - real(ESMF_KIND_R8),pointer :: farray_R82D(:,:) - real(ESMF_KIND_R8),pointer :: farray_R83D(:,:,:) - type(ESMF_TypeKind_Flag) :: typekind - integer :: rank - integer :: localDeCount - integer :: deIndex - - if (present(rc)) rc = ESMF_SUCCESS - - call ESMF_ArrayGet(array,typekind=typekind,rank=rank,localDeCount=localDeCount,rc=rc) - if (ESMF_LogFoundError(rcToCheck=rc, PASSTHRU)) return ! bail out - - if (rank == 1) then - if (typekind == ESMF_TYPEKIND_I4) then - do deIndex=0,localDeCount-1 - call ESMF_ArrayGet(array,farrayPtr=farray_I41D,localDe=deIndex,rc=rc) - if (ESMF_LogFoundError(rcToCheck=rc, PASSTHRU)) return ! bail out - farray_I41D = value - enddo - elseif (typekind == ESMF_TYPEKIND_I8) then - do deIndex=0,localDeCount-1 - call ESMF_ArrayGet(array,farrayPtr=farray_I81D,localDe=deIndex,rc=rc) - if (ESMF_LogFoundError(rcToCheck=rc, PASSTHRU)) return ! bail out - farray_I81D = value - enddo - elseif (typekind == ESMF_TYPEKIND_R4) then - do deIndex=0,localDeCount-1 - call ESMF_ArrayGet(array,farrayPtr=farray_R41D,localDe=deIndex,rc=rc) - if (ESMF_LogFoundError(rcToCheck=rc, PASSTHRU)) return ! bail out - farray_R41D = value - enddo - elseif (typekind == ESMF_TYPEKIND_R8) then - do deIndex=0,localDeCount-1 - call ESMF_ArrayGet(array,farrayPtr=farray_R81D,localDe=deIndex,rc=rc) - if (ESMF_LogFoundError(rcToCheck=rc, PASSTHRU)) return ! bail out - farray_R81D = value - enddo - else - call ESMF_LogSetError(rcToCheck=ESMF_RC_ARG_RANK, & - msg="Cannot fill ESMF Array because typekind is not supported", & - CONTEXT, rcToReturn=rc) - return - endif - elseif (rank == 2) then - if (typekind == ESMF_TYPEKIND_I4) then - do deIndex=0,localDeCount-1 - call ESMF_ArrayGet(array,farrayPtr=farray_I42D,localDe=deIndex,rc=rc) - if (ESMF_LogFoundError(rcToCheck=rc, PASSTHRU)) return ! bail out - farray_I42D = value - enddo - elseif (typekind == ESMF_TYPEKIND_I8) then - do deIndex=0,localDeCount-1 - call ESMF_ArrayGet(array,farrayPtr=farray_I82D,localDe=deIndex,rc=rc) - if (ESMF_LogFoundError(rcToCheck=rc, PASSTHRU)) return ! bail out - farray_I82D = value - enddo - elseif (typekind == ESMF_TYPEKIND_R4) then - do deIndex=0,localDeCount-1 - call ESMF_ArrayGet(array,farrayPtr=farray_R42D,localDe=deIndex,rc=rc) - if (ESMF_LogFoundError(rcToCheck=rc, PASSTHRU)) return ! bail out - farray_R42D = value - enddo - elseif (typekind == ESMF_TYPEKIND_R8) then - do deIndex=0,localDeCount-1 - call ESMF_ArrayGet(array,farrayPtr=farray_R82D,localDe=deIndex,rc=rc) - if (ESMF_LogFoundError(rcToCheck=rc, PASSTHRU)) return ! bail out - farray_R82D = value - enddo - else - call ESMF_LogSetError(rcToCheck=ESMF_RC_ARG_RANK, & - msg="Cannot fill ESMF Array because typekind is not supported", & - CONTEXT, rcToReturn=rc) - return - endif - elseif (rank == 3) then - if (typekind == ESMF_TYPEKIND_I4) then - do deIndex=0,localDeCount-1 - call ESMF_ArrayGet(array,farrayPtr=farray_I43D,localDe=deIndex,rc=rc) - if (ESMF_LogFoundError(rcToCheck=rc, PASSTHRU)) return ! bail out - farray_I43D = value - enddo - elseif (typekind == ESMF_TYPEKIND_I8) then - do deIndex=0,localDeCount-1 - call ESMF_ArrayGet(array,farrayPtr=farray_I83D,localDe=deIndex,rc=rc) - if (ESMF_LogFoundError(rcToCheck=rc, PASSTHRU)) return ! bail out - farray_I83D = value - enddo - elseif (typekind == ESMF_TYPEKIND_R4) then - do deIndex=0,localDeCount-1 - call ESMF_ArrayGet(array,farrayPtr=farray_R43D,localDe=deIndex,rc=rc) - if (ESMF_LogFoundError(rcToCheck=rc, PASSTHRU)) return ! bail out - farray_R43D = value - enddo - elseif (typekind == ESMF_TYPEKIND_R8) then - do deIndex=0,localDeCount-1 - call ESMF_ArrayGet(array,farrayPtr=farray_R83D,localDe=deIndex,rc=rc) - if (ESMF_LogFoundError(rcToCheck=rc, PASSTHRU)) return ! bail out - farray_R83D = value - enddo - else - call ESMF_LogSetError(rcToCheck=ESMF_RC_ARG_RANK, & - msg="Cannot fill ESMF Array because typekind is not supported", & - CONTEXT, rcToReturn=rc) - return - endif - else - call ESMF_LogSetError(rcToCheck=ESMF_RC_ARG_RANK, & - msg="Cannot fill ESMF Array because rank is not supported", & - CONTEXT, rcToReturn=rc) - return - endif - - end subroutine -#undef METHOD - - !----------------------------------------------------------------------------- - #define METHOD "WRFHYDRO_ESMF_NetcdfIsPresent" !BOP ! !IROUTINE: WRFHYDRO_ESMF_NetcdfIsPresent - Check NetCDF file for varname diff --git a/trunk/NDHMS/CPL/NUOPC_cpl/WRFHydro_NUOPC_Cap.F90 b/trunk/NDHMS/CPL/NUOPC_cpl/WRFHydro_NUOPC_Cap.F90 index 6727b6596..e18ddff01 100644 --- a/trunk/NDHMS/CPL/NUOPC_cpl/WRFHydro_NUOPC_Cap.F90 +++ b/trunk/NDHMS/CPL/NUOPC_cpl/WRFHydro_NUOPC_Cap.F90 @@ -239,6 +239,8 @@ module WRFHydro_NUOPC model_label_Advance => label_Advance, & model_label_Finalize => label_Finalize use WRFHYDRO_NUOPC_Gluecode + use WRFHYDRO_NUOPC_Fields + use WRFHYDRO_NUOPC_Flags use WRFHydro_ESMF_Extensions implicit none @@ -250,6 +252,7 @@ module WRFHydro_NUOPC CHARACTER(LEN=*), PARAMETER :: label_InternalState = 'InternalState' type type_InternalStateStruct + logical :: realizeAllImport = .FALSE. logical :: realizeAllExport = .FALSE. character(len=64) :: configFile = 'hydro.namelist' character(len=64) :: dasConfigFile = 'namelist.hrldas' @@ -257,20 +260,24 @@ module WRFHydro_NUOPC character(len=128) :: forcingDir = 'WRFHYDRO_FORCING' integer :: did = 1 logical :: nestToNest = .FALSE. - logical :: importDependency = .FALSE. - character(len=128) :: dirOutput = "." - character(len=128) :: dirInput = "." + type(memory_flag) :: memr_import = MEMORY_POINTER + type(memory_flag) :: memr_export = MEMORY_POINTER + type(fillv_flag) :: init_import = FILLV_MODEL + type(fillv_flag) :: init_export = FILLV_MODEL + type(checkclock_flag) :: chck_import = CHECKCLOCK_CURRT + type(missingval_flag) :: misg_import = MISSINGVAL_FAIL + logical :: reset_import = .FALSE. + character(len=128) :: dirOutput = "./HYD_OUTPUT" + character(len=128) :: dirInput = "./HYD_INPUT" logical :: writeRestart = .FALSE. - logical :: readRestart = .FALSE. logical :: multiInstance = .FALSE. character :: hgrid = '0' integer :: nnests = 1 - integer :: nfields = size(WRFHYDRO_FieldList) type (ESMF_Clock) :: clock(1) type (ESMF_TimeInterval) :: stepTimer(1) type(ESMF_State) :: NStateImp(1) type(ESMF_State) :: NStateExp(1) - integer :: mode(1) = WRFHYDRO_Unknown + logical :: lsm_forcings(1) = .FALSE. endtype type type_InternalState @@ -415,8 +422,10 @@ subroutine WRFHydro_AttributeGet(rc) logical :: configIsPresent type(ESMF_Config) :: config type(NUOPC_FreeFormat) :: attrFF + character(32) :: atName + logical :: atPres + character(32) :: atVal character(ESMF_MAXSTR) :: logMsg - character(len=64) :: modeStr ! check gcomp for config call ESMF_GridCompGet(gcomp, configIsPresent=configIsPresent, rc=rc) @@ -435,101 +444,238 @@ subroutine WRFHydro_AttributeGet(rc) if (ESMF_STDERRORCHECK(rc)) return ! bail out endif + ! Realize all import fields + atName="realize_all_import" + call NUOPC_CompAttributeGet(gcomp, name=atName, isPresent=atPres, rc=rc) + if (ESMF_STDERRORCHECK(rc)) return ! bail out + if (atPres) then + call NUOPC_CompAttributeGet(gcomp, name=atName, value=atVal, rc=rc) + if (ESMF_STDERRORCHECK(rc)) return ! bail out + atVal = ESMF_UtilStringUpperCase(atVal, rc=rc) + if (ESMF_STDERRORCHECK(rc)) return ! bail out + is%wrap%realizeAllImport = (trim(atVal)=="TRUE") + endif + ! Realize all export fields - call ESMF_AttributeGet(gcomp, name="realize_all_export", value=value, & - defaultValue="false", convention="NUOPC", purpose="Instance", rc=rc) + atName="realize_all_export" + call NUOPC_CompAttributeGet(gcomp, name=atName, isPresent=atPres, rc=rc) if (ESMF_STDERRORCHECK(rc)) return ! bail out - is%wrap%realizeAllExport = (trim(value)=="true") + if (atPres) then + call NUOPC_CompAttributeGet(gcomp, name=atName, value=atVal, rc=rc) + if (ESMF_STDERRORCHECK(rc)) return ! bail out + atVal = ESMF_UtilStringUpperCase(atVal, rc=rc) + if (ESMF_STDERRORCHECK(rc)) return ! bail out + is%wrap%realizeAllExport = (trim(atVal)=="TRUE") + endif ! Determine hydro configuration filename - call ESMF_AttributeGet(gcomp, name="config_file", value=value, & - defaultValue="hydro.namelist", & - convention="NUOPC", purpose="Instance", rc=rc) + atName="config_file" + call NUOPC_CompAttributeGet(gcomp, name=atName, isPresent=atPres, rc=rc) if (ESMF_STDERRORCHECK(rc)) return ! bail out - is%wrap%configFile = value + if (atPres) then + call NUOPC_CompAttributeGet(gcomp, name=atName, value=atVal, rc=rc) + if (ESMF_STDERRORCHECK(rc)) return ! bail out + is%wrap%configFile = atVal + endif ! Determine DAS configuration filename - call ESMF_AttributeGet(gcomp, name="das_config_file", value=value, & - defaultValue="namelist.hrldas", & - convention="NUOPC", purpose="Instance", rc=rc) + atName="das_config_file" + call NUOPC_CompAttributeGet(gcomp, name=atName, isPresent=atPres, rc=rc) if (ESMF_STDERRORCHECK(rc)) return ! bail out - is%wrap%dasConfigFile = value + if (atPres) then + call NUOPC_CompAttributeGet(gcomp, name=atName, value=atVal, rc=rc) + if (ESMF_STDERRORCHECK(rc)) return ! bail out + is%wrap%dasConfigFile = atVal + endif ! Time Step - call ESMF_AttributeGet(gcomp, name="time_step", value=value, defaultValue="0", & - convention="NUOPC", purpose="Instance", rc=rc) + atName="time_step" + call NUOPC_CompAttributeGet(gcomp, name=atName, isPresent=atPres, rc=rc) if (ESMF_STDERRORCHECK(rc)) return ! bail out - read (value,*,iostat=stat) is%wrap%timeStepInt - if (stat /= 0) then - call ESMF_LogSetError(ESMF_FAILURE, & - msg="Cannot convert "//trim(value)//" to integer.", & - line=__LINE__,file=__FILE__,rcToReturn=rc) - return ! bail out + if (atPres) then + call NUOPC_CompAttributeGet(gcomp, name=atName, value=atVal, rc=rc) + if (ESMF_STDERRORCHECK(rc)) return ! bail out + read (atVal,*,iostat=stat) is%wrap%timeStepInt + if (stat /= 0) then + call ESMF_LogSetError(ESMF_FAILURE, & + msg="Cannot convert "//trim(atVal)//" to integer.", & + line=__LINE__,file=__FILE__,rcToReturn=rc) + return ! bail out + endif endif ! Forcing Directory - call ESMF_AttributeGet(gcomp, name="forcings_directory", value=value, & - defaultValue=is%wrap%forcingDir, & - convention="NUOPC", purpose="Instance", rc=rc) + atName="forcings_directory" + call NUOPC_CompAttributeGet(gcomp, name=atName, isPresent=atPres, rc=rc) if (ESMF_STDERRORCHECK(rc)) return ! bail out - is%wrap%forcingDir = trim(value) + if (atPres) then + call NUOPC_CompAttributeGet(gcomp, name=atName, value=atVal, rc=rc) + if (ESMF_STDERRORCHECK(rc)) return ! bail out + is%wrap%forcingDir = trim(atVal) + endif ! Determine Domain ID - call ESMF_AttributeGet(gcomp, name="did", value=value, & - defaultValue="1", & - convention="NUOPC", purpose="Instance", rc=rc) - if (ESMF_STDERRORCHECK(rc)) return ! bail out - is%wrap%did = ESMF_UtilString2Int(value, rc=rc) + atName="did" + call NUOPC_CompAttributeGet(gcomp, name=atName, isPresent=atPres, rc=rc) if (ESMF_STDERRORCHECK(rc)) return ! bail out + if (atPres) then + call NUOPC_CompAttributeGet(gcomp, name=atName, value=atVal, rc=rc) + if (ESMF_STDERRORCHECK(rc)) return ! bail out + is%wrap%did = ESMF_UtilString2Int(atVal, rc=rc) + if (ESMF_STDERRORCHECK(rc)) return ! bail out + endif ! Connect Nest to Nest - call ESMF_AttributeGet(gcomp, name="nest_to_nest", value=value, & - defaultValue="false", & - convention="NUOPC", purpose="Instance", rc=rc) + atName="nest_to_nest" + call NUOPC_CompAttributeGet(gcomp, name=atName, isPresent=atPres, rc=rc) if (ESMF_STDERRORCHECK(rc)) return ! bail out - is%wrap%nestToNest = (trim(value)=="true") + if (atPres) then + call NUOPC_CompAttributeGet(gcomp, name=atName, value=atVal, rc=rc) + if (ESMF_STDERRORCHECK(rc)) return ! bail out + atVal = ESMF_UtilStringUpperCase(atVal, rc=rc) + if (ESMF_STDERRORCHECK(rc)) return ! bail out + is%wrap%nestToNest = (trim(atVal)=="TRUE") + endif - ! Determine Import Dependency - call ESMF_AttributeGet(gcomp, name="import_dependency", & - value=value, defaultValue="false", & - convention="NUOPC", purpose="Instance", rc=rc) + ! import data memory type + atName="field_memory_import" + call NUOPC_CompAttributeGet(gcomp, name=atName, isPresent=atPres, rc=rc) + if (ESMF_STDERRORCHECK(rc)) return ! bail out + if (atPres) then + call NUOPC_CompAttributeGet(gcomp, name=atName, value=atVal, rc=rc) + if (ESMF_STDERRORCHECK(rc)) return ! bail out + is%wrap%memr_import = atVal + endif + + ! export data memory type + atName="field_memory_export" + call NUOPC_CompAttributeGet(gcomp, name=atName, isPresent=atPres, rc=rc) + if (ESMF_STDERRORCHECK(rc)) return ! bail out + if (atPres) then + call NUOPC_CompAttributeGet(gcomp, name=atName, value=atVal, rc=rc) + if (ESMF_STDERRORCHECK(rc)) return ! bail out + is%wrap%memr_export = atVal + endif + + ! import data initialization type + atName="initialize_import" + call NUOPC_CompAttributeGet(gcomp, name=atName, isPresent=atPres, rc=rc) + if (ESMF_STDERRORCHECK(rc)) return ! bail out + if (atPres) then + call NUOPC_CompAttributeGet(gcomp, name=atName, value=atVal, rc=rc) + if (ESMF_STDERRORCHECK(rc)) return ! bail out + is%wrap%init_import = atVal + endif + + ! backwards compatible setting (overrides initialize_import) + atName="import_dependency" + call NUOPC_CompAttributeGet(gcomp, name=atName, isPresent=atPres, rc=rc) if (ESMF_STDERRORCHECK(rc)) return ! bail out - is%wrap%importDependency = (trim(value)=="true") + if (atPres) then + call NUOPC_CompAttributeGet(gcomp, name=atName, value=atVal, rc=rc) + if (ESMF_STDERRORCHECK(rc)) return ! bail out + atVal = ESMF_UtilStringUpperCase(atVal, rc=rc) + if (ESMF_STDERRORCHECK(rc)) return ! bail out + if (trim(atVal)=="TRUE") is%wrap%init_import = FILLV_DEPENDENCY + endif + + ! export data initialization type + atName="initialize_export" + call NUOPC_CompAttributeGet(gcomp, name=atName, isPresent=atPres, rc=rc) + if (ESMF_STDERRORCHECK(rc)) return ! bail out + if (atPres) then + call NUOPC_CompAttributeGet(gcomp, name=atName, value=atVal, rc=rc) + if (ESMF_STDERRORCHECK(rc)) return ! bail out + is%wrap%init_export = atVal + endif + + ! backwards compatible setting (overrides initialize_export) + atName="read_restart" + call NUOPC_CompAttributeGet(gcomp, name=atName, isPresent=atPres, rc=rc) + if (ESMF_STDERRORCHECK(rc)) return ! bail out + if (atPres) then + call NUOPC_CompAttributeGet(gcomp, name=atName, value=atVal, rc=rc) + if (ESMF_STDERRORCHECK(rc)) return ! bail out + atVal = ESMF_UtilStringUpperCase(atVal, rc=rc) + if (ESMF_STDERRORCHECK(rc)) return ! bail out + if (trim(atVal)=="TRUE") is%wrap%init_export = FILLV_FILE + endif + + ! Get check import + atName="check_import" + call NUOPC_CompAttributeGet(gcomp, name=atName, isPresent=atPres, rc=rc) + if (ESMF_STDERRORCHECK(rc)) return ! bail out + if (atPres) then + call NUOPC_CompAttributeGet(gcomp, name=atName, value=atVal, rc=rc) + if (ESMF_STDERRORCHECK(rc)) return ! bail out + is%wrap%chck_import = atVal + endif + + ! Get missing import handler + atName="missing_import" + call NUOPC_CompAttributeGet(gcomp, name=atName, isPresent=atPres, rc=rc) + if (ESMF_STDERRORCHECK(rc)) return ! bail out + if (atPres) then + call NUOPC_CompAttributeGet(gcomp, name=atName, value=atVal, rc=rc) + if (ESMF_STDERRORCHECK(rc)) return ! bail out + is%wrap%misg_import = atVal + endif + + ! Get reset import handler + atName="reset_import" + call NUOPC_CompAttributeGet(gcomp, name=atName, isPresent=atPres, rc=rc) + if (ESMF_STDERRORCHECK(rc)) return ! bail out + if (atPres) then + call NUOPC_CompAttributeGet(gcomp, name=atName, value=atVal, rc=rc) + if (ESMF_STDERRORCHECK(rc)) return ! bail out + atVal = ESMF_UtilStringUpperCase(atVal, rc=rc) + if (ESMF_STDERRORCHECK(rc)) return ! bail out + is%wrap%reset_import = (trim(atVal)=="TRUE") + endif ! Get component output directory - call ESMF_AttributeGet(gcomp, name="output_directory", & - value=value, defaultValue=trim(cname)//"_OUTPUT", & - convention="NUOPC", purpose="Instance", rc=rc) + atName="output_directory" + call NUOPC_CompAttributeGet(gcomp, name=atName, isPresent=atPres, rc=rc) if (ESMF_STDERRORCHECK(rc)) return ! bail out - is%wrap%dirOutput = trim(value) + if (atPres) then + call NUOPC_CompAttributeGet(gcomp, name=atName, value=atVal, rc=rc) + if (ESMF_STDERRORCHECK(rc)) return ! bail out + is%wrap%dirOutput = trim(atVal) + endif ! Get component input directory - call ESMF_AttributeGet(gcomp, name="input_directory", & - value=value, defaultValue=trim(cname)//"_INPUT", & - convention="NUOPC", purpose="Instance", rc=rc) + atName="input_directory" + call NUOPC_CompAttributeGet(gcomp, name=atName, isPresent=atPres, rc=rc) if (ESMF_STDERRORCHECK(rc)) return ! bail out - is%wrap%dirInput = trim(value) + if (atPres) then + call NUOPC_CompAttributeGet(gcomp, name=atName, value=atVal, rc=rc) + if (ESMF_STDERRORCHECK(rc)) return ! bail out + is%wrap%dirInput = trim(atVal) + endif ! Write cap restart state - call ESMF_AttributeGet(gcomp, name="write_restart", & - value=value, defaultValue="false", & - convention="NUOPC", purpose="Instance", rc=rc) + atName="write_restart" + call NUOPC_CompAttributeGet(gcomp, name=atName, isPresent=atPres, rc=rc) if (ESMF_STDERRORCHECK(rc)) return ! bail out - is%wrap%writeRestart = (trim(value)=="true") - - ! Read cap restart state - call ESMF_AttributeGet(gcomp, name="read_restart", & - value=value, defaultValue="false", & - convention="NUOPC", purpose="Instance", rc=rc) - if (ESMF_STDERRORCHECK(rc)) return ! bail out - is%wrap%readRestart = (trim(value)=="true") + if (atPres) then + call NUOPC_CompAttributeGet(gcomp, name=atName, value=atVal, rc=rc) + if (ESMF_STDERRORCHECK(rc)) return ! bail out + atVal = ESMF_UtilStringUpperCase(atVal, rc=rc) + if (ESMF_STDERRORCHECK(rc)) return ! bail out + is%wrap%writeRestart = (trim(atVal)=="TRUE") + endif ! Determine Import Dependency - call ESMF_AttributeGet(gcomp, name="multi_instance_hyd", & - value=value, defaultValue="false", & - convention="NUOPC", purpose="Instance", rc=rc) + atName="multi_instance_hyd" + call NUOPC_CompAttributeGet(gcomp, name=atName, isPresent=atPres, rc=rc) if (ESMF_STDERRORCHECK(rc)) return ! bail out - is%wrap%multiInstance = (trim(value)=="true") + if (atPres) then + call NUOPC_CompAttributeGet(gcomp, name=atName, value=atVal, rc=rc) + if (ESMF_STDERRORCHECK(rc)) return ! bail out + atVal = ESMF_UtilStringUpperCase(atVal, rc=rc) + if (ESMF_STDERRORCHECK(rc)) return ! bail out + is%wrap%multiInstance = (trim(atVal)=="TRUE") + endif if (btest(verbosity,16)) then call ESMF_LogWrite(trim(cname)//": Settings",ESMF_LOGMSG_INFO) @@ -539,6 +685,9 @@ subroutine WRFHydro_AttributeGet(rc) write (logMsg, "(A,(A,I0))") trim(cname)//": ", & "Diagnostic = ",diagnostic call ESMF_LogWrite(trim(logMsg),ESMF_LOGMSG_INFO) + write (logMsg, "(A,(A,L1))") trim(cname)//": ", & + "Realze All Imports = ",is%wrap%realizeAllImport + call ESMF_LogWrite(trim(logMsg),ESMF_LOGMSG_INFO) write (logMsg, "(A,(A,L1))") trim(cname)//": ", & "Realze All Exports = ",is%wrap%realizeAllExport call ESMF_LogWrite(trim(logMsg),ESMF_LOGMSG_INFO) @@ -560,8 +709,32 @@ subroutine WRFHydro_AttributeGet(rc) write (logMsg, "(A,(A,L1))") trim(cname)//": ", & "Nest To Nest = ",is%wrap%nestToNest call ESMF_LogWrite(trim(logMsg),ESMF_LOGMSG_INFO) + atVal = is%wrap%memr_import + write (logMsg, "(A,(A,A))") trim(cname)//": ", & + "Field Memory Import = ",trim(atVal) + call ESMF_LogWrite(trim(logMsg),ESMF_LOGMSG_INFO) + atVal = is%wrap%memr_export + write (logMsg, "(A,(A,A))") trim(cname)//": ", & + "Field Memory Export = ",trim(atVal) + call ESMF_LogWrite(trim(logMsg),ESMF_LOGMSG_INFO) + atVal = is%wrap%init_import + write (logMsg, "(A,(A,A))") trim(cname)//": ", & + "Initialize Import = ",trim(atVal) + call ESMF_LogWrite(trim(logMsg),ESMF_LOGMSG_INFO) + atVal = is%wrap%init_export + write (logMsg, "(A,(A,A))") trim(cname)//": ", & + "Initialize Export = ",trim(atVal) + call ESMF_LogWrite(trim(logMsg),ESMF_LOGMSG_INFO) + atVal = is%wrap%chck_import + write (logMsg, "(A,(A,A))") trim(cname)//": ", & + "Check Imports = ",trim(atVal) + call ESMF_LogWrite(trim(logMsg),ESMF_LOGMSG_INFO) + atVal = is%wrap%misg_import + write (logMsg, "(A,(A,A))") trim(cname)//": ", & + "Missing Imports = ",trim(atVal) + call ESMF_LogWrite(trim(logMsg),ESMF_LOGMSG_INFO) write (logMsg, "(A,(A,L1))") trim(cname)//': ', & - "Import Dependency = ",is%wrap%importDependency + "Reset Import = ",is%wrap%reset_import call ESMF_LogWrite(trim(logMsg),ESMF_LOGMSG_INFO) write (logMsg, "(A,(A,A))") trim(cname)//": ", & "Output Directory = ",trim(is%wrap%dirOutput) @@ -572,9 +745,6 @@ subroutine WRFHydro_AttributeGet(rc) write (logMsg, "(A,(A,L1))") trim(cname)//': ', & "Write Restart = ",is%wrap%writeRestart call ESMF_LogWrite(trim(logMsg),ESMF_LOGMSG_INFO) - write (logMsg, "(A,(A,L1))") trim(cname)//': ', & - "Read Restart = ",is%wrap%readRestart - call ESMF_LogWrite(trim(logMsg),ESMF_LOGMSG_INFO) write (logMsg, "(A,(A,L1))") trim(cname)//': ', & "Multiple Instances = ",is%wrap%multiInstance call ESMF_LogWrite(trim(logMsg),ESMF_LOGMSG_INFO) @@ -658,83 +828,19 @@ subroutine InitializeP1(gcomp, importState, exportState, clock, rc) if (ESMF_STDERRORCHECK(rc)) return ! bail out endif - call WRFHYDRO_FieldDictionaryAdd(rc=rc) + call field_dictionary_add(fieldList=cap_fld_list, rc=rc) if (ESMF_STDERRORCHECK(rc)) return ! bail out !! !! advertise import and export fields !! - do fIndex = 1, size(WRFHYDRO_FieldList) - if (WRFHYDRO_FieldList(fIndex)%adImport) then - call NUOPC_Advertise(is%wrap%NStateImp(1), & - standardName=trim(WRFHYDRO_FieldList(fIndex)%stdname), & - name=trim(WRFHYDRO_FieldList(fIndex)%stateName), & - rc=rc) - if (ESMF_STDERRORCHECK(rc)) return ! bail out - endif - if (WRFHYDRO_FieldList(fIndex)%adExport) then - call NUOPC_Advertise(is%wrap%NStateExp(1), & - standardName=trim(WRFHYDRO_FieldList(fIndex)%stdname), & - name=trim(WRFHYDRO_FieldList(fIndex)%stateName), & - rc=rc) - if (ESMF_STDERRORCHECK(rc)) return ! bail out - endif - enddo - - if (btest(verbosity,16)) call LogAdvertised() - - contains ! - - - - - - - - - - - - - - - - - - - - - - - - - - - - - - - - - - subroutine LogAdvertised() - ! local variables - integer :: cntImp - integer :: cntExp - integer :: fIndex - character(ESMF_MAXSTR) :: logMsg - - ! Count advertised import and export fields - cntImp = 0 - cntExp = 0 - do fIndex = 1, size(WRFHydro_FieldList) - if (WRFHydro_FieldList(fIndex)%adImport) cntImp = cntImp + 1 - if (WRFHydro_FieldList(fIndex)%adExport) cntExp = cntExp + 1 - enddo - - ! Report advertised import fields - write(logMsg,'(a,a,i0,a)') TRIM(cname)//': ', & - 'List of advertised import fields(',cntImp,'):' - call ESMF_LogWrite(TRIM(logMsg), ESMF_LOGMSG_INFO) - write(logMsg,'(a,a5,a,a16,a,a)') TRIM(cname)//': ', & - 'index',' ','name',' ','standardName' - call ESMF_LogWrite(TRIM(logMsg), ESMF_LOGMSG_INFO) - cntImp = 0 - do fIndex=1, size(WRFHydro_FieldList) - if (.NOT.WRFHydro_FieldList(fIndex)%adImport) cycle - cntImp = cntImp + 1 - write(logMsg,'(a,i5,a,a16,a,a)') TRIM(cname)//': ', & - cntImp,' ',TRIM(WRFHydro_FieldList(fIndex)%stateName), & - ' ',TRIM(WRFHydro_FieldList(fIndex)%stdName) - call ESMF_LogWrite(trim(logMsg), ESMF_LOGMSG_INFO) - enddo - - ! Report advertised export fields - write(logMsg,'(a,a,i0,a)') TRIM(cname)//': ', & - 'List of advertised export fields(',cntExp,'):' - call ESMF_LogWrite(TRIM(logMsg), ESMF_LOGMSG_INFO) - write(logMsg,'(a,a5,a,a16,a,a)') TRIM(cname)//': ', & - 'index',' ','name',' ','standardName' - call ESMF_LogWrite(TRIM(logMsg), ESMF_LOGMSG_INFO) - cntExp = 0 - do fIndex=1, size(WRFHydro_FieldList) - if (.NOT.WRFHydro_FieldList(fIndex)%adExport) cycle - cntExp = cntExp + 1 - write(logMsg,'(a,i5,a,a16,a,a)') TRIM(cname)//': ', & - cntExp,' ',TRIM(WRFHydro_FieldList(fIndex)%stateName), & - ' ',TRIM(WRFHydro_FieldList(fIndex)%stdName) - call ESMF_LogWrite(trim(LogMsg), ESMF_LOGMSG_INFO) - enddo + call field_advertise(fieldList=cap_fld_list, & + importState=is%wrap%NStateImp(1), & + exportState=is%wrap%NStateExp(1), & + rc=rc) + if (ESMF_STDERRORCHECK(rc)) return ! bail out - end subroutine + if (btest(verbosity,16)) call field_advertise_log(cap_fld_list,cname,rc=rc) end subroutine @@ -805,128 +911,25 @@ subroutine InitializeP3(gcomp, importState, exportState, clock, rc) if (ESMF_STDERRORCHECK(rc)) return ! bail out endif - do fIndex = 1, size(WRFHYDRO_FieldList) - if (WRFHYDRO_FieldList(fIndex)%adImport) then - importConnected = NUOPC_IsConnected(is%wrap%NStateImp(1), & - fieldName=WRFHYDRO_FieldList(fIndex)%stateName, rc=rc) - if (ESMF_STDERRORCHECK(rc)) return ! bail out - else - importConnected = .FALSE. - endif - - if (importConnected) then - WRFHYDRO_FieldList(fIndex)%realizedImport = .TRUE. - field = WRFHYDRO_FieldCreate(stateName=WRFHYDRO_FieldList(fIndex)%stateName, & - grid=WRFHYDRO_grid, & - did=is%wrap%did, & - rc=rc) - if (ESMF_STDERRORCHECK(rc)) return ! bail out - call NUOPC_Realize(is%wrap%NStateImp(1), field=field, rc=rc) - if (ESMF_STDERRORCHECK(rc)) return - elseif(WRFHYDRO_FieldList(fIndex)%adImport) then - call ESMF_StateRemove(is%wrap%NStateImp(1), (/trim(WRFHYDRO_FieldList(fIndex)%stateName)/), & - relaxedflag=.true.,rc=rc) - if (ESMF_STDERRORCHECK(rc)) return - endif - - if (WRFHYDRO_FieldList(fIndex)%adExport) then - if (is%wrap%realizeAllExport) then - exportConnected = .TRUE. - else - exportConnected = NUOPC_IsConnected(is%wrap%NStateExp(1), & - fieldName=WRFHYDRO_FieldList(fIndex)%stateName, rc=rc) - if (ESMF_STDERRORCHECK(rc)) return ! bail out - endif - else - exportConnected = .FALSE. - endif - - if (exportConnected) then - WRFHYDRO_FieldList(fIndex)%realizedExport = .TRUE. - field = WRFHYDRO_FieldCreate(stateName=WRFHYDRO_FieldList(fIndex)%stateName, & - grid=WRFHYDRO_grid, & - did=is%wrap%did, & - rc=rc) - if (ESMF_STDERRORCHECK(rc)) return ! bail out - call NUOPC_Realize(is%wrap%NStateExp(1), field=field,rc=rc) - if (ESMF_STDERRORCHECK(rc)) return - elseif(WRFHYDRO_FieldList(fIndex)%adExport) then - call ESMF_StateRemove(is%wrap%NStateExp(1),(/trim(WRFHYDRO_FieldList(fIndex)%stateName)/), & - relaxedflag=.true.,rc=rc) - if (ESMF_STDERRORCHECK(rc)) return - endif - - ! TODO: Initialize the value in the pointer to 0 after proper restart is setup - !if(associated(WRFHYDRO_FieldList(fIndex)%farrayPtr) ) WRFHYDRO_FieldList(fIndex)%farrayPtr = 0.0 - ! remove a not connected Field from State - - enddo - -! Model has initialized its own field memory so don't fill state. -! call NUOPC_FillState(is%wrap%NStateImp(1),0,rc=rc) -! if (ESMF_STDERRORCHECK(rc)) return -! call NUOPC_FillState(is%wrap%NStateExp(1),0,rc=rc) -! if (ESMF_STDERRORCHECK(rc)) return + call field_realize(fieldList=cap_fld_list, & + importState=is%wrap%NStateImp(1), & + exportState=is%wrap%NStateExp(1), & + grid=WRFHYDRO_grid, did=is%wrap%did, & + realizeAllImport=is%wrap%realizeAllImport, & + realizeAllExport=is%wrap%realizeAllExport, & + memr_import=is%wrap%memr_import, & + memr_export=is%wrap%memr_export, & + rc=rc) + if (ESMF_STDERRORCHECK(rc)) return ! bail out - is%wrap%mode(1) = WRFHYDRO_RunModeGet(is%wrap%NStateImp(1),rc) + is%wrap%lsm_forcings(1) = check_lsm_forcings(is%wrap%NStateImp(1),rc) if (ESMF_STDERRORCHECK(rc)) return ! bail out - if (btest(verbosity,16)) call LogRealized() + if (btest(verbosity,16)) call field_realize_log(cap_fld_list,cname,rc=rc) if (btest(verbosity,16)) call LogMode() contains ! - - - - - - - - - - - - - - - - - - - - - - - - - - - - - - - - - subroutine LogRealized() - ! local variables - integer :: cntImp - integer :: cntExp - integer :: fIndex - character(ESMF_MAXSTR) :: logMsg - - ! Count advertised import and export fields - cntImp = 0 - cntExp = 0 - do fIndex = 1, size(WRFHydro_FieldList) - if (WRFHydro_FieldList(fIndex)%realizedImport) cntImp = cntImp + 1 - if (WRFHydro_FieldList(fIndex)%realizedExport) cntExp = cntExp + 1 - enddo - - ! Report realized import fields - write(logMsg,'(a,a,i0,a)') TRIM(cname)//': ', & - 'List of realized import fields(',cntImp,'):' - call ESMF_LogWrite(TRIM(logMsg), ESMF_LOGMSG_INFO) - write(logMsg,'(a,a5,a,a16,a,a)') TRIM(cname)//': ', & - 'index',' ','name',' ','standardName' - call ESMF_LogWrite(TRIM(logMsg), ESMF_LOGMSG_INFO) - cntImp = 0 - do fIndex=1, size(WRFHydro_FieldList) - if (.NOT.WRFHydro_FieldList(fIndex)%realizedImport) cycle - cntImp = cntImp + 1 - write(logMsg,'(a,i5,a,a16,a,a)') TRIM(cname)//': ', & - cntImp,' ',TRIM(WRFHydro_FieldList(fIndex)%stateName), & - ' ',TRIM(WRFHydro_FieldList(fIndex)%stdName) - call ESMF_LogWrite(trim(LogMsg), ESMF_LOGMSG_INFO) - enddo - - ! Report realized export fields - write(logMsg,'(a,a,i0,a)') TRIM(cname)//': ', & - 'List of realized export fields(',cntExp,'):' - call ESMF_LogWrite(TRIM(logMsg), ESMF_LOGMSG_INFO) - write(logMsg,'(a,a5,a,a16,a,a)') TRIM(cname)//': ', & - 'index',' ','name',' ','standardName' - call ESMF_LogWrite(TRIM(logMsg), ESMF_LOGMSG_INFO) - cntExp = 0 - do fIndex=1, size(WRFHydro_FieldList) - if (.NOT.WRFHydro_FieldList(fIndex)%realizedExport) cycle - cntExp = cntExp + 1 - write(logMsg,'(a,i5,a,a16,a,a)') TRIM(cname)//': ', & - cntExp,' ',TRIM(WRFHydro_FieldList(fIndex)%stateName), & - ' ',TRIM(WRFHydro_FieldList(fIndex)%stdName) - call ESMF_LogWrite(trim(LogMsg), ESMF_LOGMSG_INFO) - enddo - - end subroutine - !--------------------------------------------------------------------------- subroutine LogMode() @@ -934,16 +937,11 @@ subroutine LogMode() character(ESMF_MAXSTR) :: logMsg character(len=64) :: modeStr - select case(is%wrap%mode(1)) - case (WRFHYDRO_Offline) - modeStr ="WRFHYDRO_Offline" - case (WRFHYDRO_Coupled) - modeStr = "WRFHYDRO_Coupled" - case (WRFHYDRO_Hybrid) - modeStr = "WRFHYDRO_Hybrid" - case default - modeStr = "WRFHYDRO_Unknown" - end select + if(is%wrap%lsm_forcings(1)) then + modeStr = "WRFHYDRO_Coupled" + else + modeStr = "WRFHYDRO_Offline" + endif write (logMsg, "(A,(A,A))") trim(cname)//": ", & "Mode = ",trim(modeStr) call ESMF_LogWrite(trim(logMsg),ESMF_LOGMSG_INFO) @@ -966,16 +964,15 @@ subroutine DataInitialize(gcomp, rc) type(type_InternalState) :: is type(ESMF_Clock) :: modelClock type(ESMF_Time) :: currTime + type(ESMF_Time) :: invalidTime character(len=32) :: currTimeStr character(len=9) :: nStr - integer :: iIndex - integer :: itemCount - character(len=64),allocatable :: itemNameList(:) - type(ESMF_StateItem_Flag), allocatable :: itemTypeList(:) - type(ESMF_Field) :: field - integer :: stat logical :: importCurrent logical :: importUpdated + logical :: exportUpdated + character(len=32) :: initTypeStr + logical :: mdlRestart + integer :: stat rc = ESMF_SUCCESS @@ -1008,89 +1005,141 @@ subroutine DataInitialize(gcomp, rc) call NUOPC_ModelGet(gcomp, modelClock=modelClock, rc=rc) if (ESMF_STDERRORCHECK(rc)) return ! bail out + ! set up invalid time (by convention) + call ESMF_TimeSet(invalidTime, yy=99999999, mm=01, dd=01, & + h=00, m=00, s=00, rc=rc) + if (ESMF_STDERRORCHECK(rc)) return ! bail out + ! get the current time out of the clock call ESMF_ClockGet(modelClock, currTime=currTime, rc=rc) if (ESMF_STDERRORCHECK(rc)) return ! bail out call ESMF_TimeGet(currTime, timeString=currTimeStr, rc=rc) if (ESMF_STDERRORCHECK(rc)) return ! bail out - ! Initialize import and export fields - ! No initialization. Fields remain set to initial value - - importUpdated = .TRUE. write (nStr,"(I0)") is%wrap%did - if (is%wrap%importDependency) then + ! initialize import state + if (is%wrap%init_import.eq.FILLV_MISSING) then + call state_fill_uniform(is%wrap%NStateImp(1), & + fillValue=ESMF_MISSING_VALUE, rc=rc) + if (ESMF_STDERRORCHECK(rc)) return + call NUOPC_SetTimestamp(is%wrap%NStateImp(1), time=invalidTime, rc=rc) + if (ESMF_STDERRORCHECK(rc)) return ! bail out + importUpdated = .TRUE. + elseif (is%wrap%init_import.eq.FILLV_ZERO) then + call state_fill_uniform(is%wrap%NStateImp(1), & + fillValue=0.0_ESMF_KIND_R8, rc=rc) + if (ESMF_STDERRORCHECK(rc)) return + call NUOPC_SetTimestamp(is%wrap%NStateImp(1), time=invalidTime, rc=rc) + if (ESMF_STDERRORCHECK(rc)) return ! bail out + importUpdated = .TRUE. + elseif (is%wrap%init_import.eq.FILLV_DEPENDENCY) then importCurrent = NUOPC_IsAtTime(is%wrap%NStateImp(1), & time=currTime, rc=rc) if (ESMF_STDERRORCHECK(rc)) return ! bail out - if (importCurrent) then call ESMF_LogWrite( & trim(cname)//': '//rname//' Initialize-Data-Dependency SATISFIED!!! Nest='//trim(nStr), & ESMF_LOGMSG_INFO) + importUpdated = .TRUE. else call ESMF_LogWrite( & trim(cname)//': '//rname//' Initialize-Data-Dependency NOT YET SATISFIED!!! Nest='//trim(nStr), & ESMF_LOGMSG_INFO) importUpdated = .FALSE. endif + elseif (is%wrap%init_import.eq.FILLV_PRESCRIBE) then + call state_fill_prescribe(is%wrap%NStateImp(1), & + fieldList=cap_fld_list, rc=rc) + if (ESMF_STDERRORCHECK(rc)) return + importUpdated = .TRUE. + elseif (is%wrap%init_import.eq.FILLV_FILE) then + call state_fill_file(is%wrap%NStateImp(1), & + filePrefix=trim(is%wrap%dirInput)//"/restart_"//trim(cname)// & + "_imp_D"//trim(nStr)//"_"//trim(currTimeStr), rc=rc) + if (ESMF_STDERRORCHECK(rc)) return + call NUOPC_SetTimestamp(is%wrap%NStateImp(1), time=currTime, rc=rc) + if (ESMF_STDERRORCHECK(rc)) return ! bail out + importUpdated = .TRUE. + elseif (is%wrap%init_import.eq.FILLV_MODEL) then + if (is%wrap%memr_import.eq.MEMORY_COPY) then + call state_copy_frhyd(is%wrap%NStateImp(1), is%wrap%did, rc=rc) + if (ESMF_STDERRORCHECK(rc)) return ! bail out + endif + call WRFHYDRO_get_restart(is%wrap%did, restart=mdlRestart, rc=rc) + if (ESMF_STDERRORCHECK(rc)) return ! bail out + if (mdlRestart) then + call NUOPC_SetTimestamp(is%wrap%NStateImp(1), time=currTime, rc=rc) + if (ESMF_STDERRORCHECK(rc)) return ! bail out + else + call NUOPC_SetTimestamp(is%wrap%NStateImp(1), time=invalidTime, rc=rc) + if (ESMF_STDERRORCHECK(rc)) return ! bail out + endif + importUpdated = .TRUE. + else + initTypeStr = is%wrap%init_import + call ESMF_LogSetError(ESMF_FAILURE, & + msg="Import data initialize routine unknown "//trim(initTypeStr), & + line=__LINE__,file=__FILE__,rcToReturn=rc) + return ! bail out + importUpdated = .FALSE. endif - if (is%wrap%readRestart) then - call ESMF_StateGet(is%wrap%NStateExp(1),itemCount=itemCount, rc=rc) - if (ESMF_STDERRORCHECK(rc)) return ! bail out - - allocate( & - itemNameList(itemCount), & - itemTypeList(itemCount), & - stat=stat) - if (ESMF_LogFoundAllocError(statusToCheck=stat, & - msg="Allocation of state item list memory failed.", & - line=__LINE__, & - file=__FILE__)) & - return ! bail out - - call ESMF_StateGet(is%wrap%NStateExp(1),itemNameList=itemNameList, & - itemTypeList=itemTypeList,rc=rc) + ! initialize export state + if (is%wrap%init_export.eq.FILLV_MISSING) then + call state_fill_uniform(is%wrap%NStateExp(1), & + fillValue=ESMF_MISSING_VALUE, rc=rc) if (ESMF_STDERRORCHECK(rc)) return - - do iIndex=1, itemCount - if ( itemTypeList(iIndex) == ESMF_STATEITEM_FIELD) then - call ESMF_StateGet(is%wrap%NStateExp(1),field=field, & - itemName=itemNameList(iIndex),rc=rc) - if (ESMF_STDERRORCHECK(rc)) return - call ESMF_AttributeGet(field, name="StandardName", & - value=value, convention="NUOPC", purpose="Instance", rc=rc) - if (ESMF_STDERRORCHECK(rc)) return - call ESMF_FieldRead(field, & - fileName=trim(is%wrap%dirInput)//"/restart_"//trim(cname)// & - "_exp_D"//trim(nStr)//"_"//trim(currTimeStr)//"_"// & - trim(itemNameList(iIndex))//".nc", & - variableName=value, iofmt=ESMF_IOFMT_NETCDF, rc=rc) - if (ESMF_STDERRORCHECK(rc)) return - call NUOPC_SetAttribute(field, name="Updated", value="true", rc=rc) - if (ESMF_STDERRORCHECK(rc)) return ! bail out - endif - enddo - - deallocate(itemNameList, itemTypeList, stat=stat) - if (ESMF_LogFoundDeallocError(statusToCheck=stat, & - msg="Deallocation of state item list memory failed.", & - line=__LINE__, & - file=__FILE__)) & - return ! bail out - - call ESMF_LogWrite( & - trim(cname)//': '//rname//' Read cap restart complete! Nest='//trim(nStr), & - ESMF_LOGMSG_INFO) - is%wrap%readRestart = .FALSE. - - endif ! readRestart + call NUOPC_SetTimestamp(is%wrap%NStateExp(1), time=invalidTime, rc=rc) + if (ESMF_STDERRORCHECK(rc)) return ! bail out + exportUpdated = .TRUE. + elseif (is%wrap%init_export.eq.FILLV_ZERO) then + call state_fill_uniform(is%wrap%NStateExp(1), & + fillValue=0.0_ESMF_KIND_R8, rc=rc) + if (ESMF_STDERRORCHECK(rc)) return + call NUOPC_SetTimestamp(is%wrap%NStateExp(1), time=invalidTime, rc=rc) + if (ESMF_STDERRORCHECK(rc)) return ! bail out + exportUpdated = .TRUE. + elseif (is%wrap%init_export.eq.FILLV_PRESCRIBE) then + call state_fill_prescribe(is%wrap%NStateExp(1), & + fieldList=cap_fld_list, rc=rc) + if (ESMF_STDERRORCHECK(rc)) return + exportUpdated = .TRUE. + elseif (is%wrap%init_export.eq.FILLV_FILE) then + call state_fill_file(is%wrap%NStateExp(1), & + filePrefix=trim(is%wrap%dirInput)//"/restart_"//trim(cname)// & + "_exp_D"//trim(nStr)//"_"//trim(currTimeStr), rc=rc) + if (ESMF_STDERRORCHECK(rc)) return + call NUOPC_SetTimestamp(is%wrap%NStateExp(1), time=currTime, rc=rc) + if (ESMF_STDERRORCHECK(rc)) return ! bail out + exportUpdated = .TRUE. + elseif (is%wrap%init_export.eq.FILLV_MODEL) then + if (is%wrap%memr_export.eq.MEMORY_COPY) then + call state_copy_frhyd(is%wrap%NStateExp(1), is%wrap%did, rc=rc) + if (ESMF_STDERRORCHECK(rc)) return ! bail out + endif + call WRFHYDRO_get_restart(is%wrap%did, restart=mdlRestart, rc=rc) + if (ESMF_STDERRORCHECK(rc)) return ! bail out + if (mdlRestart) then + call NUOPC_SetTimestamp(is%wrap%NStateExp(1), time=currTime, rc=rc) + if (ESMF_STDERRORCHECK(rc)) return ! bail out + else + call NUOPC_SetTimestamp(is%wrap%NStateExp(1), time=invalidTime, rc=rc) + if (ESMF_STDERRORCHECK(rc)) return ! bail out + endif + exportUpdated = .TRUE. + else + initTypeStr = is%wrap%init_export + call ESMF_LogSetError(ESMF_FAILURE, & + msg="Export data initialize routine unknown "//trim(initTypeStr), & + line=__LINE__,file=__FILE__,rcToReturn=rc) + return ! bail out + exportUpdated = .FALSE. + endif ! set InitializeDataComplete Attribute to "true", indicating to the ! generic code that all inter-model data dependencies are satisfied - if (importUpdated) then + if (importUpdated.AND.exportUpdated) then call NUOPC_CompAttributeSet(gcomp, name="InitializeDataComplete", value="true", rc=rc) if (ESMF_STDERRORCHECK(rc)) return ! bail out ! Write initialization files @@ -1108,8 +1157,6 @@ subroutine DataInitialize(gcomp, rc) endif endif -! if (btest(verbosity,16)) call WRFHydro_FieldListLog(label=cname) - end subroutine !----------------------------------------------------------------------------- @@ -1313,6 +1360,7 @@ subroutine ModelAdvance(gcomp, rc) character(len=32) :: currTimeStr, advEndTimeStr type(ESMF_TimeInterval) :: timeStep character(len=9) :: nStr + character(len=16) :: misgValTypeStr rc = ESMF_SUCCESS @@ -1370,6 +1418,36 @@ subroutine ModelAdvance(gcomp, rc) if (ESMF_STDERRORCHECK(rc)) return ! bail out endif + if (is%wrap%memr_import.eq.MEMORY_COPY) then + call state_copy_tohyd(is%wrap%NStateImp(1), is%wrap%did, rc=rc) + if (ESMF_STDERRORCHECK(rc)) return ! bail out + endif + + if (is%wrap%misg_import.eq.MISSINGVAL_FAIL) then + call state_check_missing(is%wrap%NStateImp(1), did=is%wrap%did, rc=rc) + if (ESMF_STDERRORCHECK(rc)) return ! bail out + elseif (is%wrap%misg_import.eq.MISSINGVAL_PRESCRIBE) then + call state_prescribe_missing(is%wrap%NStateImp(1), did=is%wrap%did, & + fieldList=cap_fld_list, rc=rc) + if (ESMF_STDERRORCHECK(rc)) return ! bail out + elseif (is%wrap%misg_import.eq.MISSINGVAL_IGNORE) then +! DO NOTHING + else + misgValTypeStr = is%wrap%misg_import + call ESMF_LogSetError(ESMF_FAILURE, & + msg="Unknown missing value handler "//trim(misgValTypeStr), & + line=__LINE__,file=__FILE__,rcToReturn=rc) + return ! bail out + endif + + if (btest(diagnostic,16)) then + call model_debug(is%wrap%NStateImp(1), did=is%wrap%did, & + memflg=is%wrap%memr_import, & + filePrefix=trim(is%wrap%dirOutput)//"/wrfhydro_"// & + rname//"_imp_D"//trim(nStr)//"_"//trim(currTimeStr)//"_", rc=rc) + if (ESMF_STDERRORCHECK(rc)) return ! bail out + endif + is%wrap%stepTimer(1) = is%wrap%stepTimer(1) + timeStep call ESMF_ClockGet(is%wrap%clock(1),timeStep=timestep,rc=rc) @@ -1380,7 +1458,7 @@ subroutine ModelAdvance(gcomp, rc) if (btest(verbosity,16)) then call LogAdvance(nIndex=1,nStr=nStr) endif - call wrfhydro_nuopc_run(is%wrap%did,is%wrap%mode(1), & + call wrfhydro_nuopc_run(is%wrap%did,is%wrap%lsm_forcings(1), & is%wrap%clock(1),is%wrap%NStateImp(1),is%wrap%NStateExp(1),rc) if(ESMF_STDERRORCHECK(rc)) return ! bail out call ESMF_ClockAdvance(is%wrap%clock(1),rc=rc) @@ -1389,6 +1467,25 @@ subroutine ModelAdvance(gcomp, rc) is%wrap%stepTimer(1) - timestep enddo + if (is%wrap%memr_export.eq.MEMORY_COPY) then + call state_copy_frhyd(is%wrap%NStateExp(1), is%wrap%did, rc=rc) + if (ESMF_STDERRORCHECK(rc)) return ! bail out + endif + + if (is%wrap%reset_import) then + if ((is%wrap%memr_import.eq.MEMORY_POINTER) .AND. & + (is%wrap%memr_export.eq.MEMORY_POINTER)) then + call ESMF_LogSetError(ESMF_FAILURE, & + msg="Cannot reset import field if pointer is shared with export.", & + line=__LINE__,file=__FILE__,rcToReturn=rc) + return ! bail out + else + call state_fill_uniform(is%wrap%NStateImp(1), & + fillValue=ESMF_MISSING_VALUE, rc=rc) + if (ESMF_STDERRORCHECK(rc)) return + endif + endif + ! Write export files if (btest(diagnostic,16)) then call NUOPC_Write(is%wrap%NStateExp(1), & @@ -1414,16 +1511,12 @@ subroutine LogAdvance(nIndex,nStr) call ESMF_LogWrite(trim(cname)//': '//rname//& ' Advancing Nest='//trim(nStr),ESMF_LOGMSG_INFO) - select case(is%wrap%mode(nIndex)) - case (WRFHYDRO_Offline) - nModeStr ="WRFHYDRO_Offline" - case (WRFHYDRO_Coupled) + if (is%wrap%lsm_forcings(nIndex)) then nModeStr = "WRFHYDRO_Coupled" - case (WRFHYDRO_Hybrid) - nModeStr = "WRFHYDRO_Hybrid" - case default - nModeStr = "WRFHYDRO_Unknown" - end select + else + nModeStr = "WRFHYDRO_Offline" + endif + write (logMsg, "(A,(A,A,A),(A,A))") trim(cname)//': ', & 'Nest(',trim(nStr),') ', & 'Mode = ',trim(nModeStr) diff --git a/trunk/NDHMS/CPL/NUOPC_cpl/WRFHydro_NUOPC_Fields.F90 b/trunk/NDHMS/CPL/NUOPC_cpl/WRFHydro_NUOPC_Fields.F90 new file mode 100644 index 000000000..af433d45d --- /dev/null +++ b/trunk/NDHMS/CPL/NUOPC_cpl/WRFHydro_NUOPC_Fields.F90 @@ -0,0 +1,1479 @@ +#define FILENAME "WRFHydro_NUOPC_Fields.F90" +#define MODNAME "wrfhydro_nuopc_fields" +#include "WRFHydro_NUOPC_Macros.h" + +module wrfhydro_nuopc_fields +! !MODULE: wrfhydro_nuopc_fields +! +! !DESCRIPTION: +! This module connects NUOPC field information for WRFHYDRO +! +! !REVISION HISTORY: +! 21Jul23 Dan Rosen Initial Specification +! +! !USES: + use ESMF + use NUOPC + use WRFHydro_ESMF_Extensions + use WRFHydro_NUOPC_Flags + use config_base, only: nlst + use module_rt_data, only: rt_domain + use overland_data, only: overland_struct + use overland_control, only: overland_control_struct + + implicit none + + private + + type cap_fld_type + sequence + character(len=64) :: sd_name = "dummy" ! standard name + character(len=64) :: st_name = "dummy" ! state name + character(len=64) :: units = "-" ! units + logical :: ad_import = .FALSE. ! advertise import + logical :: ad_export = .FALSE. ! advertise export + real(ESMF_KIND_R8) :: vl_fillv = ESMF_MISSING_VALUE ! default + logical :: rl_import = .FALSE. ! realize import + logical :: rl_export = .FALSE. ! realize export + end type cap_fld_type + + type(cap_fld_type),target,dimension(20) :: cap_fld_list = (/ & + cap_fld_type("inst_total_soil_moisture_content ","smc ", & + "m3 m-3",.TRUE. ,.TRUE. ,0.20d0), & + cap_fld_type("inst_soil_moisture_content ","slc ", & + "m3 m-3",.TRUE. ,.TRUE. ,0.20d0), & + cap_fld_type("inst_soil_temperature ","stc ", & + "K ",.TRUE. ,.FALSE.,288.d0), & + cap_fld_type("liquid_fraction_of_soil_moisture_layer_1","sh2ox1 ", & + "m3 m-3",.TRUE. ,.TRUE. ,0.20d0), & + cap_fld_type("liquid_fraction_of_soil_moisture_layer_2","sh2ox2 ", & + "m3 m-3",.TRUE. ,.TRUE. ,0.20d0), & + cap_fld_type("liquid_fraction_of_soil_moisture_layer_3","sh2ox3 ", & + "m3 m-3",.TRUE. ,.TRUE. ,0.20d0), & + cap_fld_type("liquid_fraction_of_soil_moisture_layer_4","sh2ox4 ", & + "m3 m-3",.TRUE. ,.TRUE. ,0.20d0), & + cap_fld_type("soil_moisture_fraction_layer_1 ","smc1 ", & + "m3 m-3",.TRUE. ,.TRUE. ,0.20d0), & + cap_fld_type("soil_moisture_fraction_layer_2 ","smc2 ", & + "m3 m-3",.TRUE. ,.TRUE. ,0.20d0), & + cap_fld_type("soil_moisture_fraction_layer_3 ","smc3 ", & + "m3 m-3",.TRUE. ,.TRUE. ,0.20d0), & + cap_fld_type("soil_moisture_fraction_layer_4 ","smc4 ", & + "m3 m-3",.TRUE. ,.TRUE. ,0.20d0), & + cap_fld_type("soil_temperature_layer_1 ","stc1 ", & + "K ",.TRUE. ,.FALSE.,288.d0), & + cap_fld_type("soil_temperature_layer_2 ","stc2 ", & + "K ",.TRUE. ,.FALSE.,288.d0), & + cap_fld_type("soil_temperature_layer_3 ","stc3 ", & + "K ",.TRUE. ,.FALSE.,288.d0), & + cap_fld_type("soil_temperature_layer_4 ","stc4 ", & + "K ",.TRUE. ,.FALSE.,288.d0), & + cap_fld_type("soil_porosity ","smcmax1 ", & + "1 ",.FALSE.,.FALSE.,0.45d0), & + cap_fld_type("vegetation_type ","vegtyp ", & + "1 ",.FALSE.,.FALSE.,16.0d0), & + cap_fld_type("surface_water_depth ","sfchead ", & + "mm ",.FALSE.,.TRUE. ,0.00d0), & + cap_fld_type("time_step_infiltration_excess ","infxsrt ", & + "mm ",.TRUE. ,.FALSE.,0.00d0), & + cap_fld_type("soil_column_drainage ","soldrain", & + "mm ",.TRUE. ,.FALSE.,0.00d0) & + /) + + public cap_fld_list + public field_dictionary_add + public field_create + public field_realize + public field_advertise + public check_lsm_forcings + public field_advertise_log + public field_realize_log + public read_impexp_config_flnm + public field_find_standardname + public field_find_statename + public state_fill_uniform + public state_fill_prescribe + public state_fill_file + public state_copy_tohyd + public state_copy_frhyd + public state_check_missing + public state_prescribe_missing + public model_debug + + !----------------------------------------------------------------------------- + contains + !----------------------------------------------------------------------------- + +#undef METHOD +#define METHOD "field_dictionary_add" + subroutine field_dictionary_add(fieldList, rc) + type(cap_fld_type), intent(in) :: fieldList(:) + integer, intent(out) :: rc + ! local variables + integer :: n + logical :: isPresent + + rc = ESMF_SUCCESS + + do n=lbound(fieldList,1),ubound(fieldList,1) + isPresent = NUOPC_FieldDictionaryHasEntry( & + fieldList(n)%sd_name, rc=rc) + if (ESMF_STDERRORCHECK(rc)) return ! bail out + if (.not.isPresent) then + call NUOPC_FieldDictionaryAddEntry( & + StandardName=trim(fieldList(n)%sd_name), & + canonicalUnits=trim(fieldList(n)%units), & + rc=rc) + if (ESMF_STDERRORCHECK(rc)) return ! bail out + end if + end do + + end subroutine + + !----------------------------------------------------------------------------- + +#undef METHOD +#define METHOD "field_realize" + subroutine field_realize(fieldList, importState, exportState, grid, & + did, realizeAllImport, realizeAllExport, memr_import, memr_export, rc) + type(cap_fld_type), intent(inout) :: fieldList(:) + type(ESMF_State), intent(inout) :: importState + type(ESMF_State), intent(inout) :: exportState + type(ESMF_Grid), intent(in) :: grid + integer, intent(in) :: did + logical, intent(in) :: realizeAllImport + logical, intent(in) :: realizeAllExport + type(memory_flag) :: memr_import + type(memory_flag) :: memr_export + integer, intent(out) :: rc + ! local variables + integer :: n + logical :: realizeImport + logical :: realizeExport + type(ESMF_Field) :: field_import + type(ESMF_Field) :: field_export + + rc = ESMF_SUCCESS + + do n=lbound(fieldList,1),ubound(fieldList,1) + ! check realize import + if (fieldList(n)%ad_import) then + if (realizeAllImport) then + realizeImport = .true. + else + realizeImport = NUOPC_IsConnected(importState, & + fieldName=trim(fieldList(n)%st_name),rc=rc) + if (ESMF_STDERRORCHECK(rc)) return ! bail out + end if + else + realizeImport = .false. + end if + ! create import field + if ( realizeImport ) then + field_import=field_create(fld_name=fieldList(n)%st_name, & + grid=grid, did=did, memflg=memr_import, rc=rc) + if (ESMF_STDERRORCHECK(rc)) return ! bail out + call NUOPC_Realize(importState, field=field_import, rc=rc) + if (ESMF_STDERRORCHECK(rc)) return ! bail out + fieldList(n)%rl_import = .true. + else + call ESMF_StateRemove(importState, (/fieldList(n)%st_name/), & + relaxedflag=.true., rc=rc) + if (ESMF_STDERRORCHECK(rc)) return ! bail out + fieldList(n)%rl_import = .false. + end if + + ! check realize export + if (fieldList(n)%ad_export) then + if (realizeAllExport) then + realizeExport = .true. + else + realizeExport = NUOPC_IsConnected(exportState, & + fieldName=trim(fieldList(n)%st_name),rc=rc) + if (ESMF_STDERRORCHECK(rc)) return ! bail out + end if + else + realizeExport = .false. + end if + ! create export field + if( realizeExport ) then + field_export=field_create(fld_name=fieldList(n)%st_name, & + grid=grid, did=did, memflg=memr_export, rc=rc) + if (ESMF_STDERRORCHECK(rc)) return ! bail out + call NUOPC_Realize(exportState, field=field_export, rc=rc) + if (ESMF_STDERRORCHECK(rc)) return ! bail out + fieldList(n)%rl_export = .true. + else + call ESMF_StateRemove(exportState, (/fieldList(n)%st_name/), & + relaxedflag=.true., rc=rc) + if (ESMF_STDERRORCHECK(rc)) return ! bail out + fieldList(n)%rl_export = .false. + end if + end do + end subroutine + + !----------------------------------------------------------------------------- + +#undef METHOD +#define METHOD "lsm_forcings" + + function check_lsm_forcings(importState,rc) + ! RETURN + logical :: check_lsm_forcings + ! ARGUMENTS + type(ESMF_State), intent(in) :: importState + integer, intent(out) :: rc + ! LOCAL VARIABLES + integer :: fieldIndex + type(ESMF_StateItem_Flag) :: itemType + integer :: s_smc, s_smc1, s_smc2, s_smc3, s_smc4 + integer :: s_slc, s_slc1, s_slc2, s_slc3, s_slc4 + integer :: s_stc, s_stc1, s_stc2, s_stc3, s_stc4 + integer :: s_infxsrt + integer :: s_soldrain + logical :: c_smc + logical :: c_slc + logical :: c_stc + logical :: c_infxsrt + logical :: c_soldrain + + ! total soil moisture content + call ESMF_StateGet(importState,itemSearch="smc", itemCount=s_smc, rc=rc) + if (ESMF_STDERRORCHECK(rc)) return ! bail out + call ESMF_StateGet(importState,itemSearch="smc1",itemCount=s_smc1,rc=rc) + if (ESMF_STDERRORCHECK(rc)) return ! bail out + call ESMF_StateGet(importState,itemSearch="smc2",itemCount=s_smc2,rc=rc) + if (ESMF_STDERRORCHECK(rc)) return ! bail out + call ESMF_StateGet(importState,itemSearch="smc3",itemCount=s_smc3,rc=rc) + if (ESMF_STDERRORCHECK(rc)) return ! bail out + call ESMF_StateGet(importState,itemSearch="smc4",itemCount=s_smc4,rc=rc) + if (ESMF_STDERRORCHECK(rc)) return ! bail out + if (s_smc.gt.0) then + c_smc = NUOPC_IsConnected(importState, fieldName="smc") + elseif ((s_smc1.gt.0) .and. (s_smc2.gt.0) .and. & + (s_smc3.gt.0) .and. (s_smc4.gt.0)) then + c_smc = (NUOPC_IsConnected(importState, fieldName="smc1") .and. & + NUOPC_IsConnected(importState, fieldName="smc2") .and. & + NUOPC_IsConnected(importState, fieldName="smc3") .and. & + NUOPC_IsConnected(importState, fieldName="smc4")) + else + c_smc = .false. + endif + + ! liquid soil moisture content + call ESMF_StateGet(importState,itemSearch="slc", itemCount=s_slc, rc=rc) + if (ESMF_STDERRORCHECK(rc)) return ! bail out + call ESMF_StateGet(importState,itemSearch="sh2ox1",itemCount=s_slc1,rc=rc) + if (ESMF_STDERRORCHECK(rc)) return ! bail out + call ESMF_StateGet(importState,itemSearch="sh2ox2",itemCount=s_slc2,rc=rc) + if (ESMF_STDERRORCHECK(rc)) return ! bail out + call ESMF_StateGet(importState,itemSearch="sh2ox3",itemCount=s_slc3,rc=rc) + if (ESMF_STDERRORCHECK(rc)) return ! bail out + call ESMF_StateGet(importState,itemSearch="sh2ox4",itemCount=s_slc4,rc=rc) + if (ESMF_STDERRORCHECK(rc)) return ! bail out + if (s_slc.gt.0) then + c_slc = NUOPC_IsConnected(importState, fieldName="slc") + elseif ((s_slc1.gt.0) .and. (s_slc2.gt.0) .and. & + (s_slc3.gt.0) .and. (s_slc4.gt.0)) then + c_slc = (NUOPC_IsConnected(importState, fieldName="sh2ox1") .and. & + NUOPC_IsConnected(importState, fieldName="sh2ox2") .and. & + NUOPC_IsConnected(importState, fieldName="sh2ox3") .and. & + NUOPC_IsConnected(importState, fieldName="sh2ox4")) + else + c_slc = .false. + endif + + ! soil temperature + call ESMF_StateGet(importState,itemSearch="stc", itemCount=s_stc, rc=rc) + if (ESMF_STDERRORCHECK(rc)) return ! bail out + call ESMF_StateGet(importState,itemSearch="stc1",itemCount=s_stc1,rc=rc) + if (ESMF_STDERRORCHECK(rc)) return ! bail out + call ESMF_StateGet(importState,itemSearch="stc2",itemCount=s_stc2,rc=rc) + if (ESMF_STDERRORCHECK(rc)) return ! bail out + call ESMF_StateGet(importState,itemSearch="stc3",itemCount=s_stc3,rc=rc) + if (ESMF_STDERRORCHECK(rc)) return ! bail out + call ESMF_StateGet(importState,itemSearch="stc4",itemCount=s_stc4,rc=rc) + if (ESMF_STDERRORCHECK(rc)) return ! bail out + if (s_stc.gt.0) then + c_stc = NUOPC_IsConnected(importState, fieldName="stc") + elseif ((s_stc1.gt.0) .and. (s_stc2.gt.0) .and. & + (s_stc3.gt.0) .and. (s_stc4.gt.0)) then + c_stc = (NUOPC_IsConnected(importState, fieldName="stc1") .and. & + NUOPC_IsConnected(importState, fieldName="stc2") .and. & + NUOPC_IsConnected(importState, fieldName="stc3") .and. & + NUOPC_IsConnected(importState, fieldName="stc4")) + else + c_stc = .false. + endif + + ! infiltration excess + call ESMF_StateGet(importState,itemSearch="infxsrt",itemCount=s_infxsrt,rc=rc) + if (ESMF_STDERRORCHECK(rc)) return ! bail out + if (s_infxsrt.gt.0) then + c_infxsrt = NUOPC_IsConnected(importState, fieldName="infxsrt") + else + c_infxsrt = .false. + endif + + ! soil drainage + call ESMF_StateGet(importState,itemSearch="soldrain",itemCount=s_soldrain,rc=rc) + if (ESMF_STDERRORCHECK(rc)) return ! bail out + if (s_soldrain.gt.0) then + c_soldrain = NUOPC_IsConnected(importState, fieldName="soldrain") + else + c_soldrain = .false. + endif + + check_lsm_forcings = c_smc .and. c_slc .and. c_stc .and. & + c_infxsrt .and. c_soldrain + + end function + + !----------------------------------------------------------------------------- + +#undef METHOD +#define METHOD "field_advertise" + subroutine field_advertise(fieldList, importState, exportState, & + transferOffer, rc) + type(cap_fld_type), intent(in) :: fieldList(:) + type(ESMF_State), intent(inout) :: importState + type(ESMF_State), intent(inout) :: exportState + character(*), intent(in),optional :: transferOffer + integer, intent(out) :: rc + ! local variables + integer :: n + + rc = ESMF_SUCCESS + + do n=lbound(fieldList,1),ubound(fieldList,1) + if (fieldList(n)%ad_import) then + call NUOPC_Advertise(importState, & + StandardName=fieldList(n)%sd_name, & + Units=fieldList(n)%units, & + TransferOfferGeomObject=transferOffer, & + name=fieldList(n)%st_name, & + rc=rc) + if (ESMF_STDERRORCHECK(rc)) return ! bail out + end if + if (fieldList(n)%ad_export) then + call NUOPC_Advertise(exportState, & + StandardName=fieldList(n)%sd_name, & + Units=fieldList(n)%units, & + TransferOfferGeomObject=transferOffer, & + name=fieldList(n)%st_name, & + rc=rc) + if (ESMF_STDERRORCHECK(rc)) return ! bail out + end if + end do + + end subroutine + + !----------------------------------------------------------------------------- + +#undef METHOD +#define METHOD "field_advertise_log" + subroutine field_advertise_log(fieldList, cname, rc) + type(cap_fld_type), intent(in) :: fieldList(:) + character(*), intent(in) :: cname + integer, intent(out) :: rc + ! local variables + integer :: cntImp + integer :: cntExp + integer :: n + character(32) :: label + character(ESMF_MAXSTR) :: logMsg + + rc = ESMF_SUCCESS + + label = trim(cname) + + ! count advertised import and export fields + cntImp = 0 + cntExp = 0 + do n = lbound(fieldList,1), ubound(fieldList,1) + if (fieldList(n)%ad_import) cntImp = cntImp + 1 + if (fieldList(n)%ad_export) cntExp = cntExp + 1 + enddo + + ! log advertised import fields + write(logMsg,'(a,a,i0,a)') trim(label)//': ', & + 'List of advertised import fields(',cntImp,'):' + call ESMF_LogWrite(trim(logMsg), ESMF_LOGMSG_INFO) + write(logMsg,'(a,a5,a,a16,a,a)') trim(label)//': ', & + 'index',' ','name',' ','standardName' + call ESMF_LogWrite(trim(logMsg), ESMF_LOGMSG_INFO) + cntImp = 0 + do n=lbound(fieldList,1), ubound(fieldList,1) + if (.NOT.fieldList(n)%ad_import) cycle + cntImp = cntImp + 1 + write(logMsg,'(a,i5,a,a16,a,a)') trim(label)//': ', & + cntImp,' ',trim(fieldList(n)%st_name), & + ' ',trim(fieldList(n)%sd_name) + call ESMF_LogWrite(trim(logMsg), ESMF_LOGMSG_INFO) + enddo + + ! log advertised export fields + write(logMsg,'(a,a,i0,a)') trim(label)//': ', & + 'List of advertised export fields(',cntExp,'):' + call ESMF_LogWrite(trim(logMsg), ESMF_LOGMSG_INFO) + write(logMsg,'(a,a5,a,a16,a,a)') trim(label)//': ', & + 'index',' ','name',' ','standardName' + call ESMF_LogWrite(trim(logMsg), ESMF_LOGMSG_INFO) + cntExp = 0 + do n=lbound(fieldList,1), ubound(fieldList,1) + if (.NOT.fieldList(n)%ad_export) cycle + cntExp = cntExp + 1 + write(logMsg,'(a,i5,a,a16,a,a)') trim(label)//': ', & + cntExp,' ',trim(fieldList(n)%st_name), & + ' ',trim(fieldList(n)%sd_name) + call ESMF_LogWrite(trim(logMsg), ESMF_LOGMSG_INFO) + enddo + + end subroutine + + !----------------------------------------------------------------------------- + +#undef METHOD +#define METHOD "field_realize_log" + subroutine field_realize_log(fieldList, cname, rc) + type(cap_fld_type), intent(in) :: fieldList(:) + character(*), intent(in) :: cname + integer, intent(out) :: rc + ! local variables + integer :: cntImp + integer :: cntExp + integer :: n + character(32) :: label + character(ESMF_MAXSTR) :: logMsg + + rc = ESMF_SUCCESS + + label = trim(cname) + + ! count realized import and export fields + cntImp = 0 + cntExp = 0 + do n = lbound(fieldList,1), ubound(fieldList,1) + if (fieldList(n)%rl_import) cntImp = cntImp + 1 + if (fieldList(n)%rl_export) cntExp = cntExp + 1 + enddo + + ! log realized import fields + write(logMsg,'(a,a,i0,a)') trim(label)//': ', & + 'List of realized import fields(',cntImp,'):' + call ESMF_LogWrite(trim(logMsg), ESMF_LOGMSG_INFO) + write(logMsg,'(a,a5,a,a16,a,a)') trim(label)//': ', & + 'index',' ','name',' ','standardName' + call ESMF_LogWrite(trim(logMsg), ESMF_LOGMSG_INFO) + cntImp = 0 + do n=lbound(fieldList,1), ubound(fieldList,1) + if (.NOT.fieldList(n)%rl_import) cycle + cntImp = cntImp + 1 + write(logMsg,'(a,i5,a,a16,a,a)') trim(label)//': ', & + cntImp,' ',trim(fieldList(n)%st_name), & + ' ',trim(fieldList(n)%sd_name) + call ESMF_LogWrite(trim(LogMsg), ESMF_LOGMSG_INFO) + enddo + + ! log realized export fields + write(logMsg,'(a,a,i0,a)') trim(label)//': ', & + 'List of realized export fields(',cntExp,'):' + call ESMF_LogWrite(trim(logMsg), ESMF_LOGMSG_INFO) + write(logMsg,'(a,a5,a,a16,a,a)') trim(label)//': ', & + 'index',' ','name',' ','standardName' + call ESMF_LogWrite(trim(logMsg), ESMF_LOGMSG_INFO) + cntExp = 0 + do n=lbound(fieldList,1), ubound(fieldList,1) + if (.NOT.fieldList(n)%rl_export) cycle + cntExp = cntExp + 1 + write(logMsg,'(a,i5,a,a16,a,a)') trim(label)//': ', & + cntExp,' ',trim(fieldList(n)%st_name), & + ' ',trim(fieldList(n)%sd_name) + call ESMF_LogWrite(trim(LogMsg), ESMF_LOGMSG_INFO) + enddo + + end subroutine + + !----------------------------------------------------------------------------- + +#undef METHOD +#define METHOD "read_impexp_config_flnm" + subroutine read_impexp_config_flnm(fname, fieldList, rc) + character(len=30),intent(in) :: fname + type(cap_fld_type),intent(inout) :: fieldList(:) + integer,intent(out) :: rc + + ! local variables + type(ESMF_Config) :: fieldsConfig + type(NUOPC_FreeFormat) :: attrFF + integer :: lineCount + integer :: tokenCount + character(len=NUOPC_FreeFormatLen),allocatable :: tokenList(:) + integer :: i,j + integer :: stat + + rc = ESMF_SUCCESS + +! load fname into fieldsConfig + fieldsConfig = ESMF_ConfigCreate(rc=rc) + if (ESMF_STDERRORCHECK(rc)) return ! bail out + call ESMF_ConfigLoadFile(fieldsConfig, fname, rc=rc) + if (ESMF_STDERRORCHECK(rc)) return ! bail out + +! read export fields from config + attrFF = NUOPC_FreeFormatCreate(fieldsConfig, & + label="hyd_fields", rc=rc) + if (ESMF_STDERRORCHECK(rc)) return ! bail out + call NUOPC_FreeFormatGet(attrFF, lineCount=lineCount, rc=rc) + if (ESMF_STDERRORCHECK(rc)) return ! bail out + do i=1, lineCount + call NUOPC_FreeFormatGetLine(attrFF, line=i, & + tokenCount=tokenCount, rc=rc) + if (ESMF_STDERRORCHECK(rc)) return ! bail out + if (.not.((tokenCount.eq.5).or.(tokenCount.eq.6))) then + call ESMF_LogSetError(ESMF_FAILURE, & + msg="Malformed ocn_export_fields item FORMAT="// & + "'STATE_NAME' 'STANDARD_NAME' 'UNITS' 'IMPORT' 'EXPORT' "// & +! "['FILLVAL'] "// & + "in file: "//trim(fname), & + CONTEXT, rcToReturn=rc) + return ! bail out + endif + allocate(tokenList(tokenCount)) + call NUOPC_FreeFormatGetLine(attrFF, line=i, tokenList=tokenList, rc=rc) + if (ESMF_STDERRORCHECK(rc)) return ! bail out + call field_find_statename(fieldList, tokenList(1), location=j, rc=rc) + if (ESMF_STDERRORCHECK(rc)) return ! bail out + fieldList(j)%st_name=tokenList(1) + fieldList(j)%sd_name=tokenList(2) + fieldList(j)%units=tokenList(3) + tokenList(4) = ESMF_UtilStringUpperCase(tokenList(4), rc=rc) + if (ESMF_STDERRORCHECK(rc)) return ! bail out + fieldList(j)%ad_import=((tokenList(4).eq.".TRUE.") .or. & + (tokenList(4).eq."TRUE")) + tokenList(5) = ESMF_UtilStringUpperCase(tokenList(5), rc=rc) + if (ESMF_STDERRORCHECK(rc)) return ! bail out + fieldList(j)%ad_export=((tokenList(5).eq.".TRUE.") .or. & + (tokenList(5).eq."TRUE")) + if (tokenCount.eq.6) then + fieldList(j)%vl_fillv = ESMF_UtilString2Real(tokenList(6), rc=rc) + if (ESMF_STDERRORCHECK(rc)) return ! bail out + endif + deallocate(tokenList) + enddo + +! cleanup + call NUOPC_FreeFormatDestroy(attrFF, rc=rc) + if (ESMF_STDERRORCHECK(rc)) return ! bail out + call ESMF_ConfigDestroy(fieldsConfig, rc=rc) + if (ESMF_STDERRORCHECK(rc)) return ! bail out + + end subroutine read_impexp_config_flnm + + !----------------------------------------------------------------------------- + +#undef METHOD +#define METHOD "field_find_standardname" + subroutine field_find_standardname(fieldList, standardName, location, & + fillValue, rc) + type(cap_fld_type), intent(in) :: fieldList(:) + character(len=64), intent(in) :: standardName + integer, intent(out), optional :: location + real(ESMF_KIND_R8),intent(out),optional :: fillValue + integer, intent(out) :: rc + ! local variables + integer :: n + + rc = ESMF_RC_NOT_FOUND + + if (present(location)) location = lbound(fieldList,1) - 1 + if (present(fillValue)) fillValue = ESMF_MISSING_VALUE + + do n=lbound(fieldList,1),ubound(fieldList,1) + if (fieldList(n)%sd_name .eq. standardName) then + if (present(location)) location = n + if (present(fillValue)) fillValue = fieldList(n)%vl_fillv + rc = ESMF_SUCCESS + return + end if + end do + + if (ESMF_LogFoundError(rcToCheck=rc, & + msg="Field not found in fieldList "//trim(standardName), & + line=__LINE__, & + file=__FILE__)) & + return ! bail out + + end subroutine + + !----------------------------------------------------------------------------- + +#undef METHOD +#define METHOD "field_find_statename" + subroutine field_find_statename(fieldList, stateName, location, & + fillValue, rc) + type(cap_fld_type), intent(in) :: fieldList(:) + character(len=64), intent(in) :: stateName + integer, intent(out), optional :: location + real(ESMF_KIND_R8),intent(out),optional :: fillValue + integer, intent(out) :: rc + ! local variables + integer :: n + + rc = ESMF_RC_NOT_FOUND + + if (present(location)) location = lbound(fieldList,1) - 1 + if (present(fillValue)) fillValue = ESMF_MISSING_VALUE + + do n=lbound(fieldList,1),ubound(fieldList,1) + if (fieldList(n)%st_name .eq. stateName) then + if (present(location)) location = n + if (present(fillValue)) fillValue = fieldList(n)%vl_fillv + rc = ESMF_SUCCESS + return + end if + end do + + if (ESMF_LogFoundError(rcToCheck=rc, & + msg="Field not found in fieldList "//trim(stateName), & + line=__LINE__, & + file=__FILE__)) & + return ! bail out + + end subroutine + + !----------------------------------------------------------------------------- + +#undef METHOD +#define METHOD "field_create" + function field_create(fld_name,grid,did,memflg,rc) + ! return value + type(ESMF_Field) :: field_create + ! arguments + character(*), intent(in) :: fld_name + type(ESMF_Grid), intent(in) :: grid + integer, intent(in) :: did + type(memory_flag), intent(in) :: memflg + integer, intent(out) :: rc + ! local variables + character(len=16) :: cmemflg + + + rc = ESMF_SUCCESS + + if (memflg .eq. MEMORY_POINTER) then + select case (trim(fld_name)) + case ('smc') + field_create = ESMF_FieldCreate(name=fld_name, grid=grid, & + farray=rt_domain(did)%smc(:,:,:), gridToFieldMap=(/1,2/), & + ungriddedLBound=(/1/), ungriddedUBound=(/nlst(did)%nsoil/), & + indexflag=ESMF_INDEX_DELOCAL, rc=rc) + if(ESMF_STDERRORCHECK(rc)) return ! bail out + case ('slc') + field_create = ESMF_FieldCreate(name=fld_name, grid=grid, & + farray=rt_domain(did)%sh2ox(:,:,:), gridToFieldMap=(/1,2/), & + ungriddedLBound=(/1/), ungriddedUBound=(/nlst(did)%nsoil/), & + indexflag=ESMF_INDEX_DELOCAL, rc=rc) + if(ESMF_STDERRORCHECK(rc)) return ! bail out + case ('stc') + field_create = ESMF_FieldCreate(name=fld_name, grid=grid, & + farray=rt_domain(did)%stc(:,:,:), gridToFieldMap=(/1,2/), & + ungriddedLBound=(/1/), ungriddedUBound=(/nlst(did)%nsoil/), & + indexflag=ESMF_INDEX_DELOCAL, rc=rc) + if(ESMF_STDERRORCHECK(rc)) return ! bail out + case ('sh2ox1') + field_create = ESMF_FieldCreate(name=fld_name, grid=grid, & + farray=rt_domain(did)%sh2ox(:,:,1), & + indexflag=ESMF_INDEX_DELOCAL, rc=rc) + if(ESMF_STDERRORCHECK(rc)) return ! bail out + case ('sh2ox2') + field_create = ESMF_FieldCreate(name=fld_name, grid=grid, & + farray=rt_domain(did)%sh2ox(:,:,2), & + indexflag=ESMF_INDEX_DELOCAL, rc=rc) + if(ESMF_STDERRORCHECK(rc)) return ! bail out + case ('sh2ox3') + field_create = ESMF_FieldCreate(name=fld_name, grid=grid, & + farray=rt_domain(did)%sh2ox(:,:,3), & + indexflag=ESMF_INDEX_DELOCAL, rc=rc) + if(ESMF_STDERRORCHECK(rc)) return ! bail out + case ('sh2ox4') + field_create = ESMF_FieldCreate(name=fld_name, grid=grid, & + farray=rt_domain(did)%sh2ox(:,:,4), & + indexflag=ESMF_INDEX_DELOCAL, rc=rc) + if(ESMF_STDERRORCHECK(rc)) return ! bail out + case ('smc1') + field_create = ESMF_FieldCreate(name=fld_name, grid=grid, & + farray=rt_domain(did)%smc(:,:,1), & + indexflag=ESMF_INDEX_DELOCAL, rc=rc) + if(ESMF_STDERRORCHECK(rc)) return ! bail out + case ('smc2') + field_create = ESMF_FieldCreate(name=fld_name, grid=grid, & + farray=rt_domain(did)%smc(:,:,2), & + indexflag=ESMF_INDEX_DELOCAL, rc=rc) + if(ESMF_STDERRORCHECK(rc)) return ! bail out + case ('smc3') + field_create = ESMF_FieldCreate(name=fld_name, grid=grid, & + farray=rt_domain(did)%smc(:,:,3), & + indexflag=ESMF_INDEX_DELOCAL, rc=rc) + if(ESMF_STDERRORCHECK(rc)) return ! bail out + case ('smc4') + field_create = ESMF_FieldCreate(name=fld_name, grid=grid, & + farray=rt_domain(did)%smc(:,:,4), & + indexflag=ESMF_INDEX_DELOCAL, rc=rc) + if(ESMF_STDERRORCHECK(rc)) return ! bail out + case ('smcmax1') + field_create = ESMF_FieldCreate(name=fld_name, grid=grid, & + farray=rt_domain(did)%smcmax1, & + indexflag=ESMF_INDEX_DELOCAL, rc=rc) + if(ESMF_STDERRORCHECK(rc)) return ! bail out + case ('stc1') + field_create = ESMF_FieldCreate(name=fld_name, grid=grid, & + farray=rt_domain(did)%stc(:,:,1), & + indexflag=ESMF_INDEX_DELOCAL, rc=rc) + if(ESMF_STDERRORCHECK(rc)) return ! bail out + case ('stc2') + field_create = ESMF_FieldCreate(name=fld_name, grid=grid, & + farray=rt_domain(did)%stc(:,:,2), & + indexflag=ESMF_INDEX_DELOCAL, rc=rc) + if(ESMF_STDERRORCHECK(rc)) return ! bail out + case ('stc3') + field_create = ESMF_FieldCreate(name=fld_name, grid=grid, & + farray=rt_domain(did)%stc(:,:,3), & + indexflag=ESMF_INDEX_DELOCAL, rc=rc) + if(ESMF_STDERRORCHECK(rc)) return ! bail out + case ('stc4') + field_create = ESMF_FieldCreate(name=fld_name, grid=grid, & + farray=rt_domain(did)%stc(:,:,4), & + indexflag=ESMF_INDEX_DELOCAL, rc=rc) + if(ESMF_STDERRORCHECK(rc)) return ! bail out + case ('vegtyp') + field_create = ESMF_FieldCreate(name=fld_name, grid=grid, & + farray=rt_domain(did)%vegtyp, & + indexflag=ESMF_INDEX_DELOCAL, rc=rc) + if(ESMF_STDERRORCHECK(rc)) return ! bail out + case ('sfchead') + field_create = ESMF_FieldCreate(name=fld_name, grid=grid, & + farray=rt_domain(did)%overland%control%surface_water_head_lsm, & + indexflag=ESMF_INDEX_DELOCAL, rc=rc) + if(ESMF_STDERRORCHECK(rc)) return ! bail out + case ('infxsrt') + field_create = ESMF_FieldCreate(name=fld_name, grid=grid, & + farray=rt_domain(did)%infxsrt, & + indexflag=ESMF_INDEX_DELOCAL, rc=rc) + if (ESMF_STDERRORCHECK(rc)) return + case ('soldrain') + field_create = ESMF_FieldCreate(name=fld_name, grid=grid, & + farray=rt_domain(did)%soldrain, & + indexflag=ESMF_INDEX_DELOCAL, rc=rc) + if (ESMF_STDERRORCHECK(rc)) return + case default + call ESMF_LogSetError(ESMF_FAILURE, & + msg=METHOD//": Field hookup missing: "//trim(fld_name), & + file=FILENAME,rcToReturn=rc) + return ! bail out + end select + elseif (memflg .eq. MEMORY_COPY) then + select case (trim(fld_name)) + case ('smc','slc','stc') + field_create = ESMF_FieldCreate(name=fld_name, grid=grid, & + typekind=ESMF_TYPEKIND_FIELD, gridToFieldMap=(/1,2/), & + ungriddedLBound=(/1/), ungriddedUBound=(/nlst(did)%nsoil/), & + indexflag=ESMF_INDEX_DELOCAL, rc=rc) + if(ESMF_STDERRORCHECK(rc)) return ! bail out + case default + field_create = ESMF_FieldCreate(name=fld_name, grid=grid, & + typekind=ESMF_TYPEKIND_FIELD, & + indexflag=ESMF_INDEX_DELOCAL, rc=rc) + if (ESMF_STDERRORCHECK(rc)) return + end select + call ESMF_FieldFill(field_create, dataFillScheme="const", & + const1=ESMF_MISSING_VALUE, rc=rc) + if (ESMF_STDERRORCHECK(rc)) return + else + cmemflg = memflg + call ESMF_LogSetError(ESMF_FAILURE, & + msg=METHOD//": Field memory flag unknown: "//trim(cmemflg), & + file=FILENAME,rcToReturn=rc) + return ! bail out + endif + + end function + + !----------------------------------------------------------------------------- + +#undef METHOD +#define METHOD "state_fill_uniform" + subroutine state_fill_uniform(state, fillValue, rc) + type(ESMF_State), intent(inout) :: state + real(ESMF_KIND_R8), intent(in) :: fillValue + integer, intent(out) :: rc + ! local variables + integer :: n + integer :: itemCount + character(len=64),allocatable :: itemNameList(:) + type(ESMF_StateItem_Flag), allocatable :: itemTypeList(:) + type(ESMF_Field) :: field + integer :: stat + + rc = ESMF_SUCCESS + + call ESMF_StateGet(state,itemCount=itemCount, rc=rc) + if (ESMF_STDERRORCHECK(rc)) return ! bail out + + allocate(itemNameList(itemCount), stat=stat) + if (ESMF_LogFoundAllocError(statusToCheck=stat, & + msg="Allocation of state item name memory failed.", & + line=__LINE__, file=__FILE__)) return ! bail out + allocate(itemTypeList(itemCount), stat=stat) + if (ESMF_LogFoundAllocError(statusToCheck=stat, & + msg="Allocation of state item type memory failed.", & + line=__LINE__, file=__FILE__)) return ! bail out + + call ESMF_StateGet(state,itemNameList=itemNameList, & + itemTypeList=itemTypeList,rc=rc) + if (ESMF_STDERRORCHECK(rc)) return + + do n=1, itemCount + if (itemTypeList(n) == ESMF_STATEITEM_FIELD) then + call ESMF_StateGet(state, field=field, & + itemName=itemNameList(n),rc=rc) + if (ESMF_STDERRORCHECK(rc)) return + call ESMF_FieldFill(field, dataFillScheme="const", & + const1=fillValue, rc=rc) + if (ESMF_STDERRORCHECK(rc)) return + call NUOPC_SetAttribute(field, name="Updated", value="true", rc=rc) + if (ESMF_STDERRORCHECK(rc)) return ! bail out + endif + enddo + + deallocate(itemNameList) + deallocate(itemTypeList) + + end subroutine state_fill_uniform + + !----------------------------------------------------------------------------- + +#undef METHOD +#define METHOD "state_fill_prescribe" + subroutine state_fill_prescribe(state, fieldList, rc) + type(ESMF_State), intent(inout) :: state + type(cap_fld_type), intent(in) :: fieldList(:) + integer, intent(out) :: rc + ! local variables + integer :: n + integer :: itemCount + character(len=64),allocatable :: itemNameList(:) + type(ESMF_StateItem_Flag), allocatable :: itemTypeList(:) + type(ESMF_Field) :: field + real(ESMF_KIND_R8) :: filVal + integer :: stat + + rc = ESMF_SUCCESS + + call ESMF_StateGet(state,itemCount=itemCount, rc=rc) + if (ESMF_STDERRORCHECK(rc)) return ! bail out + + allocate(itemNameList(itemCount), stat=stat) + if (ESMF_LogFoundAllocError(statusToCheck=stat, & + msg="Allocation of state item name memory failed.", & + line=__LINE__, file=__FILE__)) return ! bail out + allocate(itemTypeList(itemCount), stat=stat) + if (ESMF_LogFoundAllocError(statusToCheck=stat, & + msg="Allocation of state item type memory failed.", & + line=__LINE__, file=__FILE__)) return ! bail out + + call ESMF_StateGet(state,itemNameList=itemNameList, & + itemTypeList=itemTypeList,rc=rc) + if (ESMF_STDERRORCHECK(rc)) return + + do n=1, itemCount + if (itemTypeList(n) == ESMF_STATEITEM_FIELD) then + call field_find_statename(fieldList, & + stateName=itemNameList(n), fillValue=filVal, rc=rc) + if (ESMF_STDERRORCHECK(rc)) return + call ESMF_StateGet(state, field=field, & + itemName=itemNameList(n),rc=rc) + if (ESMF_STDERRORCHECK(rc)) return + call ESMF_FieldFill(field, dataFillScheme="const", & + const1=filVal, rc=rc) + if (ESMF_STDERRORCHECK(rc)) return + call NUOPC_SetAttribute(field, name="Updated", value="true", rc=rc) + if (ESMF_STDERRORCHECK(rc)) return ! bail out + endif + enddo + + deallocate(itemNameList) + deallocate(itemTypeList) + + end subroutine state_fill_prescribe + + !----------------------------------------------------------------------------- + +#undef METHOD +#define METHOD "state_fill_file" + subroutine state_fill_file(state, filePrefix, rc) + type(ESMF_State), intent(inout) :: state + character(len=*), intent(in) :: filePrefix + integer, intent(out) :: rc + ! local variables + integer :: n + integer :: itemCount + character(len=64),allocatable :: itemNameList(:) + type(ESMF_StateItem_Flag), allocatable :: itemTypeList(:) + type(ESMF_Field) :: field + character(len=64) :: fldName + integer :: stat + + rc = ESMF_SUCCESS + + call ESMF_StateGet(state,itemCount=itemCount, rc=rc) + if (ESMF_STDERRORCHECK(rc)) return ! bail out + + allocate(itemNameList(itemCount), stat=stat) + if (ESMF_LogFoundAllocError(statusToCheck=stat, & + msg="Allocation of state item name memory failed.", & + line=__LINE__, file=__FILE__)) return ! bail out + allocate(itemTypeList(itemCount), stat=stat) + if (ESMF_LogFoundAllocError(statusToCheck=stat, & + msg="Allocation of state item type memory failed.", & + line=__LINE__, file=__FILE__)) return ! bail out + + call ESMF_StateGet(state,itemNameList=itemNameList, & + itemTypeList=itemTypeList,rc=rc) + if (ESMF_STDERRORCHECK(rc)) return + + do n=1, itemCount + if ( itemTypeList(n) == ESMF_STATEITEM_FIELD) then + call ESMF_StateGet(state,field=field, & + itemName=itemNameList(n),rc=rc) + if (ESMF_STDERRORCHECK(rc)) return + call NUOPC_GetAttribute(field, name="StandardName", & + value=fldName, rc=rc) + if (ESMF_STDERRORCHECK(rc)) return + call ESMF_FieldRead(field, variableName=trim(fldName), & + fileName=trim(filePrefix)//"_"//trim(itemNameList(n))//".nc", & + iofmt=ESMF_IOFMT_NETCDF, rc=rc) + if (ESMF_STDERRORCHECK(rc)) return + call NUOPC_SetAttribute(field, name="Updated", value="true", rc=rc) + if (ESMF_STDERRORCHECK(rc)) return ! bail out + endif + enddo + + deallocate(itemNameList) + deallocate(itemTypeList) + + end subroutine state_fill_file + + !----------------------------------------------------------------------------- + +#undef METHOD +#define METHOD "state_copy_tohyd" + subroutine state_copy_tohyd(state, did, rc) + type(ESMF_State), intent(inout) :: state + integer, intent(in) :: did + integer, intent(out) :: rc + ! local variables + integer :: n + integer :: itemCount + character(len=64),allocatable :: itemNameList(:) + type(ESMF_StateItem_Flag), allocatable :: itemTypeList(:) + type(ESMF_Field) :: field + integer :: dimCount + real(ESMF_KIND_FIELD), pointer :: farrayPtr2d(:,:) + real(ESMF_KIND_FIELD), pointer :: farrayPtr3d(:,:,:) + integer :: stat + + rc = ESMF_SUCCESS + + call ESMF_StateGet(state,itemCount=itemCount, rc=rc) + if (ESMF_STDERRORCHECK(rc)) return ! bail out + + allocate(itemNameList(itemCount), stat=stat) + if (ESMF_LogFoundAllocError(statusToCheck=stat, & + msg="Allocation of state item name memory failed.", & + line=__LINE__, file=__FILE__)) return ! bail out + allocate(itemTypeList(itemCount), stat=stat) + if (ESMF_LogFoundAllocError(statusToCheck=stat, & + msg="Allocation of state item type memory failed.", & + line=__LINE__, file=__FILE__)) return ! bail out + + call ESMF_StateGet(state,itemNameList=itemNameList, & + itemTypeList=itemTypeList,rc=rc) + if (ESMF_STDERRORCHECK(rc)) return + + do n=1, itemCount + if (itemTypeList(n) == ESMF_STATEITEM_FIELD) then + call ESMF_StateGet(state, field=field, & + itemName=itemNameList(n),rc=rc) + if (ESMF_STDERRORCHECK(rc)) return + call ESMF_FieldGet(field, dimCount=dimCount, rc=rc) + if (ESMF_STDERRORCHECK(rc)) return + if (dimCount .eq. 2) then + call ESMF_FieldGet(field, farrayPtr=farrayPtr2d, rc=rc) + if (ESMF_STDERRORCHECK(rc)) return + elseif (dimCount .eq. 3) then + call ESMF_FieldGet(field, farrayPtr=farrayPtr3d, rc=rc) + if (ESMF_STDERRORCHECK(rc)) return + else + call ESMF_LogSetError(ESMF_FAILURE, & + msg=METHOD//": dimCount is not supported.", & + file=FILENAME,rcToReturn=rc) + return ! bail out + endif + select case (ItemNameList(n)) + case ('smc') + rt_domain(did)%smc = farrayPtr3d + case ('slc') + rt_domain(did)%sh2ox = farrayPtr3d + case ('stc') + rt_domain(did)%stc = farrayPtr3d + case ('sh2ox1') + rt_domain(did)%sh2ox(:,:,1) = farrayPtr2d + case ('sh2ox2') + rt_domain(did)%sh2ox(:,:,2) = farrayPtr2d + case ('sh2ox3') + rt_domain(did)%sh2ox(:,:,3) = farrayPtr2d + case ('sh2ox4') + rt_domain(did)%sh2ox(:,:,4) = farrayPtr2d + case ('smc1') + rt_domain(did)%smc(:,:,1) = farrayPtr2d + case ('smc2') + rt_domain(did)%smc(:,:,2) = farrayPtr2d + case ('smc3') + rt_domain(did)%smc(:,:,3) = farrayPtr2d + case ('smc4') + rt_domain(did)%smc(:,:,4) = farrayPtr2d + case ('smcmax1') + rt_domain(did)%smcmax1 = farrayPtr2d + case ('stc1') + rt_domain(did)%stc(:,:,1) = farrayPtr2d + case ('stc2') + rt_domain(did)%stc(:,:,2) = farrayPtr2d + case ('stc3') + rt_domain(did)%stc(:,:,3) = farrayPtr2d + case ('stc4') + rt_domain(did)%stc(:,:,4) = farrayPtr2d + case ('vegtyp') + rt_domain(did)%vegtyp = farrayPtr2d + case ('sfchead') + rt_domain(did)%overland%control%surface_water_head_lsm = & + farrayPtr2d + case ('infxsrt') + rt_domain(did)%infxsrt = farrayPtr2d + case ('soldrain') + rt_domain(did)%soldrain = farrayPtr2d + case default + call ESMF_LogSetError(ESMF_FAILURE, & + msg=METHOD//": Field hookup missing: "//trim(itemNameList(n)), & + file=FILENAME,rcToReturn=rc) + return ! bail out + endselect + endif + enddo + + deallocate(itemNameList) + deallocate(itemTypeList) + + end subroutine state_copy_tohyd + + !----------------------------------------------------------------------------- + +#undef METHOD +#define METHOD "state_copy_frhyd" + subroutine state_copy_frhyd(state, did, rc) + type(ESMF_State), intent(inout) :: state + integer, intent(in) :: did + integer, intent(out) :: rc + ! local variables + integer :: n + integer :: itemCount + character(len=64),allocatable :: itemNameList(:) + type(ESMF_StateItem_Flag), allocatable :: itemTypeList(:) + type(ESMF_Field) :: field + integer :: dimCount + real(ESMF_KIND_FIELD), pointer :: farrayPtr2d(:,:) + real(ESMF_KIND_FIELD), pointer :: farrayPtr3d(:,:,:) + integer :: stat + character(len=16) :: cmissingv_flag + + rc = ESMF_SUCCESS + + call ESMF_StateGet(state,itemCount=itemCount, rc=rc) + if (ESMF_STDERRORCHECK(rc)) return ! bail out + + allocate(itemNameList(itemCount), stat=stat) + if (ESMF_LogFoundAllocError(statusToCheck=stat, & + msg="Allocation of state item name memory failed.", & + line=__LINE__, file=__FILE__)) return ! bail out + allocate(itemTypeList(itemCount), stat=stat) + if (ESMF_LogFoundAllocError(statusToCheck=stat, & + msg="Allocation of state item type memory failed.", & + line=__LINE__, file=__FILE__)) return ! bail out + + call ESMF_StateGet(state,itemNameList=itemNameList, & + itemTypeList=itemTypeList,rc=rc) + if (ESMF_STDERRORCHECK(rc)) return + + do n=1, itemCount + if (itemTypeList(n) == ESMF_STATEITEM_FIELD) then + call ESMF_StateGet(state, field=field, & + itemName=itemNameList(n),rc=rc) + if (ESMF_STDERRORCHECK(rc)) return + call ESMF_FieldGet(field, dimCount=dimCount, rc=rc) + if (ESMF_STDERRORCHECK(rc)) return + if (dimCount .eq. 2) then + call ESMF_FieldGet(field, farrayPtr=farrayPtr2d, rc=rc) + if (ESMF_STDERRORCHECK(rc)) return + elseif (dimCount .eq. 3) then + call ESMF_FieldGet(field, farrayPtr=farrayPtr3d, rc=rc) + if (ESMF_STDERRORCHECK(rc)) return + else + call ESMF_LogSetError(ESMF_FAILURE, & + msg=METHOD//": dimCount is not supported.", & + file=FILENAME,rcToReturn=rc) + return ! bail out + endif + select case (ItemNameList(n)) + case ('smc') + farrayPtr3d = rt_domain(did)%smc + case ('slc') + farrayPtr3d = rt_domain(did)%sh2ox + case ('stc') + farrayPtr3d = rt_domain(did)%stc + case ('sh2ox1') + farrayPtr2d = rt_domain(did)%sh2ox(:,:,1) + case ('sh2ox2') + farrayPtr2d = rt_domain(did)%sh2ox(:,:,2) + case ('sh2ox3') + farrayPtr2d = rt_domain(did)%sh2ox(:,:,3) + case ('sh2ox4') + farrayPtr2d = rt_domain(did)%sh2ox(:,:,4) + case ('smc1') + farrayPtr2d = rt_domain(did)%smc(:,:,1) + case ('smc2') + farrayPtr2d = rt_domain(did)%smc(:,:,2) + case ('smc3') + farrayPtr2d = rt_domain(did)%smc(:,:,3) + case ('smc4') + farrayPtr2d = rt_domain(did)%smc(:,:,4) + case ('smcmax1') + farrayPtr2d = rt_domain(did)%smcmax1 + case ('stc1') + farrayPtr2d = rt_domain(did)%stc(:,:,1) + case ('stc2') + farrayPtr2d = rt_domain(did)%stc(:,:,2) + case ('stc3') + farrayPtr2d = rt_domain(did)%stc(:,:,3) + case ('stc4') + farrayPtr2d = rt_domain(did)%stc(:,:,4) + case ('vegtyp') + farrayPtr2d = rt_domain(did)%vegtyp + case ('sfchead') + farrayPtr2d = rt_domain(did)%overland%control%surface_water_head_lsm + case ('infxsrt') + farrayPtr2d = rt_domain(did)%infxsrt + case ('soldrain') + farrayPtr2d = rt_domain(did)%soldrain + case default + call ESMF_LogSetError(ESMF_FAILURE, & + msg=METHOD//": Field hookup missing: "//trim(itemNameList(n)), & + file=FILENAME,rcToReturn=rc) + return ! bail out + end select + endif + enddo + + deallocate(itemNameList) + deallocate(itemTypeList) + + end subroutine state_copy_frhyd + + !----------------------------------------------------------------------------- + +#undef METHOD +#define METHOD "state_check_missing" + subroutine state_check_missing(state, did, rc) + type(ESMF_State), intent(inout) :: state + integer, intent(in) :: did + integer, intent(out) :: rc + ! local variables + integer :: n + integer :: itemCount + character(len=64),allocatable :: itemNameList(:) + type(ESMF_StateItem_Flag), allocatable :: itemTypeList(:) + real(ESMF_KIND_R8), parameter :: chkVal = real(ESMF_MISSING_VALUE) + logical :: missng + integer :: stat + + rc = ESMF_SUCCESS + + call ESMF_StateGet(state,itemCount=itemCount, rc=rc) + if (ESMF_STDERRORCHECK(rc)) return ! bail out + + allocate(itemNameList(itemCount), stat=stat) + if (ESMF_LogFoundAllocError(statusToCheck=stat, & + msg="Allocation of state item name memory failed.", & + line=__LINE__, file=__FILE__)) return ! bail out + allocate(itemTypeList(itemCount), stat=stat) + if (ESMF_LogFoundAllocError(statusToCheck=stat, & + msg="Allocation of state item type memory failed.", & + line=__LINE__, file=__FILE__)) return ! bail out + call ESMF_StateGet(state,itemNameList=itemNameList, & + itemTypeList=itemTypeList,rc=rc) + if (ESMF_STDERRORCHECK(rc)) return + + do n=1, itemCount + if (itemTypeList(n) == ESMF_STATEITEM_FIELD) then + missng = .FALSE. + select case (ItemNameList(n)) + case ('smc') + missng = any(rt_domain(did)%smc.eq.chkVal) + case ('slc') + missng = any(rt_domain(did)%sh2ox.eq.chkVal) + case ('stc') + missng = any(rt_domain(did)%stc.eq.chkVal) + case ('sh2ox1') + missng = any(rt_domain(did)%sh2ox(:,:,1).eq.chkVal) + case ('sh2ox2') + missng = any(rt_domain(did)%sh2ox(:,:,2).eq.chkVal) + case ('sh2ox3') + missng = any(rt_domain(did)%sh2ox(:,:,3).eq.chkVal) + case ('sh2ox4') + missng = any(rt_domain(did)%sh2ox(:,:,4).eq.chkVal) + case ('smc1') + missng = any(rt_domain(did)%smc(:,:,1).eq.chkVal) + case ('smc2') + missng = any(rt_domain(did)%smc(:,:,2).eq.chkVal) + case ('smc3') + missng = any(rt_domain(did)%smc(:,:,3).eq.chkVal) + case ('smc4') + missng = any(rt_domain(did)%smc(:,:,4).eq.chkVal) + case ('smcmax1') + missng = any(rt_domain(did)%smcmax1.eq.chkVal) + case ('stc1') + missng = any(rt_domain(did)%stc(:,:,1).eq.chkVal) + case ('stc2') + missng = any(rt_domain(did)%stc(:,:,2).eq.chkVal) + case ('stc3') + missng = any(rt_domain(did)%stc(:,:,3).eq.chkVal) + case ('stc4') + missng = any(rt_domain(did)%stc(:,:,4).eq.chkVal) + case ('vegtyp') + missng = any(rt_domain(did)%vegtyp.eq.chkVal) + case ('sfchead') + missng = any(rt_domain(did)%overland%control%surface_water_head_lsm & + .eq.chkVal) + case ('infxsrt') + missng = any(rt_domain(did)%infxsrt.eq.chkVal) + case ('soldrain') + missng = any(rt_domain(did)%soldrain.eq.chkVal) + case default + call ESMF_LogSetError(ESMF_FAILURE, & + msg=METHOD//": Field hookup missing: "//trim(itemNameList(n)), & + file=FILENAME,rcToReturn=rc) + return ! bail out + endselect + if (missng) then + call ESMF_LogSetError(ESMF_FAILURE, & + msg=METHOD//": Missing value: "//trim(itemNameList(n)), & + file=FILENAME,rcToReturn=rc) + return ! bail out + endif + endif + enddo + deallocate(itemNameList) + deallocate(itemTypeList) + + end subroutine state_check_missing + + !----------------------------------------------------------------------------- + +#undef METHOD +#define METHOD "state_prescribe_missing" + subroutine state_prescribe_missing(state, did, fieldList, rc) + type(ESMF_State), intent(inout) :: state + integer, intent(in) :: did + type(cap_fld_type), intent(in) :: fieldList(:) + integer, intent(out) :: rc + ! local variables + integer :: n + integer :: itemCount + character(len=64),allocatable :: itemNameList(:) + type(ESMF_StateItem_Flag), allocatable :: itemTypeList(:) + real(ESMF_KIND_R8), parameter :: chkVal = real(ESMF_MISSING_VALUE) + real(ESMF_KIND_R8) :: filVal + integer :: stat + + rc = ESMF_SUCCESS + + call ESMF_StateGet(state,itemCount=itemCount, rc=rc) + if (ESMF_STDERRORCHECK(rc)) return ! bail out + + allocate(itemNameList(itemCount), stat=stat) + if (ESMF_LogFoundAllocError(statusToCheck=stat, & + msg="Allocation of state item name memory failed.", & + line=__LINE__, file=__FILE__)) return ! bail out + allocate(itemTypeList(itemCount), stat=stat) + if (ESMF_LogFoundAllocError(statusToCheck=stat, & + msg="Allocation of state item type memory failed.", & + line=__LINE__, file=__FILE__)) return ! bail out + call ESMF_StateGet(state,itemNameList=itemNameList, & + itemTypeList=itemTypeList,rc=rc) + if (ESMF_STDERRORCHECK(rc)) return + + do n=1, itemCount + if (itemTypeList(n) == ESMF_STATEITEM_FIELD) then + call field_find_statename(fieldList, & + stateName=itemNameList(n), fillValue=filVal, rc=rc) + if (ESMF_STDERRORCHECK(rc)) return + select case (itemNameList(n)) + case ('smc') + where (rt_domain(did)%smc.eq.chkVal) & + rt_domain(did)%smc = filVal + case ('slc') + where (rt_domain(did)%sh2ox.eq.chkVal) & + rt_domain(did)%sh2ox = filVal + case ('stc') + where (rt_domain(did)%stc.eq.chkVal) & + rt_domain(did)%stc = filVal + case ('sh2ox1') + where (rt_domain(did)%sh2ox(:,:,1).eq.chkVal) & + rt_domain(did)%sh2ox(:,:,1) = filVal + case ('sh2ox2') + where (rt_domain(did)%sh2ox(:,:,2).eq.chkVal) & + rt_domain(did)%sh2ox(:,:,2) = filVal + case ('sh2ox3') + where (rt_domain(did)%sh2ox(:,:,3).eq.chkVal) & + rt_domain(did)%sh2ox(:,:,3) = filVal + case ('sh2ox4') + where (rt_domain(did)%sh2ox(:,:,4).eq.chkVal) & + rt_domain(did)%sh2ox(:,:,4) = filVal + case ('smc1') + where (rt_domain(did)%smc(:,:,1).eq.chkVal) & + rt_domain(did)%smc(:,:,1) = filVal + case ('smc2') + where (rt_domain(did)%smc(:,:,2).eq.chkVal) & + rt_domain(did)%smc(:,:,2) = filVal + case ('smc3') + where (rt_domain(did)%smc(:,:,3).eq.chkVal) & + rt_domain(did)%smc(:,:,3) = filVal + case ('smc4') + where (rt_domain(did)%smc(:,:,4).eq.chkVal) & + rt_domain(did)%smc(:,:,4) = filVal + case ('smcmax1') + where (rt_domain(did)%smcmax1.eq.chkVal) & + rt_domain(did)%smcmax1 = filVal + case ('stc1') + where (rt_domain(did)%stc(:,:,1).eq.chkVal) & + rt_domain(did)%stc(:,:,1) = filVal + case ('stc2') + where (rt_domain(did)%stc(:,:,2).eq.chkVal) & + rt_domain(did)%stc(:,:,2) = filVal + case ('stc3') + where (rt_domain(did)%stc(:,:,3).eq.chkVal) & + rt_domain(did)%stc(:,:,3) = filVal + case ('stc4') + where (rt_domain(did)%stc(:,:,4).eq.chkVal) & + rt_domain(did)%stc(:,:,4) = filVal + case ('vegtyp') + where (rt_domain(did)%vegtyp.eq.chkVal) & + rt_domain(did)%vegtyp = filVal + case ('sfchead') + where (rt_domain(did)%overland%control%surface_water_head_lsm & + .eq.chkVal) & + rt_domain(did)%overland%control%surface_water_head_lsm = filVal + case ('infxsrt') + where (rt_domain(did)%infxsrt.eq.chkVal) & + rt_domain(did)%infxsrt = filVal + case ('soldrain') + where (rt_domain(did)%soldrain.eq.chkVal) & + rt_domain(did)%soldrain = filVal + case default + call ESMF_LogSetError(ESMF_FAILURE, & + msg=METHOD//": Field hookup missing: "//trim(itemNameList(n)), & + file=FILENAME,rcToReturn=rc) + return ! bail out + end select + endif + enddo + + deallocate(itemNameList) + deallocate(itemTypeList) + + end subroutine state_prescribe_missing + + !----------------------------------------------------------------------------- + +#undef METHOD +#define METHOD "model_debug" + subroutine model_debug(state, did, memflg, filePrefix, rc) + type(ESMF_State), intent(inout) :: state + integer, intent(in) :: did + type(memory_flag) :: memflg + character(len=*) :: filePrefix + integer, intent(out) :: rc + ! local variables + integer :: n + integer :: itemCount + character(len=64),allocatable :: itemNameList(:) + type(ESMF_StateItem_Flag), allocatable :: itemTypeList(:) + type(ESMF_Field) :: cpyfield, outfield + type(ESMF_Grid) :: grid + integer :: stat + character(len=16) :: cmemflg + + rc = ESMF_SUCCESS + + if (memflg .eq. MEMORY_POINTER) then + call NUOPC_Write(state, & + fileNamePrefix=filePrefix, overwrite=.true., & + status=ESMF_FILESTATUS_REPLACE, timeslice=1, rc=rc) + if (ESMF_STDERRORCHECK(rc)) return ! bail out + elseif(memflg .eq. MEMORY_COPY) then + call ESMF_StateGet(state,itemCount=itemCount, rc=rc) + if (ESMF_STDERRORCHECK(rc)) return ! bail out + + allocate(itemNameList(itemCount), stat=stat) + if (ESMF_LogFoundAllocError(statusToCheck=stat, & + msg="Allocation of state item name memory failed.", & + line=__LINE__, file=__FILE__)) return ! bail out + allocate(itemTypeList(itemCount), stat=stat) + if (ESMF_LogFoundAllocError(statusToCheck=stat, & + msg="Allocation of state item type memory failed.", & + line=__LINE__, file=__FILE__)) return ! bail out + call ESMF_StateGet(state,itemNameList=itemNameList, & + itemTypeList=itemTypeList,rc=rc) + if (ESMF_STDERRORCHECK(rc)) return + + do n=1, itemCount + if (itemTypeList(n) == ESMF_STATEITEM_FIELD) then + call ESMF_StateGet(state, field=cpyfield, & + itemName=itemNameList(n),rc=rc) + if (ESMF_STDERRORCHECK(rc)) return + call ESMF_FieldGet(cpyfield, grid=grid, rc=rc) + if (ESMF_STDERRORCHECK(rc)) return + outfield = field_create(itemNameList(n), grid=grid, did=did, & + memflg=MEMORY_POINTER, rc=rc) + call ESMF_FieldWrite(outfield, variableName=itemNameList(n), & + fileName=trim(filePrefix)//"_"//trim(itemNameList(n))//".nc", & + iofmt=ESMF_IOFMT_NETCDF, rc=rc) + call ESMF_FieldDestroy(outfield, rc=rc) + if (ESMF_STDERRORCHECK(rc)) return + endif + enddo + deallocate(itemNameList) + deallocate(itemTypeList) + else + cmemflg = memflg + call ESMF_LogSetError(ESMF_FAILURE, & + msg=METHOD//": Field memory flag unknown: "//trim(cmemflg), & + file=FILENAME,rcToReturn=rc) + return ! bail out + endif + + end subroutine model_debug + + !----------------------------------------------------------------------------- + + +end module wrfhydro_nuopc_fields diff --git a/trunk/NDHMS/CPL/NUOPC_cpl/WRFHydro_NUOPC_Flags.F90 b/trunk/NDHMS/CPL/NUOPC_cpl/WRFHydro_NUOPC_Flags.F90 new file mode 100644 index 000000000..3a4ffe934 --- /dev/null +++ b/trunk/NDHMS/CPL/NUOPC_cpl/WRFHydro_NUOPC_Flags.F90 @@ -0,0 +1,305 @@ +#define FILENAME "WRFHydro_NUOPC_Flags.F90" +#define MODNAME "wrfhydro_nuopc_flags" +#include "WRFHydro_NUOPC_Macros.h" + +module wrfhydro_nuopc_flags +! !MODULE: wrfhydro_nuopc_flags +! +! !DESCRIPTION: +! This module controls WRFHYDRO configuration flags for NUOPC cap +! +! !REVISION HISTORY: +! 21Sep23 Dan Rosen Initial Specification +! +! !USES: + use ESMF, only: ESMF_UtilStringUpperCase, ESMF_SUCCESS + + implicit none + + private + + type memory_flag + sequence + private + integer :: mem + end type memory_flag + + type(memory_flag), parameter :: & + MEMORY_ERROR = memory_flag(-1), & + MEMORY_POINTER = memory_flag(0), & + MEMORY_COPY = memory_flag(1) + + type fillv_flag + sequence + private + integer :: fillv + end type fillv_flag + + type(fillv_flag), parameter :: & + FILLV_ERROR = fillv_flag(-1), & + FILLV_MISSING = fillv_flag(0), & + FILLV_ZERO = fillv_flag(1), & + FILLV_PRESCRIBE = fillv_flag(2), & + FILLV_MODEL = fillv_flag(3), & + FILLV_DEPENDENCY = fillv_flag(4), & + FILLV_FILE = fillv_flag(5) + + type checkclock_flag + sequence + private + integer :: checkclock + end type checkclock_flag + + type(checkclock_flag), parameter :: & + CHECKCLOCK_ERROR = checkclock_flag(-1), & + CHECKCLOCK_CURRT = checkclock_flag(0), & + CHECKCLOCK_NEXTT = checkclock_flag(1), & + CHECKCLOCK_NONE = checkclock_flag(2) + + type missingval_flag + sequence + private + integer :: missingval + end type missingval_flag + + type(missingval_flag), parameter :: & + MISSINGVAL_ERROR = missingval_flag(-1), & + MISSINGVAL_IGNORE = missingval_flag(0), & + MISSINGVAL_FAIL = missingval_flag(1), & + MISSINGVAL_PRESCRIBE = missingval_flag(2) + + public memory_flag + public fillv_flag + public checkclock_flag + public missingval_flag + public MEMORY_ERROR + public MEMORY_COPY + public MEMORY_POINTER + public FILLV_ERROR + public FILLV_ZERO + public FILLV_MISSING + public FILLV_PRESCRIBE + public FILLV_MODEL + public FILLV_DEPENDENCY + public FILLV_FILE + public CHECKCLOCK_ERROR + public CHECKCLOCK_CURRT + public CHECKCLOCK_NEXTT + public CHECKCLOCK_NONE + public MISSINGVAL_ERROR + public MISSINGVAL_IGNORE + public MISSINGVAL_FAIL + public MISSINGVAL_PRESCRIBE + + public operator(==), assignment(=) + + interface operator (==) + module procedure memory_eq + module procedure fillv_eq + module procedure checkclock_eq + module procedure missingval_eq + end interface + + interface assignment (=) + module procedure memory_toString + module procedure memory_frString + module procedure fillv_toString + module procedure fillv_frString + module procedure checkclock_toString + module procedure checkclock_frString + module procedure missingval_toString + module procedure missingval_frString + end interface + + !----------------------------------------------------------------------------- + contains + !----------------------------------------------------------------------------- + + function memory_eq(val1, val2) + logical memory_eq + type(memory_flag), intent(in) :: val1, val2 + memory_eq = (val1%mem == val2%mem) + end function memory_eq + + !----------------------------------------------------------------------------- + subroutine memory_toString(string, val) + character(len=*), intent(out) :: string + type(memory_flag), intent(in) :: val + if (val == MEMORY_COPY) then + write(string,'(a)') 'MEMORY_COPY' + elseif (val == MEMORY_POINTER) then + write(string,'(a)') 'MEMORY_POINTER' + else + write(string,'(a)') 'MEMORY_ERROR' + endif + end subroutine memory_toString + + !----------------------------------------------------------------------------- + + subroutine memory_frString(val, string) + type(memory_flag), intent(out) :: val + character(len=*), intent(in) :: string + character(len=16) :: ustring + integer :: rc + ustring = ESMF_UtilStringUpperCase(string, rc=rc) + if (rc .ne. ESMF_SUCCESS) then + val = MEMORY_ERROR + elseif (ustring .eq. 'MEMORY_COPY') then + val = MEMORY_COPY + elseif (ustring .eq. 'MEMORY_POINTER') then + val = MEMORY_POINTER + else + val = MEMORY_ERROR + endif + end subroutine memory_frString + + !----------------------------------------------------------------------------- + + function fillv_eq(val1, val2) + logical fillv_eq + type(fillv_flag), intent(in) :: val1, val2 + fillv_eq = (val1%fillv == val2%fillv) + end function fillv_eq + + !----------------------------------------------------------------------------- + + subroutine fillv_toString(string, val) + character(len=*), intent(out) :: string + type(fillv_flag), intent(in) :: val + if (val == FILLV_ZERO) then + write(string,'(a)') 'FILLV_ZERO' + elseif (val == FILLV_MISSING) then + write(string,'(a)') 'FILLV_MISSING' + elseif (val == FILLV_PRESCRIBE) then + write(string,'(a)') 'FILLV_PRESCRIBE' + elseif (val == FILLV_MODEL) then + write(string,'(a)') 'FILLV_MODEL' + elseif (val == FILLV_DEPENDENCY) then + write(string,'(a)') 'FILLV_DEPENDENCY' + elseif (val == FILLV_FILE) then + write(string,'(a)') 'FILLV_FILE' + else + write(string,'(a)') 'FILLV_ERROR' + endif + end subroutine fillv_toString + + !----------------------------------------------------------------------------- + + subroutine fillv_frString(val, string) + type(fillv_flag), intent(out) :: val + character(len=*), intent(in) :: string + character(len=16) :: ustring + integer :: rc + ustring = ESMF_UtilStringUpperCase(string, rc=rc) + if (rc .ne. ESMF_SUCCESS) then + val = FILLV_ERROR + elseif (ustring .eq. 'FILLV_ZERO') then + val = FILLV_ZERO + elseif (ustring .eq. 'FILLV_MISSING') then + val = FILLV_MISSING + elseif (ustring .eq. 'FILLV_PRESCRIBE') then + val = FILLV_PRESCRIBE + elseif (ustring .eq. 'FILLV_MODEL') then + val = FILLV_MODEL + elseif (ustring .eq. 'FILLV_DEPENDENCY') then + val = FILLV_DEPENDENCY + elseif (ustring .eq. 'FILLV_FILE') then + val = FILLV_FILE + else + val = FILLV_ERROR + endif + end subroutine fillv_frString + + !----------------------------------------------------------------------------- + + function checkclock_eq(val1, val2) + logical checkclock_eq + type(checkclock_flag), intent(in) :: val1, val2 + checkclock_eq = (val1%checkclock == val2%checkclock) + end function checkclock_eq + + !----------------------------------------------------------------------------- + + subroutine checkclock_toString(string, val) + character(len=*), intent(out) :: string + type(checkclock_flag), intent(in) :: val + if (val == CHECKCLOCK_CURRT) then + write(string,'(a)') 'CHECKCLOCK_CURRT' + elseif (val == CHECKCLOCK_NEXTT) then + write(string,'(a)') 'CHECKCLOCK_NEXTT' + elseif (val == CHECKCLOCK_NONE) then + write(string,'(a)') 'CHECKCLOCK_NONE' + else + write(string,'(a)') 'CHECKCLOCK_ERROR' + endif + end subroutine checkclock_toString + + !----------------------------------------------------------------------------- + + subroutine checkclock_frString(val, string) + type(checkclock_flag), intent(out) :: val + character(len=*), intent(in) :: string + character(len=16) :: ustring + integer :: rc + ustring = ESMF_UtilStringUpperCase(string, rc=rc) + if (rc .ne. ESMF_SUCCESS) then + val = CHECKCLOCK_ERROR + elseif (ustring .eq. 'CHECKCLOCK_CURRT') then + val = CHECKCLOCK_CURRT + elseif (ustring .eq. 'CHECKCLOCK_NEXTT') then + val = CHECKCLOCK_NEXTT + elseif (ustring .eq. 'CHECKCLOCK_NONE') then + val = CHECKCLOCK_NONE + else + val = CHECKCLOCK_ERROR + endif + end subroutine checkclock_frString + + !----------------------------------------------------------------------------- + + function missingval_eq(val1, val2) + logical missingval_eq + type(missingval_flag), intent(in) :: val1, val2 + missingval_eq = (val1%missingval == val2%missingval) + end function missingval_eq + + !----------------------------------------------------------------------------- + + subroutine missingval_toString(string, val) + character(len=*), intent(out) :: string + type(missingval_flag), intent(in) :: val + if (val == MISSINGVAL_IGNORE) then + write(string,'(a)') 'MISSINGVAL_IGNORE' + elseif (val == MISSINGVAL_FAIL) then + write(string,'(a)') 'MISSINGVAL_FAIL' + elseif (val == MISSINGVAL_PRESCRIBE) then + write(string,'(a)') 'MISSINGVAL_PRESCRIBE' + else + write(string,'(a)') 'MISSINGVAL_ERROR' + endif + end subroutine missingval_toString + + !----------------------------------------------------------------------------- + + subroutine missingval_frString(val, string) + type(missingval_flag), intent(out) :: val + character(len=*), intent(in) :: string + character(len=20) :: ustring + integer :: rc + ustring = ESMF_UtilStringUpperCase(string, rc=rc) + if (rc .ne. ESMF_SUCCESS) then + val = MISSINGVAL_ERROR + elseif (ustring .eq. 'MISSINGVAL_IGNORE') then + val = MISSINGVAL_IGNORE + elseif (ustring .eq. 'MISSINGVAL_FAIL') then + val = MISSINGVAL_FAIL + elseif (ustring .eq. 'MISSINGVAL_PRESCRIBE') then + val = MISSINGVAL_PRESCRIBE + else + val = MISSINGVAL_ERROR + endif + end subroutine missingval_frString + + !----------------------------------------------------------------------------- + +end module diff --git a/trunk/NDHMS/CPL/NUOPC_cpl/WRFHydro_NUOPC_Gluecode.F90 b/trunk/NDHMS/CPL/NUOPC_cpl/WRFHydro_NUOPC_Gluecode.F90 index d9b1a5515..019646bd0 100644 --- a/trunk/NDHMS/CPL/NUOPC_cpl/WRFHydro_NUOPC_Gluecode.F90 +++ b/trunk/NDHMS/CPL/NUOPC_cpl/WRFHydro_NUOPC_Gluecode.F90 @@ -44,16 +44,14 @@ module wrfhydro_nuopc_gluecode cpl_outdate use module_rt_data, only: & rt_domain - use overland_data, only: & - overland_struct - use overland_control, only: & - overland_control_struct use module_lsm_forcing, only: & read_ldasout use config_base, only: & nlst, & init_namelist_rt_field use orchestrator_base + use wrfhydro_nuopc_fields + use wrfhydro_nuopc_flags implicit none @@ -66,173 +64,7 @@ module wrfhydro_nuopc_gluecode public :: WRFHYDRO_get_timestep public :: WRFHYDRO_set_timestep public :: WRFHYDRO_get_hgrid - public :: WRFHYDRO_RunModeGet - public :: WRFHYDRO_Unknown - public :: WRFHYDRO_Offline - public :: WRFHYDRO_Coupled - public :: WRFHYDRO_Hybrid - public :: WRFHYDRO_Field - public :: WRFHYDRO_FieldList - public :: WRFHYDRO_FieldDictionaryAdd - public :: WRFHYDRO_FieldCreate - - INTEGER, PARAMETER :: WRFHYDRO_Unknown = -1 - INTEGER, PARAMETER :: WRFHYDRO_Offline = 0 - INTEGER, PARAMETER :: WRFHYDRO_Coupled = 1 - INTEGER, PARAMETER :: WRFHYDRO_Hybrid = 2 - - type WRFHYDRO_Field - character(len=64) :: stdname = ' ' - character(len=10) :: units = ' ' - character(len=16) :: stateName = ' ' - character(len=64) :: transferOffer = 'will provide' - logical :: adImport = .FALSE. - logical :: realizedImport = .FALSE. - logical :: adExport = .FALSE. - logical :: realizedExport = .FALSE. - logical :: assoc = .FALSE. - real(ESMF_KIND_R8), dimension(:,:,:), pointer :: farrayPtr => null() - endtype WRFHYDRO_Field - - type(WRFHYDRO_Field),dimension(46) :: WRFHYDRO_FieldList = (/ & - WRFHYDRO_Field( & !(01) - stdname='aerodynamic_roughness_length', units='m', & - stateName='z0',adImport=.FALSE.,adExport=.FALSE.), & - WRFHYDRO_Field( & !(02) - stdname='canopy_moisture_storage', units='kg m-2', & - stateName='cmc',adImport=.FALSE.,adExport=.FALSE.), & - WRFHYDRO_Field( & !(03) - stdname='carbon_dioxide', units='mol?', & - stateName='co2',adImport=.FALSE.,adExport=.FALSE.), & - WRFHYDRO_Field( & !(04) - stdname='cosine_zenith_angle', units='?', & - stateName='cosz',adImport=.FALSE.,adExport=.FALSE.), & - WRFHYDRO_Field( & !(05) - stdname='exchange_coefficient_heat', units='?', & - stateName='ch',adImport=.FALSE.,adExport=.FALSE.), & - WRFHYDRO_Field( & !(06) - stdname='exchange_coefficient_heat_height2m', units='?', & - stateName='ch2',adImport=.FALSE.,adExport=.FALSE.), & - WRFHYDRO_Field( & !(07) - stdname='exchange_coefficient_moisture_height2m', units='?', & - stateName='ch2',adImport=.FALSE.,adExport=.FALSE.), & - WRFHYDRO_Field( & !(08) - stdname='ice_mask', units='1', & - stateName='xice',adImport=.FALSE.,adExport=.FALSE.), & - WRFHYDRO_Field( & !(09) - stdname='inst_down_lw_flx', units='W m-2', & - stateName='lwdown',adImport=.FALSE.,adExport=.FALSE.), & - WRFHYDRO_Field( & !(10) - stdname='inst_down_sw_flx', units='W m-2', & - stateName='swdown',adImport=.FALSE.,adExport=.FALSE.), & - WRFHYDRO_Field( & !(11) - stdname='inst_height_lowest', units='m', & - stateName='hgt',adImport=.FALSE.,adExport=.FALSE.), & - WRFHYDRO_Field( & !(12) - stdname='inst_merid_wind_height_lowest', units='m s-1', & - stateName='vwind',adImport=.FALSE.,adExport=.FALSE.), & - WRFHYDRO_Field( & !(13) - stdname='inst_pres_height_lowest', units='Pa', & - stateName='psurf',adImport=.FALSE.,adExport=.FALSE.), & - WRFHYDRO_Field( & !(14) - stdname='inst_pres_height_surface', units='Pa', & - stateName='psurf',adImport=.FALSE.,adExport=.FALSE.), & - WRFHYDRO_Field( & !(15) - stdname='inst_spec_humid_height_lowest', units='kg kg-1', & - stateName='q2',adImport=.FALSE.,adExport=.FALSE.), & - WRFHYDRO_Field( & !(16) - stdname='inst_temp_height_lowest', units='K', & - stateName='sfctmp',adImport=.FALSE.,adExport=.FALSE.), & - WRFHYDRO_Field( & !(17) - stdname='inst_temp_height_surface', units='K', & - stateName='sfctmp',adImport=.FALSE.,adExport=.FALSE.), & - WRFHYDRO_Field( & !(18) - stdname='inst_wind_speed_height_lowest', units='m s-1', & - stateName='sfcspd',adImport=.FALSE.,adExport=.FALSE.), & - WRFHYDRO_Field( & !(19) - stdname='inst_zonal_wind_height_lowest', units='m s-1', & - stateName='uwind',adImport=.FALSE.,adExport=.FALSE.), & - WRFHYDRO_Field( & !(20) - stdname='liquid_fraction_of_soil_moisture_layer_1', units='m3 m-3', & - stateName='sh2ox1',adImport=.TRUE.,adExport=.TRUE.), & - WRFHYDRO_Field( & !(21) - stdname='liquid_fraction_of_soil_moisture_layer_2', units='m3 m-3', & - stateName='sh2ox2',adImport=.TRUE.,adExport=.TRUE.), & - WRFHYDRO_Field( & !(22) - stdname='liquid_fraction_of_soil_moisture_layer_3', units='m3 m-3', & - stateName='sh2ox3',adImport=.TRUE.,adExport=.TRUE.), & - WRFHYDRO_Field( & !(23) - stdname='liquid_fraction_of_soil_moisture_layer_4', units='m3 m-3', & - stateName='sh2ox4',adImport=.TRUE.,adExport=.TRUE.), & - WRFHYDRO_Field( & !(24) - stdname='mean_cprec_rate', units='kg s-1 m-2', & - stateName='prcpconv',adImport=.FALSE.,adExport=.TRUE.), & - WRFHYDRO_Field( & !(25) - stdname='mean_down_lw_flx', units='W m-2', & - stateName='lwdown',adImport=.FALSE.,adExport=.FALSE.), & - WRFHYDRO_Field( & !(26) - stdname='mean_down_sw_flx', units='W m-2', & - stateName='swdown',adImport=.FALSE.,adExport=.FALSE.), & - WRFHYDRO_Field( & !(27) - stdname='mean_fprec_rate', units='kg s-1 m-2', & - stateName='prcp_frozen',adImport=.FALSE.,adExport=.FALSE.), & - WRFHYDRO_Field( & !(28) - stdname='mean_prec_rate', units='kg s-1 m-2', & - stateName='prcprain',adImport=.FALSE.,adExport=.FALSE.), & - WRFHYDRO_Field( & !(29) - stdname='mean_surface_albedo', units='lm lm-1', & - stateName='albedo',adImport=.FALSE.,adExport=.FALSE.), & - WRFHYDRO_Field( & !(30) - stdname='soil_moisture_fraction_layer_1', units='m3 m-3', & - stateName='smc1',adImport=.TRUE.,adExport=.TRUE.), & - WRFHYDRO_Field( & !(31) - stdname='soil_moisture_fraction_layer_2', units='m3 m-3', & - stateName='smc2',adImport=.TRUE.,adExport=.TRUE.), & - WRFHYDRO_Field( & !(32) - stdname='soil_moisture_fraction_layer_3', units='m3 m-3', & - stateName='smc3',adImport=.TRUE.,adExport=.TRUE.), & - WRFHYDRO_Field( & !(33) - stdname='soil_moisture_fraction_layer_4', units='m3 m-3', & - stateName='smc4',adImport=.TRUE.,adExport=.TRUE.), & - WRFHYDRO_Field( & !(34) - stdname='soil_porosity', units='1', & - stateName='smcmax1',adImport=.FALSE.,adExport=.FALSE.), & - WRFHYDRO_Field( & !(35) - stdname='subsurface_runoff_amount', units='kg m-2', & - stateName='soldrain',adImport=.FALSE.,adExport=.FALSE.), & - WRFHYDRO_Field( & !(36) - stdname='surface_runoff_amount', units='kg m-2', & - stateName='infxsrt',adImport=.FALSE.,adExport=.FALSE.), & - WRFHYDRO_Field( & !(37) - stdname='surface_snow_thickness', units='m', & - stateName='snowdepth',adImport=.FALSE.,adExport=.TRUE.), & - WRFHYDRO_Field( & !(38) - stdname='soil_temperature_layer_1', units='K', & - stateName='stc1',adImport=.TRUE.,adExport=.FALSE.), & - WRFHYDRO_Field( & !(39) - stdname='soil_temperature_layer_2', units='K', & - stateName='stc2',adImport=.TRUE.,adExport=.FALSE.), & - WRFHYDRO_Field( & !(40) - stdname='soil_temperature_layer_3', units='K', & - stateName='stc3',adImport=.TRUE.,adExport=.FALSE.), & - WRFHYDRO_Field( & !(41) - stdname='soil_temperature_layer_4', units='K', & - stateName='stc4',adImport=.TRUE.,adExport=.FALSE.), & - WRFHYDRO_Field( & !(42) - stdname='vegetation_type', units='1', & - stateName='vegtyp',adImport=.FALSE.,adExport=.FALSE.), & - WRFHYDRO_Field( & !(43) - stdname='volume_fraction_of_total_water_in_soil', units='m3 m-3', & - stateName='snliqv',adImport=.FALSE.,adExport=.TRUE.), & - WRFHYDRO_Field( & !(44) - stdname='surface_water_depth', units='mm', & - stateName='sfchead',adImport=.FALSE.,adExport=.TRUE.), & - WRFHYDRO_Field( & !(45) - stdname='time_step_infiltration_excess', units='mm', & - stateName='infxsrt',adImport=.TRUE.,adExport=.FALSE.), & - WRFHYDRO_Field( & !(46) - stdname='soil_column_drainage', units='mm', & - stateName='soldrain',adImport=.TRUE.,adExport=.FALSE.)/) + public :: WRFHYDRO_get_restart ! PARAMETERS character(len=ESMF_MAXSTR) :: indir = 'WRFHYDRO_FORCING' @@ -337,7 +169,7 @@ subroutine wrfhydro_nuopc_ini(did,vm,clock,forcingDir,rc) write(nlst(did)%hgrid,'(I1)') did if(nlst(did)%dt .le. 0) then - call ESMF_LogSetError(ESMF_RC_ARG_OUTOFRANGE, & + call ESMF_LogSetError(ESMF_FAILURE, & msg=METHOD//": Timestep less than 1 is not supported!", & file=FILENAME,rcToReturn=rc) return ! bail out @@ -352,7 +184,7 @@ subroutine wrfhydro_nuopc_ini(did,vm,clock,forcingDir,rc) #endif if(nlst(did)%nsoil .gt. 4) then - call ESMF_LogSetError(ESMF_RC_ARG_OUTOFRANGE, & + call ESMF_LogSetError(ESMF_FAILURE, & msg=METHOD//": Maximum soil levels supported is 4.", & file=FILENAME,rcToReturn=rc) return ! bail out @@ -473,7 +305,7 @@ subroutine wrfhydro_nuopc_ini(did,vm,clock,forcingDir,rc) cpl_outdate = startTimeStr(1:19) if(nlst(did)%dt .le. 0) then - call ESMF_LogSetError(ESMF_RC_ARG_OUTOFRANGE, & + call ESMF_LogSetError(ESMF_FAILURE, & msg=METHOD//": Timestep less than 1 is not supported!", & file=FILENAME,rcToReturn=rc) return ! bail out @@ -521,9 +353,10 @@ subroutine wrfhydro_nuopc_ini(did,vm,clock,forcingDir,rc) #undef METHOD #define METHOD "wrfhydro_nuopc_run" - subroutine wrfhydro_nuopc_run(did,mode,clock,importState,exportState,rc) + subroutine wrfhydro_nuopc_run(did,lsm_forcings,clock,importState,& + exportState,rc) integer, intent(in) :: did - integer, intent(in) :: mode + logical, intent(in) :: lsm_forcings type(ESMF_Clock),intent(in) :: clock type(ESMF_State),intent(inout) :: importState type(ESMF_State),intent(inout) :: exportState @@ -539,7 +372,7 @@ subroutine wrfhydro_nuopc_run(did,mode,clock,importState,exportState,rc) rc = ESMF_SUCCESS if(.not. RT_DOMAIN(did)%initialized) then - call ESMF_LogSetError(ESMF_RC_ARG_OUTOFRANGE, & + call ESMF_LogSetError(ESMF_FAILURE, & msg="WRHYDRO: Model has not been initialized!", & file=FILENAME,rcToReturn=rc) return ! bail out @@ -556,7 +389,7 @@ subroutine wrfhydro_nuopc_run(did,mode,clock,importState,exportState,rc) if(ESMF_STDERRORCHECK(rc)) return ! bail out if(nlst(did)%dt .le. 0) then - call ESMF_LogSetError(ESMF_RC_ARG_OUTOFRANGE, & + call ESMF_LogSetError(ESMF_FAILURE, & msg=METHOD//": Timestep less than 1 is not supported!", & file=FILENAME,rcToReturn=rc) return ! bail out @@ -593,7 +426,7 @@ subroutine wrfhydro_nuopc_run(did,mode,clock,importState,exportState,rc) nlst(did)%GWBASESWCRT .eq. 0) then call ESMF_LogWrite(METHOD//": SUBRTSWCRT,OVRTSWCRT,GWBASESWCRT are zero!", & ESMF_LOGMSG_WARNING) - !call ESMF_LogSetError(ESMF_RC_ARG_OUTOFRANGE, & + !call ESMF_LogSetError(ESMF_FAILURE, & ! msg=METHOD//": SUBRTSWCRT,OVRTSWCRT,GWBASESWCRT are zero!", & ! file=FILENAME,rcToReturn=rc) !return ! bail out @@ -603,31 +436,13 @@ subroutine wrfhydro_nuopc_run(did,mode,clock,importState,exportState,rc) call ESMF_LogWrite(METHOD//": Restart initial data from offline file.", & ESMF_LOGMSG_INFO) else - - select case (mode) - case (WRFHYDRO_Offline) - call read_ldasout(olddate=nlst(did)%olddate(1:19), & - hgrid=nlst(did)%hgrid, & - indir=trim(indir), dt=nlst(did)%dt, & - ix=rt_domain(did)%ix,jx=rt_domain(did)%jx, & - infxsrt=rt_domain(did)%infxsrt,soldrain=rt_domain(did)%soldrain) - case (WRFHYDRO_Coupled) - - - case (WRFHYDRO_Hybrid) - call read_ldasout(olddate=nlst(did)%olddate(1:19), & - hgrid=nlst(did)%hgrid, & - indir=trim(indir), dt=nlst(did)%dt, & - ix=rt_domain(did)%ix,jx=rt_domain(did)%jx, & - infxsrt=rt_domain(did)%infxsrt,soldrain=rt_domain(did)%soldrain) - - - case default - call ESMF_LogSetError(ESMF_RC_ARG_BAD, & - msg=METHOD//": Running mode is unknown.", & - file=FILENAME, rcToReturn=rc) - return ! bail out - end select + if (.not. lsm_forcings) then + call read_ldasout(olddate=nlst(did)%olddate(1:19), & + hgrid=nlst(did)%hgrid, & + indir=trim(indir), dt=nlst(did)%dt, & + ix=rt_domain(did)%ix,jx=rt_domain(did)%jx, & + infxsrt=rt_domain(did)%infxsrt,soldrain=rt_domain(did)%soldrain) + endif endif ! Call the WRF-HYDRO run routine @@ -681,128 +496,6 @@ subroutine wrfhydro_nuopc_fin(did,rc) end subroutine - !----------------------------------------------------------------------------- - ! Create field using internal memory - !----------------------------------------------------------------------------- - -#undef METHOD -#define METHOD "WRFHYDRO_FieldCreate" - - function WRFHYDRO_FieldCreate(stateName,grid,did,rc) - ! RETURN VALUE - type(ESMF_Field) :: WRFHYDRO_FieldCreate - ! ARGUMENTS - character(*), intent(in) :: stateName - type(ESMF_Grid), intent(in) :: grid - integer, intent(in) :: did - integer, intent(out) :: rc - ! LOCAL VARIABLES - -#ifdef DEBUG - call ESMF_LogWrite(MODNAME//": entered "//METHOD, ESMF_LOGMSG_INFO) -#endif - - rc = ESMF_SUCCESS - - SELECT CASE (trim(stateName)) - CASE ('sh2ox1') - WRFHYDRO_FieldCreate = ESMF_FieldCreate(name=stateName, grid=grid, & - farray=rt_domain(did)%sh2ox(:,:,1), & - indexflag=ESMF_INDEX_DELOCAL, rc=rc) - if(ESMF_STDERRORCHECK(rc)) return ! bail out - CASE ('sh2ox2') - WRFHYDRO_FieldCreate = ESMF_FieldCreate(name=stateName, grid=grid, & - farray=rt_domain(did)%sh2ox(:,:,2), & - indexflag=ESMF_INDEX_DELOCAL, rc=rc) - if(ESMF_STDERRORCHECK(rc)) return ! bail out - CASE ('sh2ox3') - WRFHYDRO_FieldCreate = ESMF_FieldCreate(name=stateName, grid=grid, & - farray=rt_domain(did)%sh2ox(:,:,3), & - indexflag=ESMF_INDEX_DELOCAL, rc=rc) - if(ESMF_STDERRORCHECK(rc)) return ! bail out - CASE ('sh2ox4') - WRFHYDRO_FieldCreate = ESMF_FieldCreate(name=stateName, grid=grid, & - farray=rt_domain(did)%sh2ox(:,:,4), & - indexflag=ESMF_INDEX_DELOCAL, rc=rc) - if(ESMF_STDERRORCHECK(rc)) return ! bail out - CASE ('smc1') - WRFHYDRO_FieldCreate = ESMF_FieldCreate(name=stateName, grid=grid, & - farray=rt_domain(did)%smc(:,:,1), & - indexflag=ESMF_INDEX_DELOCAL, rc=rc) - if(ESMF_STDERRORCHECK(rc)) return ! bail out - CASE ('smc2') - WRFHYDRO_FieldCreate = ESMF_FieldCreate(name=stateName, grid=grid, & - farray=rt_domain(did)%smc(:,:,2), & - indexflag=ESMF_INDEX_DELOCAL, rc=rc) - if(ESMF_STDERRORCHECK(rc)) return ! bail out - CASE ('smc3') - WRFHYDRO_FieldCreate = ESMF_FieldCreate(name=stateName, grid=grid, & - farray=rt_domain(did)%smc(:,:,3), & - indexflag=ESMF_INDEX_DELOCAL, rc=rc) - if(ESMF_STDERRORCHECK(rc)) return ! bail out - CASE ('smc4') - WRFHYDRO_FieldCreate = ESMF_FieldCreate(name=stateName, grid=grid, & - farray=rt_domain(did)%smc(:,:,4), & - indexflag=ESMF_INDEX_DELOCAL, rc=rc) - if(ESMF_STDERRORCHECK(rc)) return ! bail out - CASE ('smcmax1') - WRFHYDRO_FieldCreate = ESMF_FieldCreate(name=stateName, grid=grid, & - farray=rt_domain(did)%smcmax1, & - indexflag=ESMF_INDEX_DELOCAL, rc=rc) - if(ESMF_STDERRORCHECK(rc)) return ! bail out - CASE ('stc1') - WRFHYDRO_FieldCreate = ESMF_FieldCreate(name=stateName, grid=grid, & - farray=rt_domain(did)%stc(:,:,1), & - indexflag=ESMF_INDEX_DELOCAL, rc=rc) - if(ESMF_STDERRORCHECK(rc)) return ! bail out - CASE ('stc2') - WRFHYDRO_FieldCreate = ESMF_FieldCreate(name=stateName, grid=grid, & - farray=rt_domain(did)%stc(:,:,2), & - indexflag=ESMF_INDEX_DELOCAL, rc=rc) - if(ESMF_STDERRORCHECK(rc)) return ! bail out - CASE ('stc3') - WRFHYDRO_FieldCreate = ESMF_FieldCreate(name=stateName, grid=grid, & - farray=rt_domain(did)%stc(:,:,3), & - indexflag=ESMF_INDEX_DELOCAL, rc=rc) - if(ESMF_STDERRORCHECK(rc)) return ! bail out - CASE ('stc4') - WRFHYDRO_FieldCreate = ESMF_FieldCreate(name=stateName, grid=grid, & - farray=rt_domain(did)%stc(:,:,4), & - indexflag=ESMF_INDEX_DELOCAL, rc=rc) - if(ESMF_STDERRORCHECK(rc)) return ! bail out - CASE ('vegtyp') - WRFHYDRO_FieldCreate = ESMF_FieldCreate(name=stateName, grid=grid, & - farray=rt_domain(did)%vegtyp, & - indexflag=ESMF_INDEX_DELOCAL, rc=rc) - if(ESMF_STDERRORCHECK(rc)) return ! bail out - CASE ('sfchead') - WRFHYDRO_FieldCreate = ESMF_FieldCreate(name=stateName, grid=grid, & - farray=rt_domain(did)%overland%control%surface_water_head_lsm, & - indexflag=ESMF_INDEX_DELOCAL, rc=rc) - if(ESMF_STDERRORCHECK(rc)) return ! bail out - CASE ('infxsrt') - WRFHYDRO_FieldCreate = ESMF_FieldCreate(name=stateName, grid=grid, & - farray=rt_domain(did)%infxsrt, & - indexflag=ESMF_INDEX_DELOCAL, rc=rc) - if (ESMF_STDERRORCHECK(rc)) return - CASE ('soldrain') - WRFHYDRO_FieldCreate = ESMF_FieldCreate(name=stateName, grid=grid, & - farray=rt_domain(did)%soldrain, & - indexflag=ESMF_INDEX_DELOCAL, rc=rc) - if (ESMF_STDERRORCHECK(rc)) return - CASE DEFAULT - call ESMF_LogSetError(ESMF_RC_ARG_OUTOFRANGE, & - msg=METHOD//": Field hookup missing: "//trim(stateName), & - file=FILENAME,rcToReturn=rc) - return ! bail out - END SELECT - -#ifdef DEBUG - call ESMF_LogWrite(MODNAME//": leaving "//METHOD, ESMF_LOGMSG_INFO) -#endif - - end function - #undef METHOD #define METHOD "WRFHYDRO_GridCreate" @@ -1237,57 +930,31 @@ subroutine WRFHYDRO_get_hgrid(did,hgrid,rc) !----------------------------------------------------------------------------- #undef METHOD -#define METHOD "WRFHYDRO_RunModeGet" +#define METHOD "WRFHYDRO_get_restart" - function WRFHYDRO_RunModeGet(importState,rc) - ! RETURN - integer :: WRFHYDRO_RunModeGet + subroutine WRFHYDRO_get_restart(did,restart,rc) ! ARGUMENTS - type(ESMF_State), intent(in) :: importState - integer, intent(out), optional :: rc - ! LOCAL VARIABLES - integer :: fieldIndex - integer :: forcingCount - integer :: connectedCount - type(ESMF_StateItem_Flag) :: itemType + integer, intent(in) :: did + logical, intent(out) :: restart + integer, intent(out) :: rc #ifdef DEBUG call ESMF_LogWrite(MODNAME//": entered "//METHOD, ESMF_LOGMSG_INFO) #endif - if(present(rc)) rc = ESMF_SUCCESS - - WRFHYDRO_RunModeGet = WRFHYDRO_Unknown - forcingCount = 0 - connectedCount = 0 - - do fieldIndex=1, size(WRFHYDRO_FieldList) - if(WRFHYDRO_FieldList(fieldIndex)%adImport) then - forcingCount = forcingCount + 1 - ! Check itemType to see if field exists in state - call ESMF_StateGet(importState, & - itemName=trim(WRFHYDRO_FieldList(fieldIndex)%stateName), & - itemType=itemType, rc=rc) - if (ESMF_STDERRORCHECK(rc)) return - - if (itemType == ESMF_STATEITEM_FIELD) then - if (NUOPC_IsConnected(importState, & - fieldName=trim(WRFHYDRO_FieldList(fieldIndex)%stateName))) then - connectedCount = connectedCount + 1 - endif - endif - endif - enddo + rc = ESMF_SUCCESS - if( connectedCount == 0 ) then - WRFHYDRO_RunModeGet = WRFHYDRO_Offline - elseif ( connectedCount == forcingCount ) then - WRFHYDRO_RunModeGet = WRFHYDRO_Coupled - elseif ( connectedCount < forcingCount ) then - WRFHYDRO_RunModeGet = WRFHYDRO_Hybrid + if (nlst(did)%rst_typ .eq. 0) then + restart = .FALSE. + else + restart = .TRUE. endif - end function +#ifdef DEBUG + call ESMF_LogWrite(MODNAME//": leaving "//METHOD, ESMF_LOGMSG_INFO) +#endif + + end subroutine !----------------------------------------------------------------------------- ! Conversion Utilities @@ -1348,7 +1015,7 @@ subroutine WRFHYDRO_TimeToString(time, timestr, rc) timestr = '' ! clear string if (len(timestr) < 19) then - call ESMF_LogSetError(ESMF_RC_ARG_OUTOFRANGE, & + call ESMF_LogSetError(ESMF_FAILURE, & msg=METHOD//": Time string is too short!", & file=FILENAME,rcToReturn=rc) return ! bail out @@ -1400,46 +1067,6 @@ function WRFHYDRO_TimeIntervalGetReal(timeInterval,rc) end function - !----------------------------------------------------------------------------- - ! Dictionary Utility - !----------------------------------------------------------------------------- - -#undef METHOD -#define METHOD "WRFHYDRO_FieldDictionaryAdd" - - subroutine WRFHYDRO_FieldDictionaryAdd(rc) - ! ARGUMENTS - integer,intent(out) :: rc - ! LOCAL VARIABLES - integer :: fIndex - logical :: isPresent - -#ifdef DEBUG - call ESMF_LogWrite(MODNAME//": entered "//METHOD, ESMF_LOGMSG_INFO) -#endif - - rc = ESMF_SUCCESS - - do fIndex=1,size(WRFHYDRO_FieldList) - isPresent = NUOPC_FieldDictionaryHasEntry( & - trim(WRFHYDRO_FieldList(fIndex)%stdname), & - rc=rc) - if (ESMF_STDERRORCHECK(rc)) return - if (.not.isPresent) then - call NUOPC_FieldDictionaryAddEntry( & - trim(WRFHYDRO_FieldList(fIndex)%stdname), & - trim(WRFHYDRO_FieldList(fIndex)%units), & - rc=rc) - if (ESMF_STDERRORCHECK(rc)) return - endif - enddo - -#ifdef DEBUG - call ESMF_LogWrite(MODNAME//": leaving "//METHOD, ESMF_LOGMSG_INFO) -#endif - - end subroutine - !----------------------------------------------------------------------------- ! Log Utilities !----------------------------------------------------------------------------- diff --git a/trunk/NDHMS/CPL/NUOPC_cpl/WRFHydro_NUOPC_Macros.h b/trunk/NDHMS/CPL/NUOPC_cpl/WRFHydro_NUOPC_Macros.h index bd847f8b6..5ca6f46c8 100644 --- a/trunk/NDHMS/CPL/NUOPC_cpl/WRFHydro_NUOPC_Macros.h +++ b/trunk/NDHMS/CPL/NUOPC_cpl/WRFHydro_NUOPC_Macros.h @@ -32,7 +32,7 @@ ! Define Missing Value !------------------------------------------------------------------------------- -#define MISSINGVALUE 999999 +#define ESMF_MISSING_VALUE 9.99e20_ESMF_KIND_R8 #define UNINITIALIZED -9999 !-------------------------------------------------------------------------------