Merge remote-tracking branch 'origin/release/MAPL-v3' into bug/pchakr…

…ab/vertical-regridding-gfortran

generic3g/ComponentSpecParser/parse_geometry_spec.F90

@@ -32,10 +32,7 @@ module function parse_geometry_spec(mapl_cfg, registry, rc) result(geometry_spec
       type(ESMF_HConfig) :: vertical_grid_cfg
       type(GeomManager), pointer :: geom_mgr
       class(GeomSpec), allocatable :: geom_spec
-      integer :: num_levels
-      character(:), allocatable :: vertical_grid_class, standard_name, units
       class(VerticalGrid), allocatable :: vertical_grid
-      real, allocatable :: levels(:)
 
       has_geometry_section = ESMF_HConfigIsDefined(mapl_cfg,keyString=COMPONENT_GEOMETRY_SECTION, _RC)
       _RETURN_UNLESS(has_geometry_section)
@@ -96,39 +93,66 @@ module function parse_geometry_spec(mapl_cfg, registry, rc) result(geometry_spec
       end if
 
       if (has_vertical_grid) then
-         vertical_grid_class = ESMF_HConfigAsString(vertical_grid_cfg, keyString='class', _RC)
-         select case(vertical_grid_class)
-         case('basic')
-            num_levels = ESMF_HConfigAsI4(vertical_grid_cfg, keyString='num_levels', _RC)
-            vertical_grid = BasicVerticalGrid(num_levels)
-         case('fixed_levels')
-            standard_name = ESMF_HConfigAsString(vertical_grid_cfg, keyString='standard_name', _RC)
-            units = ESMF_HConfigAsString(vertical_grid_cfg, keyString='units', _RC)
-            levels = ESMF_HConfigAsR4Seq(vertical_grid_cfg, keyString='levels' ,_RC)
-            vertical_grid = FixedLevelsVerticalGrid(standard_name, levels, units)
-         case('model')
-            standard_name = ESMF_HConfigAsString(vertical_grid_cfg, keyString='standard_name', _RC)
-            units = ESMF_HConfigAsString(vertical_grid_cfg, keyString='units', _RC)
-            num_levels = ESMF_HConfigAsI4(vertical_grid_cfg, keyString='num_levels', _RC)
-            vertical_grid = ModelVerticalGrid(standard_name=standard_name, units=units, num_levels=num_levels)
-            select type(vertical_grid)
-            type is(ModelVerticalGrid)
-               call vertical_grid%set_registry(registry)
-               if (standard_name == "air_pressure") then
-                  call vertical_grid%add_short_name(edge="PLE", center="PL")
-               else if (standard_name == "height") then
-                  call vertical_grid%add_short_name(edge="ZLE", center="ZL")
-               else
-                  _FAIL("unsupported standard name ["//standard_name//"]")
-               end if
-            end select
-         case default
-            _FAIL('vertical grid class '//vertical_grid_class//' not supported')
-         end select
+         call parse_vertical_grid_(vertical_grid_cfg, registry, vertical_grid, _RC)
       end if
       geometry_spec = GeometrySpec(geom_spec=geom_spec, vertical_grid=vertical_grid)
 
       _RETURN(_SUCCESS)
    end function parse_geometry_spec
 
+   subroutine parse_vertical_grid_(vertical_grid_cfg, registry, vertical_grid, rc)
+      type(ESMF_HConfig), intent(in) :: vertical_grid_cfg
+      type(StateRegistry), target, intent(in) :: registry
+      class(VerticalGrid), allocatable, intent(out) :: vertical_grid
+      integer, optional, intent(out) :: rc
+
+      integer :: num_levels
+      character(:), allocatable :: class, standard_name, units
+      real, allocatable :: levels(:)
+      integer :: status
+
+      class = ESMF_HConfigAsString(vertical_grid_cfg, keyString="class", _RC)
+      select case(class)
+      case("basic")
+         num_levels = ESMF_HConfigAsI4(vertical_grid_cfg, keyString="num_levels", _RC)
+         vertical_grid = BasicVerticalGrid(num_levels)
+      case("fixed_levels")
+         standard_name = ESMF_HConfigAsString(vertical_grid_cfg, keyString="standard_name", _RC)
+         units = ESMF_HConfigAsString(vertical_grid_cfg, keyString="units", _RC)
+         levels = ESMF_HConfigAsR4Seq(vertical_grid_cfg, keyString="levels" ,_RC)
+         vertical_grid = FixedLevelsVerticalGrid(standard_name, levels, units)
+      case("model")
+         call parse_model_vertical_grid_(vertical_grid_cfg, registry, vertical_grid, _RC)
+      case default
+         _FAIL("vertical grid class "//class//" not supported")
+      end select
+
+      _RETURN(_SUCCESS)
+   end subroutine parse_vertical_grid_
+
+   subroutine parse_model_vertical_grid_(vertical_grid_cfg, registry, vertical_grid, rc)
+      type(ESMF_HConfig), intent(in) :: vertical_grid_cfg
+      type(StateRegistry), target, intent(in) :: registry
+      class(VerticalGrid), allocatable, intent(out) :: vertical_grid
+      integer, optional, intent(out) :: rc
+
+      integer :: num_levels
+      character(:), allocatable :: standard_name, units, field_edge, field_center
+      integer :: status
+
+      standard_name = ESMF_HConfigAsString(vertical_grid_cfg, keyString="standard_name", _RC)
+      units = ESMF_HConfigAsString(vertical_grid_cfg, keyString="units", _RC)
+      num_levels = ESMF_HConfigAsI4(vertical_grid_cfg, keyString="num_levels", _RC)
+      vertical_grid = ModelVerticalGrid(standard_name=standard_name, units=units, num_levels=num_levels)
+      field_edge = ESMF_HConfigAsString(vertical_grid_cfg, keyString="field_edge", _RC)
+      field_center = ESMF_HConfigAsString(vertical_grid_cfg, keyString="field_center", _RC)
+      select type(vertical_grid)
+      type is(ModelVerticalGrid)
+         call vertical_grid%set_registry(registry)
+         call vertical_grid%add_short_name(edge=field_edge, center=field_center)
+      end select
+
+      _RETURN(_SUCCESS)
+   end subroutine parse_model_vertical_grid_
+
 end submodule parse_geometry_spec_smod

generic3g/specs/FieldSpec.F90

@@ -27,8 +27,6 @@ module mapl3g_FieldSpec
    use mapl3g_InfoUtilities
    use mapl3g_ExtensionAction
    use mapl3g_VerticalGrid
-   use mapl3g_BasicVerticalGrid
-   use mapl3g_FixedLevelsVerticalGrid
    use mapl3g_VerticalRegridAction
    use mapl3g_VerticalDimSpec
    use mapl3g_AbstractActionSpec
@@ -851,10 +849,10 @@ subroutine adapt_vertical_grid(this, spec, action, rc)
 
       select type (spec)
       type is (FieldSpec)
+         _ASSERT(spec%vertical_grid%can_connect_to(this%vertical_grid), "cannot connect vertical grids")
          ! TODO: DO WE NEED TO RESTRICT SPEC's VERTICAL GRID TO MODEL?
          ! NOTE: we cannot import ModelVerticalGrid (circular dependency)
          _ASSERT(spec%vertical_grid%get_units() == this%vertical_grid%get_units(), 'units must match')
-         ! Field (to be regridded) should have the same typekind as the underlying vertical grid
          ! TODO: Should we add a typekind class variable to VerticalGrid?
          _ASSERT(spec%typekind == this%typekind, 'typekind must match')
          call spec%vertical_grid%get_coordinate_field( &
@@ -872,7 +870,6 @@ subroutine adapt_vertical_grid(this, spec, action, rc)
    end subroutine adapt_vertical_grid
 
    logical function adapter_match_vertical_grid(this, spec, rc) result(match)
-
       class(VerticalGridAdapter), intent(in) :: this
       class(StateItemSpec), intent(in) :: spec
       integer, optional, intent(out) :: rc
@@ -882,52 +879,10 @@ logical function adapter_match_vertical_grid(this, spec, rc) result(match)
       match = .false.
       select type (spec)
       type is (FieldSpec)
-         match = same_vertical_grid(spec%vertical_grid, this%vertical_grid, _RC)
+         match = spec%vertical_grid%is_identical_to(this%vertical_grid)
       end select
 
       _RETURN(_SUCCESS)
-
-   contains
-
-      logical function same_vertical_grid(src_grid, dst_grid, rc)
-         class(VerticalGrid), intent(in) :: src_grid
-         class(VerticalGrid), allocatable, intent(in) :: dst_grid
-         integer, optional, intent(out) :: rc
-
-         same_vertical_grid = .false.
-         if (.not. allocated(dst_grid)) then
-            same_vertical_grid = .true.
-            _RETURN(_SUCCESS) ! mirror grid
-         end if
-
-         same_vertical_grid = src_grid%same_id(dst_grid)
-         if (same_vertical_grid) then
-            _RETURN(_SUCCESS)
-         end if
-
-         select type(src_grid)
-         type is(BasicVerticalGrid)
-            select type(dst_grid)
-            type is(BasicVerticalGrid)
-               same_vertical_grid = (src_grid%get_num_levels() == dst_grid%get_num_levels())
-            class default
-               _FAIL("not implemented yet")
-            end select
-         type is(FixedLevelsVerticalGrid)
-            select type(dst_grid)
-            type is(FixedLevelsVerticalGrid)
-               same_vertical_grid = (src_grid == dst_grid)
-            class default
-               same_vertical_grid = .false.
-            end select
-         class default
-            same_vertical_grid = .false.
-            ! _FAIL("not implemented yet")
-         end select
-
-         _RETURN(_SUCCESS)
-      end function same_vertical_grid
-
    end function adapter_match_vertical_grid
 
    function new_TypekindAdapter(typekind) result(typekind_adapter)

generic3g/tests/Test_ModelVerticalGrid.pf

@@ -39,58 +39,70 @@ module Test_ModelVerticalGrid
 
 contains
 
-   subroutine setup(var_name, vgrid, rc)
+   subroutine setup_(var_name, geom, vgrid, registry, rc)
       character(*), intent(in) :: var_name
-      type(ModelVerticalGrid), intent(out) :: vgrid
-      integer, intent(out) :: rc
+      type(ESMF_Geom), intent(in) :: geom
+      type(ModelVerticalGrid), intent(in) :: vgrid
+      type(StateRegistry), intent(inout) :: registry
+      integer, optional, intent(out) :: rc
 
       type(VerticalDimSpec) :: vertical_dim_spec
-      type(ESMF_Geom) :: geom
-      type(VirtualConnectionPt) :: v_pt
       type(VariableSpec) :: var_spec
       class(StateItemSpec), allocatable :: fld_spec
+      type(VirtualConnectionPt) :: v_pt
       type(StateItemExtension), pointer :: extension
       class(StateItemSpec), pointer :: spec
       integer :: status
 
-      select case (var_name)
-      case ("PLE")
+      select case(var_name)
+      case("PLE")
          vertical_dim_spec = VERTICAL_DIM_EDGE
-      case ("PL")
+      case("PL")
          vertical_dim_spec = VERTICAL_DIM_CENTER
       case default
-         _FAIL("var_name should be one of PLE/PL, not" // trim(var_name))
+         _FAIL("unsupported var name " // var_name)
       end select
 
-      rc = 0
-      ! Inside user "set_geom" phase.
-      geom = make_geom(_RC)
-      vgrid = ModelVerticalGrid(standard_name="air_pressure", units="hPa", num_levels=LM)
-      call vgrid%add_short_name(edge="PLE", center="PL")
-
-      ! inside OuterMeta
-      r = StateRegistry("dyn")
-      call vgrid%set_registry(r) ! MAPL_SetVerticalGrid(...)
-
-      v_pt = VirtualConnectionPt(state_intent="export", short_name=var_name)
       var_spec = VariableSpec(&
            short_name=var_name, &
            state_intent=ESMF_STATEINTENT_EXPORT, &
            standard_name="air_pressure", &
            units="hPa", &
            vertical_dim_spec=vertical_dim_spec, &
            default_value=3.)
-      allocate(fld_spec, source=make_itemSpec(var_spec, r, rc=status))
-      _VERIFY(status)
+      allocate(fld_spec, source=make_itemSpec(var_spec, r, rc=status)); _VERIFY(status)
       call fld_spec%set_geometry(geom=geom, vertical_grid=vgrid, _RC)
 
-      call r%add_primary_spec(v_pt, fld_spec)
-
-      extension => r%get_primary_extension(v_pt, _RC)
+      v_pt = VirtualConnectionPt(state_intent="export", short_name=var_name)
+      call registry%add_primary_spec(v_pt, fld_spec)
+      extension => registry%get_primary_extension(v_pt, _RC)
       spec => extension%get_spec()
       call spec%set_active()
       call spec%create(_RC)
       call spec%allocate(_RC)
+
+      _RETURN(_SUCCESS)
+   end subroutine setup_
+
+   subroutine setup(geom, vgrid, rc)
+      type(ESMF_Geom), intent(out) :: geom
+      type(ModelVerticalGrid), intent(out) :: vgrid
+      integer, intent(out) :: rc
+
+      integer :: status
+
+      ! geom, registry etc.
+      geom = make_geom(_RC)
+      r = StateRegistry("dyn")
+
+      vgrid = ModelVerticalGrid(standard_name="air_pressure", units="hPa", num_levels=LM)
+      call vgrid%add_short_name(edge="PLE", center="PL")
+      call vgrid%set_registry(r) ! MAPL_SetVerticalGrid(...)
+
+      call setup_("PLE", geom, vgrid, r, _RC)
+      call setup_("PL", geom, vgrid, r, _RC)
+
+      _RETURN(_SUCCESS)
    end subroutine setup
 
    function make_geom(rc) result(geom)
@@ -129,9 +141,10 @@ contains
       type(MultiState) :: multi_state
       type(StateItemExtension), pointer :: extension
       type(ESMF_Field) :: ple
+      type(ESMF_Geom) :: geom
       integer :: rc, status
 
-      call setup("PLE", vgrid, _RC)
+      call setup(geom, vgrid, _RC)
 
       ple_pt = VirtualConnectionPt(state_intent="export", short_name="PLE")
       extension => r%get_primary_extension(ple_pt, _RC)
@@ -144,6 +157,7 @@ contains
       allocate(localElementCount(rank))
       call ESMF_FieldGet(ple, localElementCount=localElementCount, _RC)
       @assert_that(localElementCount, is(equal_to([IM,JM,LM+1])))
+
       _UNUSED_DUMMY(this)
    end subroutine test_created_fields_have_num_levels
 
@@ -160,8 +174,7 @@ contains
       integer :: rc, status
       real(ESMF_KIND_R4), pointer :: a(:,:,:)
 
-      call setup("PLE", vgrid, _RC)
-      geom = make_geom(_RC)
+      call setup(geom, vgrid, _RC)
 
       call vgrid%get_coordinate_field( &
            vcoord, coupler, &
@@ -175,6 +188,7 @@ contains
 
       call ESMF_FieldGet(vcoord, fArrayPtr=a, _RC)
       @assert_that(a, every_item(is(equal_to(3.))))
+
       _UNUSED_DUMMY(this)
    end subroutine test_get_coordinate_field_simple
 
@@ -194,8 +208,7 @@ contains
       type(GriddedComponentDriver), pointer :: coupler
       integer :: i, rc
 
-      call setup("PLE", vgrid, _RC)
-      geom = make_geom(_RC)
+      call setup(geom, vgrid, _RC)
 
       call vgrid%get_coordinate_field( &
            vcoord, coupler, &
@@ -220,6 +233,7 @@ contains
       end do
       @assert_that(shape(a), is(equal_to([IM, JM, LM+1])))
       @assert_that(a, every_item(is(equal_to(300.))))
+
       _UNUSED_DUMMY(this)
    end subroutine test_get_coordinate_field_change_units_edge
 
@@ -239,8 +253,7 @@ contains
       type(GriddedComponentDriver), pointer :: coupler
       integer :: i, rc
 
-      call setup("PL", vgrid, _RC)
-      geom = make_geom(_RC)
+      call setup(geom, vgrid, _RC)
 
       call vgrid%get_coordinate_field( &
            vcoord, coupler, &

generic3g/tests/scenarios/vertical_regridding_2/A.yaml

@@ -10,6 +10,8 @@ mapl:
     vertical_grid:
       class: model
       standard_name: air_pressure
+      field_edge: PLE
+      field_center: PL
       units: hPa
       num_levels: 4
 

generic3g/tests/scenarios/vertical_regridding_2/C.yaml

@@ -10,6 +10,8 @@ mapl:
     vertical_grid:
       class: model
       standard_name: height
+      field_edge: ZLE
+      field_center: ZL
       units: m
       num_levels: 4
 

generic3g/tests/scenarios/vertical_regridding_3/DYN.yaml

@@ -10,6 +10,8 @@ mapl:
     vertical_grid:
       class: model
       standard_name: air_pressure
+      field_edge: PLE
+      field_center: PL
       units: hPa
       num_levels: 4