From feef68a02c6fc5e4f94d3f5add5a6459676aeabf Mon Sep 17 00:00:00 2001 From: Tom Clune Date: Tue, 7 Jan 2025 13:45:53 -0500 Subject: [PATCH 1/2] Fixes #3267 - Implementation of VerticalGridAspect. - Adaptor mechanism now deleted. --- generic3g/actions/VerticalRegridAction.F90 | 6 +- generic3g/registry/ExtensionFamily.F90 | 22 +- generic3g/registry/StateItemExtension.F90 | 30 +- generic3g/specs/AspectCollection.F90 | 60 +++- generic3g/specs/BracketSpec.F90 | 16 - generic3g/specs/CMakeLists.txt | 1 + generic3g/specs/FieldSpec.F90 | 323 ++++++--------------- generic3g/specs/GeomAspect.F90 | 12 + generic3g/specs/InvalidSpec.F90 | 16 - generic3g/specs/ServiceSpec.F90 | 14 - generic3g/specs/StateItemAspect.F90 | 5 +- generic3g/specs/StateItemSpec.F90 | 17 -- generic3g/specs/TypekindAspect.F90 | 20 ++ generic3g/specs/UnitsAspect.F90 | 2 + generic3g/specs/VariableSpec.F90 | 4 + generic3g/specs/VerticalGridAspect.F90 | 194 +++++++++++++ generic3g/specs/WildcardSpec.F90 | 15 - generic3g/tests/MockItemSpec.F90 | 196 ++----------- generic3g/tests/Test_BaseItemSpec.pf | 12 +- generic3g/tests/Test_ExtensionFamily.pf | 25 +- generic3g/tests/Test_StateRegistry.pf | 5 +- 21 files changed, 434 insertions(+), 561 deletions(-) create mode 100644 generic3g/specs/VerticalGridAspect.F90 diff --git a/generic3g/actions/VerticalRegridAction.F90 b/generic3g/actions/VerticalRegridAction.F90 index aa0d0778b14a..e36315d87146 100644 --- a/generic3g/actions/VerticalRegridAction.F90 +++ b/generic3g/actions/VerticalRegridAction.F90 @@ -46,7 +46,7 @@ function new_VerticalRegridAction(v_in_coord, v_in_coupler, v_out_coord, v_out_c class(ComponentDriver), pointer, intent(in) :: v_in_coupler type(ESMF_Field), intent(in) :: v_out_coord class(ComponentDriver), pointer, intent(in) :: v_out_coupler - type(VerticalRegridMethod), intent(in) :: method + type(VerticalRegridMethod), optional, intent(in) :: method action%v_in_coord = v_in_coord action%v_out_coord = v_out_coord @@ -54,7 +54,9 @@ function new_VerticalRegridAction(v_in_coord, v_in_coupler, v_out_coord, v_out_c action%v_in_coupler => v_in_coupler action%v_out_coupler => v_out_coupler - action%method = method + if (present(method)) then + action%method = method + end if end function new_VerticalRegridAction subroutine initialize(this, importState, exportState, clock, rc) diff --git a/generic3g/registry/ExtensionFamily.F90 b/generic3g/registry/ExtensionFamily.F90 index b9ff1b01b940..df1638c252d2 100644 --- a/generic3g/registry/ExtensionFamily.F90 +++ b/generic3g/registry/ExtensionFamily.F90 @@ -139,6 +139,7 @@ function find_closest_extension(family, goal_spec, rc) result(closest_extension) do i = 1, aspect_names%size() aspect_name => aspect_names%of(i) dst_aspect => goal_spec%get_aspect(aspect_name, _RC) + _ASSERT(associated(dst_aspect), 'expected aspect '//aspect_name//' is missing') ! Find subset that match current aspect new_subgroup = StateItemExtensionPtrVector() @@ -158,27 +159,6 @@ function find_closest_extension(family, goal_spec, rc) result(closest_extension) end do - ! old - - adapters = archetype%make_adapters(goal_spec, _RC) - - do i = 1, size(adapters) - new_subgroup = StateItemExtensionPtrVector() - do j = 1, subgroup%size() - extension_ptr = subgroup%of(j) - spec => extension_ptr%ptr%get_spec() - associate (adapter => adapters(i)%adapter) - match = adapter%match(spec, _RC) - if (match) then - call new_subgroup%push_back(extension_ptr) - end if - end associate - end do - - if (new_subgroup%size() == 0) exit - subgroup = new_subgroup - end do - extension_ptr = subgroup%front() closest_extension => extension_ptr%ptr diff --git a/generic3g/registry/StateItemExtension.F90 b/generic3g/registry/StateItemExtension.F90 index e5e55b83fd0e..b3819b44a886 100644 --- a/generic3g/registry/StateItemExtension.F90 +++ b/generic3g/registry/StateItemExtension.F90 @@ -123,7 +123,7 @@ recursive function make_extension(this, goal, rc) result(extension) integer :: status integer :: i - class(StateItemSpec), allocatable :: new_spec + class(StateItemSpec), target, allocatable :: new_spec class(ExtensionAction), allocatable :: action class(ComponentDriver), pointer :: producer class(ComponentDriver), pointer :: source @@ -144,7 +144,11 @@ recursive function make_extension(this, goal, rc) result(extension) do i = 1, aspect_names%size() aspect_name => aspect_names%of(i) src_aspect => new_spec%get_aspect(aspect_name, _RC) + _ASSERT(associated(src_aspect), 'src aspect not found') + dst_aspect => goal%get_aspect(aspect_name, _RC) + _ASSERT(associated(dst_aspect), 'dst aspect not found') + _ASSERT(src_aspect%can_connect_to(dst_aspect), 'cannot connect aspect ' // aspect_name) if (src_aspect%needs_extension_for(dst_aspect)) then @@ -167,30 +171,6 @@ recursive function make_extension(this, goal, rc) result(extension) _RETURN(_SUCCESS) end if - ! The logic below should be removed once Aspects have fully - ! replaced Adapters. - adapters = this%spec%make_adapters(goal, _RC) - do i = 1, size(adapters) - match = adapters(i)%adapter%match(new_spec, _RC) - if (match) cycle - call adapters(i)%adapter%adapt(new_spec, action, _RC) - exit - end do - - if (.not. allocated(action)) then - extension = StateItemExtension(this%spec) - _RETURN(_SUCCESS) - end if - - call new_spec%create(_RC) - call new_spec%set_active() - - source => this%get_producer() - coupler_gridcomp = make_coupler(action, source, _RC) - producer => this%add_consumer(GriddedComponentDriver(coupler_gridcomp, fake_clock, MultiState())) - extension = StateItemExtension(new_spec) - call extension%set_producer(producer) - _RETURN(_SUCCESS) end function make_extension diff --git a/generic3g/specs/AspectCollection.F90 b/generic3g/specs/AspectCollection.F90 index 6a6d3a8fe654..8c9aa73ccd98 100644 --- a/generic3g/specs/AspectCollection.F90 +++ b/generic3g/specs/AspectCollection.F90 @@ -2,15 +2,14 @@ module mapl3g_AspectCollection use mapl3g_StateItemAspect - use mapl3g_GeomAspect + use mapl3g_VerticalGridAspect use mapl3g_UnitsAspect use mapl3g_TypekindAspect - use mapl3g_UngriddedDimsAspect - use mapl_KeywordEnforcer use mapl_ErrorHandling + use esmf implicit none private @@ -19,6 +18,7 @@ module mapl3g_AspectCollection type AspectCollection private type(GeomAspect), allocatable :: geom_aspect + type(VerticalGridAspect), allocatable :: vertical_grid_aspect type(UnitsAspect), allocatable :: units_aspect type(TypekindAspect), allocatable :: typekind_aspect type(UngriddedDimsAspect), allocatable :: ungridded_dims_aspect @@ -30,6 +30,9 @@ module mapl3g_AspectCollection procedure :: get_geom_aspect procedure :: set_geom_aspect + procedure :: get_vertical_grid_aspect + procedure :: set_vertical_grid_aspect + procedure :: get_units_aspect procedure :: set_units_aspect @@ -71,6 +74,8 @@ function get_aspect(this, name, rc) result(aspect) select case (name) case ('GEOM') aspect => this%get_geom_aspect() + case ('VERTICAL') + aspect => this%get_vertical_grid_aspect() case ('UNITS') aspect => this%get_units_aspect() case ('TYPEKIND') @@ -89,8 +94,16 @@ logical function has_aspect(this, name) character(*), intent(in) :: name select case (name) - case ('GEOM', 'UNITS', 'UNGRIDDED_DIMS') - has_aspect = .true. + case ('GEOM') + has_aspect = allocated(this%geom_aspect) + case ('VERTICAL') + has_aspect = allocated(this%vertical_grid_aspect) + case ('UNITS') + has_aspect = allocated(this%units_aspect) + case ('TYPEKIND') + has_aspect = allocated(this%typekind_aspect) + case ('UNGRIDDED_DIMS') + has_aspect = allocated(this%ungridded_dims_aspect) case default has_aspect = .false. end select @@ -98,19 +111,39 @@ logical function has_aspect(this, name) end function has_aspect subroutine set_aspect(this, aspect, rc) - class(AspectCollection) :: this + class(AspectCollection), target :: this class(StateItemAspect), target, intent(in) :: aspect integer, optional, intent(out) :: rc + type(ESMF_Geom) :: geom + type(ESMF_Typekind_Flag) :: typekind integer :: status select type (aspect) type is (GeomAspect) this%geom_aspect = aspect + ! aux vertical + if (allocated( this%vertical_grid_aspect)) then + geom = aspect%get_geom() + call this%vertical_grid_aspect%set_geom(geom) + end if + type is (VerticalGridAspect) + if (allocated(this%vertical_grid_aspect)) then + if (allocated(this%vertical_grid_aspect%vertical_grid)) then + end if + end if + this%vertical_grid_aspect = aspect + if (allocated(this%vertical_grid_aspect%vertical_grid)) then + end if type is (UnitsAspect) this%units_aspect = aspect type is (TypekindAspect) this%typekind_aspect = aspect + ! aux vertical + typekind = aspect%get_typekind() + if (allocated( this%vertical_grid_aspect)) then + call this%vertical_grid_aspect%set_typekind(typekind) + end if type is (UngriddedDimsAspect) this%ungridded_dims_aspect = aspect class default @@ -135,6 +168,21 @@ subroutine set_geom_aspect(this, geom_aspect) this%geom_aspect = geom_aspect end subroutine set_geom_aspect + function get_vertical_grid_aspect(this) result(vertical_grid_aspect) + type(VerticalGridAspect), pointer :: vertical_grid_aspect + class(AspectCollection), target, intent(in) :: this + vertical_grid_aspect => null() + if (allocated(this%vertical_grid_aspect)) then + vertical_grid_aspect => this%vertical_grid_aspect + end if + end function get_vertical_grid_aspect + + subroutine set_vertical_grid_aspect(this, vertical_grid_aspect) + class(AspectCollection), intent(inout) :: this + type(VerticalGridAspect), intent(in) :: vertical_grid_aspect + this%vertical_grid_aspect = vertical_grid_aspect + end subroutine set_vertical_grid_aspect + function get_units_aspect(this) result(units_aspect) type(UnitsAspect), pointer :: units_aspect class(AspectCollection), target, intent(in) :: this diff --git a/generic3g/specs/BracketSpec.F90 b/generic3g/specs/BracketSpec.F90 index fccdd1836958..c0f42cb4e3dc 100644 --- a/generic3g/specs/BracketSpec.F90 +++ b/generic3g/specs/BracketSpec.F90 @@ -45,7 +45,6 @@ module mapl3g_BracketSpec procedure :: add_to_state procedure :: add_to_bundle - procedure :: make_adapters procedure :: set_geometry procedure :: write_formatted end type BracketSpec @@ -281,19 +280,4 @@ subroutine write_formatted(this, unit, iotype, v_list, iostat, iomsg) write(unit, "(a)", iostat=iostat, iomsg=iomsg) "BracketSpec(write not implemented yet)" end subroutine write_formatted - function make_adapters(this, goal_spec, rc) result(adapters) - type(StateItemAdapterWrapper), allocatable :: adapters(:) - class(BracketSpec), intent(in) :: this - class(StateItemSpec), intent(in) :: goal_spec - integer, optional, intent(out) :: rc - - - allocate(adapters(0)) - _FAIL('unimplemented') - - _RETURN(_SUCCESS) - _UNUSED_DUMMY(this) - _UNUSED_DUMMY(goal_spec) - end function make_adapters - end module mapl3g_BracketSpec diff --git a/generic3g/specs/CMakeLists.txt b/generic3g/specs/CMakeLists.txt index 68f57d020199..f90ce3473520 100644 --- a/generic3g/specs/CMakeLists.txt +++ b/generic3g/specs/CMakeLists.txt @@ -3,6 +3,7 @@ target_sources(MAPL.generic3g PRIVATE AspectCollection.F90 GeomAspect.F90 TypekindAspect.F90 + VerticalGridAspect.F90 UngriddedDimsAspect.F90 UnitsAspect.F90 diff --git a/generic3g/specs/FieldSpec.F90 b/generic3g/specs/FieldSpec.F90 index ae3405ce1f78..69bf5ead280d 100644 --- a/generic3g/specs/FieldSpec.F90 +++ b/generic3g/specs/FieldSpec.F90 @@ -14,6 +14,7 @@ module mapl3g_FieldSpec use mapl3g_StateItemAspect use mapl3g_AspectCollection use mapl3g_GeomAspect + use mapl3g_VerticalGridAspect use mapl3g_UnitsAspect use mapl3g_TypekindAspect use mapl3g_UngriddedDimsAspect @@ -81,9 +82,8 @@ module mapl3g_FieldSpec type, extends(StateItemSpec) :: FieldSpec class(VerticalGrid), allocatable :: vertical_grid - type(VerticalDimSpec) :: vertical_dim_spec = VERTICAL_DIM_UNKNOWN type(StringVector) :: attributes - type(EsmfRegridderParam) :: regrid_param +!# type(EsmfRegridderParam) :: regrid_param ! Metadata character(:), allocatable :: standard_name @@ -113,7 +113,6 @@ module mapl3g_FieldSpec procedure :: add_to_state procedure :: add_to_bundle - procedure :: make_adapters procedure :: get_aspect_priorities procedure :: set_geometry @@ -138,22 +137,6 @@ module mapl3g_FieldSpec end interface can_match - type, extends(StateItemAdapter) :: VerticalGridAdapter - private - class(VerticalGrid), allocatable :: vertical_grid - type(ESMF_Geom), allocatable :: geom - type(ESMF_TypeKind_Flag) :: typekind - character(:), allocatable :: units - type(VerticalDimSpec), allocatable :: vertical_dim_spec - type(VerticalRegridMethod), allocatable :: regrid_method - contains - procedure :: adapt_one => adapt_vertical_grid - procedure :: match_one => adapter_match_vertical_grid - end type VerticalGridAdapter - - interface VerticalGridAdapter - procedure :: new_VerticalGridAdapter - end interface VerticalGridAdapter contains @@ -185,13 +168,16 @@ function new_FieldSpec_geom(unusable, geom, vertical_grid, vertical_dim_spec, ty aspects => field_spec%get_aspects() + call aspects%set_vertical_grid_aspect(VerticalGridAspect( & + vertical_grid=vertical_grid, & + vertical_dim_spec=vertical_dim_spec, & + geom=geom)) call aspects%set_geom_aspect(GeomAspect(geom, regrid_param, horizontal_dims_spec)) call aspects%set_units_aspect(UnitsAspect(units)) call aspects%set_ungridded_dims_aspect(UngriddedDimsAspect(ungridded_dims)) call aspects%set_typekind_aspect(TypekindAspect(typekind)) if (present(vertical_grid)) field_spec%vertical_grid = vertical_grid - field_spec%vertical_dim_spec = vertical_dim_spec if (present(standard_name)) field_spec%standard_name = standard_name if (present(long_name)) field_spec%long_name = long_name @@ -204,6 +190,7 @@ function new_FieldSpec_geom(unusable, geom, vertical_grid, vertical_dim_spec, ty field_spec%accumulation_type = NO_ACCUMULATION if (present(accumulation_type)) field_spec%accumulation_type = trim(accumulation_type) if (present(run_dt)) field_spec%run_dt = run_dt + end function new_FieldSpec_geom function new_FieldSpec_varspec(variable_spec) result(field_spec) @@ -213,9 +200,10 @@ function new_FieldSpec_varspec(variable_spec) result(field_spec) type(ESMF_RegridMethod_Flag), allocatable :: regrid_method field_spec%accumulation_type = NO_ACCUMULATION - _SET_FIELD(field_spec, variable_spec, vertical_dim_spec) _SET_FIELD(field_spec, variable_spec, attributes) _SET_ALLOCATED_FIELD(field_spec, variable_spec, standard_name) + call field_spec%set_aspect(variable_spec%aspects%get_aspect('GEOM')) + call field_spec%set_aspect(variable_spec%aspects%get_aspect('VERTICAL')) call field_spec%set_aspect(variable_spec%aspects%get_aspect('UNGRIDDED_DIMS')) call field_spec%set_aspect(variable_spec%aspects%get_aspect('TYPEKIND')) call field_spec%set_aspect(variable_spec%aspects%get_aspect('UNITS')) @@ -237,30 +225,47 @@ subroutine set_geometry(this, geom, vertical_grid, run_dt, rc) integer :: status type(ESMF_RegridMethod_Flag), allocatable :: regrid_method - call target_set_geom(this, geom) - if (present(vertical_grid)) this%vertical_grid = vertical_grid + call target_set_geom(this, geom, vertical_grid) if (present(run_dt)) this%run_dt = run_dt _RETURN(_SUCCESS) contains ! Helper needed to add target attribute to "this" - subroutine target_set_geom(this, geom) + subroutine target_set_geom(this, geom, vertical_grid) class(FieldSpec), target, intent(inout) :: this type(ESMF_Geom), optional, intent(in) :: geom + class(VerticalGrid), optional, intent(in) :: vertical_grid type(AspectCollection), pointer :: aspects type(GeomAspect), pointer :: geom_aspect + type(VerticalGridAspect), pointer :: vertical_grid_aspect aspects => this%get_aspects() - geom_aspect => aspects%get_geom_aspect() - if (associated(geom_aspect)) then - call geom_aspect%set_geom(geom) - else - call aspects%set_geom_aspect(GeomAspect(geom)) + if (present(geom)) then + geom_aspect => aspects%get_geom_aspect() + if (associated(geom_aspect)) then + call geom_aspect%set_geom(geom) + else + call aspects%set_aspect(GeomAspect(geom)) + end if end if - + + if (present(vertical_grid)) then + vertical_grid_aspect => aspects%get_vertical_grid_aspect() + this%vertical_grid = vertical_grid + if (associated(vertical_grid_aspect)) then + call vertical_grid_aspect%set_vertical_grid(vertical_grid) + if (present(geom)) then + call vertical_grid_aspect%set_geom(geom) + end if + else + call aspects%set_aspect(VerticalGridAspect(vertical_grid=vertical_grid, geom=geom)) + end if + + end if + end subroutine target_set_geom end subroutine set_geometry @@ -299,7 +304,7 @@ subroutine allocate(this, rc) integer, allocatable :: num_levels_grid integer, allocatable :: num_levels type(VerticalStaggerLoc) :: vert_staggerloc - class(StateItemAspect), pointer :: geom_aspect, units_aspect, typekind_aspect, ungridded_dims_aspect + class(StateItemAspect), pointer :: aspect type(UngriddedDims), pointer :: ungridded_dims type(ESMF_TypeKind_Flag) :: typekind character(:), allocatable :: units @@ -309,55 +314,61 @@ subroutine allocate(this, rc) call ESMF_FieldGet(this%payload, status=fstatus, _RC) _RETURN_IF(fstatus == ESMF_FIELDSTATUS_COMPLETE) - geom_aspect => this%get_aspect('GEOM', _RC) - select type (geom_aspect) + aspect => this%get_aspect('GEOM', _RC) + select type (aspect) class is (GeomAspect) - call ESMF_FieldEmptySet(this%payload, geom_aspect%geom, _RC) + call ESMF_FieldEmptySet(this%payload, aspect%geom, _RC) class default _FAIL('no geom aspect') end select - if (allocated(this%vertical_grid)) then - num_levels_grid = this%vertical_grid%get_num_levels() - end if + aspect => this%get_aspect('VERTICAL', _RC) - if (this%vertical_dim_spec == VERTICAL_DIM_NONE) then - vert_staggerloc = VERTICAL_STAGGER_NONE - else if (this%vertical_dim_spec == VERTICAL_DIM_EDGE) then - vert_staggerloc = VERTICAL_STAGGER_EDGE - num_levels = num_levels_grid + 1 - else if (this%vertical_dim_spec == VERTICAL_DIM_CENTER) then - vert_staggerloc = VERTICAL_STAGGER_CENTER - num_levels = num_levels_grid - else - _FAIL('unknown stagger') - end if + select type (aspect) + class is (VerticalGridAspect) + if (allocated(this%vertical_grid)) then + num_levels_grid = aspect%vertical_grid%get_num_levels() + end if + if (aspect%vertical_dim_spec == VERTICAL_DIM_NONE) then + vert_staggerloc = VERTICAL_STAGGER_NONE + else if (aspect%vertical_dim_spec == VERTICAL_DIM_EDGE) then + vert_staggerloc = VERTICAL_STAGGER_EDGE + num_levels = num_levels_grid + 1 + else if (aspect%vertical_dim_spec == VERTICAL_DIM_CENTER) then + vert_staggerloc = VERTICAL_STAGGER_CENTER + num_levels = num_levels_grid + else + _FAIL('unknown stagger') + end if + class default + _FAIL('no vertical grid aspect') + end select - ungridded_dims_aspect => this%get_aspect('UNGRIDDED_DIMS', _RC) + aspect => this%get_aspect('UNGRIDDED_DIMS', _RC) ungridded_dims => null() - if (associated(ungridded_dims_aspect)) then - select type (ungridded_dims_aspect) + if (associated(aspect)) then + select type (aspect) class is (UngriddedDimsAspect) - if (allocated(ungridded_dims_aspect%ungridded_dims)) then - ungridded_dims => ungridded_dims_aspect%ungridded_dims + if (allocated(aspect%ungridded_dims)) then + ungridded_dims => aspect%ungridded_dims end if class default _FAIL('no ungrgeom aspect') end select end if - units_aspect => this%get_aspect('UNITS', _RC) - select type(units_aspect) + aspect => this%get_aspect('UNITS', _RC) + select type(aspect) class is (UnitsAspect) - units = units_aspect%units + units = aspect%units class default _FAIL('no units aspect') end select - typekind_aspect => this%get_aspect('TYPEKIND', _RC) - select type(typekind_aspect) + aspect => this%get_aspect('TYPEKIND', _RC) + select type(aspect) class is (TypekindAspect) - typekind = typekind_aspect%typekind + typekind = aspect%typekind class default _FAIL('no units aspect') end select @@ -401,7 +412,7 @@ subroutine write_formatted(this, unit, iotype, v_list, iostat, iomsg) !# if (allocated(this%units)) then !# write(unit, "(a, a, a)", iostat=iostat, iomsg=iomsg) new_line("a"), "units:", this%units !# end if - write(unit, "(a, dt'g0')", iostat=iostat, iomsg=iomsg) new_line("a"), this%vertical_dim_spec +!# write(unit, "(a, dt'g0')", iostat=iostat, iomsg=iomsg) new_line("a"), this%vertical_dim_spec if (allocated(this%vertical_grid)) then write(unit, "(a, dt'g0', a)", iostat=iostat, iomsg=iomsg) new_line("a"), this%vertical_grid end if @@ -439,7 +450,7 @@ subroutine connect_to(this, src_spec, actual_pt, rc) integer, optional, intent(out) :: rc integer :: status - class(StateItemAspect), pointer :: geom_aspect, units_aspect, typekind_aspect + class(StateItemAspect), pointer :: aspect interface mirror procedure :: mirror_geom @@ -462,15 +473,17 @@ subroutine connect_to(this, src_spec, actual_pt, rc) call this%destroy(_RC) this%payload = src_spec%payload - geom_aspect => src_spec%get_aspect('GEOM', _RC) - call this%set_aspect(geom_aspect, _RC) - units_aspect => src_spec%get_aspect('UNITS', _RC) - call this%set_aspect(units_aspect, _RC) - typekind_aspect => src_spec%get_aspect('TYPEKIND', _RC) - call this%set_aspect(typekind_aspect, _RC) - - call mirror(dst=this%vertical_grid, src=src_spec%vertical_grid) - call mirror(dst=this%vertical_dim_spec, src=src_spec%vertical_dim_spec) + aspect => src_spec%get_aspect('GEOM', _RC) + call this%set_aspect(aspect, _RC) + aspect => src_spec%get_aspect('VERTICAL', _RC) + call this%set_aspect(aspect, _RC) + aspect => src_spec%get_aspect('UNITS', _RC) + call this%set_aspect(aspect, _RC) + aspect => src_spec%get_aspect('TYPEKIND', _RC) + call this%set_aspect(aspect, _RC) + +!# call mirror(dst=this%vertical_grid, src=src_spec%vertical_grid) +!# call mirror(dst=this%vertical_dim_spec, src=src_spec%vertical_dim_spec) call mirror(dst=this%default_value, src=src_spec%default_value) class default _FAIL('Cannot connect field spec to non field spec.') @@ -589,8 +602,8 @@ logical function can_connect_to(this, src_spec, rc) end associate can_connect_to = all ([ & - can_match(this%vertical_grid, src_spec%vertical_grid), & - match(this%vertical_dim_spec, src_spec%vertical_dim_spec), & +!# can_match(this%vertical_grid, src_spec%vertical_grid), & +!# match(this%vertical_dim_spec, src_spec%vertical_dim_spec), & includes(this%attributes, src_spec%attributes) & ]) class default @@ -785,177 +798,13 @@ function get_payload(this) result(payload) end function get_payload - function new_VerticalGridAdapter(vertical_grid, geom, typekind, units, vertical_dim_spec, regrid_method) result(vertical_grid_adapter) - type(VerticalGridAdapter) :: vertical_grid_adapter - class(VerticalGrid), optional, intent(in) :: vertical_grid - type(ESMF_Geom), optional, intent(in) :: geom - type(ESMF_Typekind_Flag), intent(in) :: typekind - character(*), optional, intent(in) :: units - type(VerticalDimSpec), intent(in) :: vertical_dim_spec - type(VerticalRegridMethod), optional, intent(in) :: regrid_method - - if (present(vertical_grid)) vertical_grid_adapter%vertical_grid = vertical_grid - if (present(geom)) vertical_grid_adapter%geom = geom - vertical_grid_adapter%typekind = typekind - if (present(units)) vertical_grid_adapter%units = units - vertical_grid_adapter%vertical_dim_spec = vertical_dim_spec - if (present(regrid_method)) vertical_grid_adapter%regrid_method = regrid_method - end function new_VerticalGridAdapter - - subroutine adapt_vertical_grid(this, spec, action, rc) - class(VerticalGridAdapter), intent(in) :: this - class(StateItemSpec), intent(inout) :: spec - class(ExtensionAction), allocatable, intent(out) :: action - integer, optional, intent(out) :: rc - - class(ComponentDriver), pointer :: v_in_coupler - class(ComponentDriver), pointer :: v_out_coupler - type(ESMF_Field) :: v_in_coord, v_out_coord - type(ESMF_TypeKind_Flag) :: typekind_in, typekind_out - type(ESMF_Geom) :: geom - type(ESMF_TypeKind_Flag) :: typekind - class(StateItemAspect), pointer :: geom_aspect - class(StateItemAspect), pointer :: units_aspect - class(StateItemAspect), pointer :: typekind_aspect - character(:), allocatable :: units - integer :: status - - 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') - ! TODO: Should we add a typekind class variable to VerticalGrid? - - geom_aspect => spec%get_aspect('GEOM', _RC) - select type (geom_aspect) - class is (GeomAspect) - geom = geom_aspect%geom - class default - _FAIL('no geom aspect') - end select - - units_aspect => spec%get_aspect('UNITS', _RC) - select type (units_aspect) - class is (UnitsAspect) - units = units_aspect%units - class default - _FAIL('no units aspect') - end select - - typekind_aspect => spec%get_aspect('TYPEKIND', _RC) - select type (typekind_aspect) - class is (TypekindAspect) - typekind = typekind_aspect%typekind - class default - _FAIL('no typekind aspect') - end select - - call spec%vertical_grid%get_coordinate_field( & - v_in_coord, v_in_coupler, & ! output - 'ignore', geom, typekind, this%vertical_grid%get_units(), spec%vertical_dim_spec, _RC) - call this%vertical_grid%get_coordinate_field( & - v_out_coord, v_out_coupler, & ! output - 'ignore', geom, typekind, units, this%vertical_dim_spec, _RC) - action = VerticalRegridAction(v_in_coord, v_out_coupler, v_out_coord, v_out_coupler, this%regrid_method) - if (allocated(spec%vertical_grid)) deallocate(spec%vertical_grid) - allocate(spec%vertical_grid, source=this%vertical_grid) - spec%vertical_dim_spec = this%vertical_dim_spec - end select - - _RETURN(_SUCCESS) - 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 - - integer :: status - - match = .false. - select type (spec) - type is (FieldSpec) - match = spec%vertical_grid%is_identical_to(this%vertical_grid) - end select - - _RETURN(_SUCCESS) - end function adapter_match_vertical_grid - - - recursive function make_adapters(this, goal_spec, rc) result(adapters) - type(StateItemAdapterWrapper), allocatable :: adapters(:) - class(FieldSpec), intent(in) :: this - class(StateItemSpec), intent(in) :: goal_spec - integer, optional, intent(out) :: rc - - type(VerticalGridAdapter) :: vertical_grid_adapter - class(StateItemAspect), pointer :: geom_aspect, units_aspect, typekind_aspect - type(ESMF_Geom) :: geom - type(ESMF_Typekind_Flag) :: typekind - character(:), allocatable :: units - integer :: status - - select type (goal_spec) - type is (FieldSpec) - ! TODO - convert remaining adapters to aspects - allocate(adapters(1)) - - geom_aspect => goal_spec%get_aspect('GEOM', _RC) - select type (geom_aspect) - class is (GeomAspect) - if (allocated(geom_aspect%geom)) then - geom = geom_aspect%geom - end if - class default - _FAIL('no geom aspect') - end select - - units_aspect => goal_spec%get_aspect('UNITS', _RC) - _ASSERT(associated(units_aspect), 'no units aspect') - select type (units_aspect) - class is (UnitsAspect) - if (allocated(units_aspect%units)) then - units = units_aspect%units - end if - class default - _FAIL('no units aspect') - end select - - typekind_aspect => goal_spec%get_aspect('TYPEKIND', _RC) - _ASSERT(associated(typekind_aspect), 'no typekind aspect') - select type (typekind_aspect) - class is (TypekindAspect) - typekind = typekind_aspect%typekind - class default - _FAIL('no typekind aspect') - end select - - vertical_grid_adapter = VerticalGridAdapter( & - goal_spec%vertical_grid, & - geom, & - typekind, & - units, & - goal_spec%vertical_dim_spec, & - VERTICAL_REGRID_LINEAR) - allocate(adapters(1)%adapter, source=vertical_grid_adapter) - type is (WildCardSpec) - adapters = goal_spec%make_adapters(goal_spec, _RC) - class default - allocate(adapters(0)) - _FAIL('unsupported subclass of StateItemSpec') - end select - - _RETURN(_SUCCESS) - end function make_adapters function get_aspect_priorities(src_spec, dst_spec) result(order) character(:), allocatable :: order class(FieldSpec), intent(in) :: src_spec class(StateItemSpec), intent(in) :: dst_spec - order = 'UNGRIDDED_DIMS::GEOM::UNITS::TYPEKIND' + order = 'UNGRIDDED_DIMS::GEOM::VERTICAL::UNITS::TYPEKIND' end function get_aspect_priorities diff --git a/generic3g/specs/GeomAspect.F90 b/generic3g/specs/GeomAspect.F90 index a31a390a7357..9723f5c545b7 100644 --- a/generic3g/specs/GeomAspect.F90 +++ b/generic3g/specs/GeomAspect.F90 @@ -26,6 +26,7 @@ module mapl3g_GeomAspect procedure :: supports_conversion_general procedure :: supports_conversion_specific procedure :: set_geom + procedure :: get_geom end type GeomAspect interface GeomAspect @@ -121,4 +122,15 @@ subroutine set_geom(this, geom) end subroutine set_geom + function get_geom(this, rc) result(geom) + class(GeomAspect), intent(in) :: this + type(ESMF_Geom) :: geom + integer, optional, intent(out) :: rc + + _ASSERT(allocated(this%geom), 'geom not allocated') + geom = this%geom + + _RETURN(_SUCCESS) + end function get_geom + end module mapl3g_GeomAspect diff --git a/generic3g/specs/InvalidSpec.F90 b/generic3g/specs/InvalidSpec.F90 index 171139c91d60..720c7e1d5d09 100644 --- a/generic3g/specs/InvalidSpec.F90 +++ b/generic3g/specs/InvalidSpec.F90 @@ -40,7 +40,6 @@ module mapl3g_InvalidSpec procedure :: set_geometry => set_geometry procedure :: write_formatted - procedure :: make_adapters end type InvalidSpec contains @@ -158,19 +157,4 @@ subroutine write_formatted(this, unit, iotype, v_list, iostat, iomsg) write(unit, "(a)", iostat=iostat, iomsg=iomsg) "InvalidSpec()" end subroutine write_formatted - ! Stub implementation - function make_adapters(this, goal_spec, rc) result(adapters) - type(StateItemAdapterWrapper), allocatable :: adapters(:) - class(InvalidSpec), intent(in) :: this - class(StateItemSpec), intent(in) :: goal_spec - integer, optional, intent(out) :: rc - - allocate(adapters(0)) - - _RETURN(_SUCCESS) - _UNUSED_DUMMY(this) - _UNUSED_DUMMY(goal_spec) - end function make_adapters - - end module mapl3g_InvalidSpec diff --git a/generic3g/specs/ServiceSpec.F90 b/generic3g/specs/ServiceSpec.F90 index 32f9fddb58cf..bae9b0ca35d3 100644 --- a/generic3g/specs/ServiceSpec.F90 +++ b/generic3g/specs/ServiceSpec.F90 @@ -42,7 +42,6 @@ module mapl3g_ServiceSpec procedure :: connect_to procedure :: can_connect_to - procedure :: make_adapters procedure :: add_to_state procedure :: add_to_bundle @@ -224,17 +223,4 @@ subroutine write_formatted(this, unit, iotype, v_list, iostat, iomsg) write(unit, "(a)", iostat=iostat, iomsg=iomsg) "ServiceSpec(write not implemented yet)" end subroutine write_formatted - function make_adapters(this, goal_spec, rc) result(adapters) - type(StateItemAdapterWrapper), allocatable :: adapters(:) - class(ServiceSpec), intent(in) :: this - class(StateItemSpec), intent(in) :: goal_spec - integer, optional, intent(out) :: rc - - allocate(adapters(0)) - - _RETURN(_SUCCESS) - _UNUSED_DUMMY(this) - _UNUSED_DUMMY(goal_spec) - end function make_adapters - end module mapl3g_ServiceSpec diff --git a/generic3g/specs/StateItemAspect.F90 b/generic3g/specs/StateItemAspect.F90 index b740eb4de65e..60859ea81360 100644 --- a/generic3g/specs/StateItemAspect.F90 +++ b/generic3g/specs/StateItemAspect.F90 @@ -117,7 +117,10 @@ logical function can_connect_to(src, dst) can_connect_to = src%supports_conversion() return end if - can_connect_to = src%supports_conversion(dst) .or. src%matches(dst) + can_connect_to = src%matches(dst) + if (.not. can_connect_to) then + can_connect_to = src%supports_conversion(dst) + end if case (1) can_connect_to = .true. case (2) diff --git a/generic3g/specs/StateItemSpec.F90 b/generic3g/specs/StateItemSpec.F90 index 1f60be2ac124..133cc4b0a1d3 100644 --- a/generic3g/specs/StateItemSpec.F90 +++ b/generic3g/specs/StateItemSpec.F90 @@ -49,7 +49,6 @@ module mapl3g_StateItemSpec procedure(I_connect), deferred :: connect_to procedure(I_can_connect), deferred :: can_connect_to - procedure(I_make_adapters), deferred :: make_adapters procedure :: get_aspect_order ! as string vector !# procedure(I_get_aspect_priorities), deferred :: get_aspect_priorities ! as colon-separated string @@ -185,22 +184,6 @@ subroutine I_write_formatted(this, unit, iotype, v_list, iostat, iomsg) character(*), intent(inout) :: iomsg end subroutine I_write_formatted - ! Returns an ordered list of adapters that priorities matching - ! rules for connecting a family of extension to a goal spec. - ! The intent is that the adapters are ordered to prioritize - ! coupling to avoid more expensive and/or diffusive couplers. - ! E.g., The first adapter for a FieldSpec is expected to be - ! a GeomAdapter so that a new RegridAction is only needed when - ! no existing extensions match the geom of the goal_spec. - function I_make_adapters(this, goal_spec, rc) result(adapters) - import StateItemSpec - import StateItemAdapterWrapper - type(StateItemAdapterWrapper), allocatable :: adapters(:) - class(StateItemSpec), intent(in) :: this - class(StateItemSpec), intent(in) :: goal_spec - integer, optional, intent(out) :: rc - end function I_make_adapters - function I_get_aspect_priorities(src_spec, dst_spec) result(aspect_order) import StateItemSpec character(:), allocatable :: order diff --git a/generic3g/specs/TypekindAspect.F90 b/generic3g/specs/TypekindAspect.F90 index fd4960a76b45..74d5c040a832 100644 --- a/generic3g/specs/TypekindAspect.F90 +++ b/generic3g/specs/TypekindAspect.F90 @@ -22,6 +22,9 @@ module mapl3g_TypekindAspect procedure :: supports_conversion_general procedure :: supports_conversion_specific procedure :: make_action + + procedure :: set_typekind + procedure :: get_typekind end type TypekindAspect interface TypekindAspect @@ -58,9 +61,12 @@ logical function matches(src, dst) class(TypekindAspect), intent(in) :: src class(StateItemAspect), intent(in) :: dst + _HERE select type(dst) class is (TypekindAspect) + _HERE matches = (src%typekind == dst%typekind) .or. count([src%typekind,dst%typekind]==MAPL_TYPEKIND_MIRROR) == 1 + _HERE, matches class default matches = .false. end select @@ -83,4 +89,18 @@ function make_action(src, dst, rc) result(action) _RETURN(_SUCCESS) end function make_action + subroutine set_typekind(this, typekind) + class(TypekindAspect), intent(inout) :: this + type(ESMF_Typekind_Flag), intent(in) :: typekind + + this%typekind = typekind + end subroutine set_typekind + + function get_typekind(this) result(typekind) + type(ESMF_Typekind_Flag) :: typekind + class(TypekindAspect), intent(in) :: this + + typekind = this%typekind + end function get_typekind + end module mapl3g_TypekindAspect diff --git a/generic3g/specs/UnitsAspect.F90 b/generic3g/specs/UnitsAspect.F90 index e1dde2592e86..bb0c8015fef2 100644 --- a/generic3g/specs/UnitsAspect.F90 +++ b/generic3g/specs/UnitsAspect.F90 @@ -56,12 +56,14 @@ logical function supports_conversion_specific(src, dst) select type (dst) class is (UnitsAspect) + _HERE, src%units, ' --> ', dst%units supports_conversion_specific = .true. if (src%units == dst%units) return ! allow silly units so long as they are the same supports_conversion_specific = are_convertible(src%units, dst%units, rc=ignore) class default supports_conversion_specific = .false. end select + _HERE, supports_conversion_specific end function supports_conversion_specific diff --git a/generic3g/specs/VariableSpec.F90 b/generic3g/specs/VariableSpec.F90 index 6173aa6e261e..db2316b394a1 100644 --- a/generic3g/specs/VariableSpec.F90 +++ b/generic3g/specs/VariableSpec.F90 @@ -3,6 +3,7 @@ module mapl3g_VariableSpec use mapl3g_AspectCollection use mapl3g_GeomAspect + use mapl3g_VerticalGridAspect use mapl3g_UnitsAspect use mapl3g_TypekindAspect use mapl3g_UngriddedDimsAspect @@ -107,6 +108,9 @@ function new_VariableSpec( & call var_spec%aspects%set_units_aspect(UnitsAspect(units)) regrid_param_ = get_regrid_param(regrid_param, standard_name) + call var_spec%aspects%set_vertical_grid_aspect(VerticalGridAspect( & + vertical_dim_spec=vertical_dim_spec, & + geom=geom)) call var_spec%aspects%set_geom_aspect(GeomAspect(geom, regrid_param_, horizontal_dims_spec)) call var_spec%aspects%set_ungridded_dims_aspect(UngriddedDimsAspect(ungridded_dims)) diff --git a/generic3g/specs/VerticalGridAspect.F90 b/generic3g/specs/VerticalGridAspect.F90 new file mode 100644 index 000000000000..84506d09b128 --- /dev/null +++ b/generic3g/specs/VerticalGridAspect.F90 @@ -0,0 +1,194 @@ +#include "MAPL_Generic.h" + +module mapl3g_VerticalGridAspect + use mapl3g_StateItemAspect + use mapl3g_ExtensionAction + use mapl3g_VerticalGrid + use mapl3g_NullAction + use mapl3g_VerticalRegridAction + use mapl3g_VerticalRegridMethod + use mapl3g_VerticalDimSpec + use mapl3g_VerticalRegridMethod + use mapl3g_ComponentDriver + use mapl_ErrorHandling + use ESMF + implicit none + private + + public :: VerticalGridAspect + + + type, extends(StateItemAspect) :: VerticalGridAspect +!# private + class(VerticalGrid), allocatable :: vertical_grid + type(VerticalRegridMethod) :: regrid_method = VERTICAL_REGRID_LINEAR +!# type(VerticalStaggerLoc), allocatable :: vertical_staggerloc + type(VerticalDimSpec), allocatable :: vertical_dim_spec + + ! These might be updated due to intervening couplers + type(ESMF_Geom), allocatable :: geom + type(ESMF_Typekind_Flag) :: typekind + contains + procedure :: matches + procedure :: supports_conversion_general + procedure :: supports_conversion_specific + procedure :: make_action + procedure :: typesafe_make_action + + procedure :: set_vertical_grid + procedure :: set_geom + procedure :: set_typekind + end type VerticalGridAspect + + interface VerticalGridAspect + procedure new_VerticalGridAspect_specific + end interface + +contains + + function new_VerticalGridAspect_specific(vertical_grid, regrid_method, vertical_dim_spec, geom, typekind, time_dependent) result(aspect) + type(VerticalGridAspect) :: aspect + class(VerticalGrid), optional, intent(in) :: vertical_grid + type(VerticalRegridMethod), optional, intent(in) :: regrid_method + type(VerticalDimSpec), optional, intent(in) :: vertical_dim_spec + type(ESMF_Geom), optional, intent(in) :: geom + type(ESMF_Typekind_Flag), optional, intent(in) :: typekind + logical, optional, intent(in) :: time_dependent + + call aspect%set_mirror(.true.) + if (present(vertical_grid)) then + aspect%vertical_grid = vertical_grid + call aspect%set_mirror(.false.) + end if + + if (present(regrid_method)) then + aspect%regrid_method = regrid_method + end if + + if (present(vertical_dim_spec)) then + aspect%vertical_dim_spec = vertical_dim_spec + end if + + if (present(geom)) then + aspect%geom = geom + end if + + if (present(typekind)) then + aspect%typekind = typekind + end if + + call aspect%set_time_dependent(time_dependent) + + end function new_VerticalGridAspect_specific + + function new_VerticalGridAspect_mirror() result(aspect) + type(VerticalGridAspect) :: aspect + + call aspect%set_mirror(.true.) + + end function new_VerticalGridAspect_mirror + + logical function supports_conversion_general(src) + class(VerticalGridAspect), intent(in) :: src + supports_conversion_general = .true. + end function supports_conversion_general + + logical function supports_conversion_specific(src, dst) + class(VerticalGridAspect), intent(in) :: src + class(StateItemAspect), intent(in) :: dst + + integer :: status + + supports_conversion_specific = .false. + + select type (dst) + class is (VerticalGridAspect) + ! Note: "grid%can_connect_to()" reverses dst and src. Something that should be fixed. + supports_conversion_specific = src%vertical_grid%can_connect_to(dst%vertical_grid) + end select + + end function supports_conversion_specific + + logical function matches(src, dst) + class(VerticalGridAspect), intent(in) :: src + class(StateItemAspect), intent(in) :: dst + + select type(dst) + class is (VerticalGridAspect) + matches = dst%vertical_grid%is_identical_to(src%vertical_grid) + class default + matches = .false. + end select + + end function matches + + function make_action(src, dst, rc) result(action) + class(ExtensionAction), allocatable :: action + class(VerticalGridAspect), intent(in) :: src + class(StateItemAspect), intent(in) :: dst + integer, optional, intent(out) :: rc + + select type (dst) + class is (VerticalGridAspect) + action = src%typesafe_make_action(dst, rc) + class default + action = NullAction() + _FAIL('dst is not a VerticalGridAspect') + end select + + _RETURN(_SUCCESS) + end function make_action + + function typesafe_make_action(src, dst, rc) result(action) + class(ExtensionAction), allocatable :: action + class(VerticalGridAspect), intent(in) :: src + class(VerticalGridAspect), intent(in) :: dst + integer, optional, intent(out) :: rc + + class(ComponentDriver), pointer :: v_in_coupler + class(ComponentDriver), pointer :: v_out_coupler + type(ESMF_Field) :: v_in_field, v_out_field + + type(ESMF_Geom) :: geom + type(ESMF_TypeKind_Flag) :: typekind + character(:), allocatable :: units + integer :: status + + geom = src%geom + typekind = src%typekind + units = src%vertical_grid%get_units() + +!# call src%vertical_grid%get_coordinate_field(v_in_field, v_in_coupler, geom, typekind, src%vertical_staggerloc, _RC) +!# call dst%vertical_grid%get_coordinate_field(v_out_field, v_out_coupler, geom, typekind, dst%vertical_staggerloc, _RC) + + call src%vertical_grid%get_coordinate_field(v_in_field, v_in_coupler, 'ignore', geom, typekind, units, src%vertical_dim_spec, _RC) + call dst%vertical_grid%get_coordinate_field(v_out_field, v_out_coupler, 'ignore', geom, typekind, units, dst%vertical_dim_spec, _RC) + + action = VerticalRegridAction(v_in_field, v_in_coupler, v_out_field, v_out_coupler, dst%regrid_method) + + _RETURN(_SUCCESS) + end function typesafe_make_action + + subroutine set_vertical_grid(self, vertical_grid) + class(VerticalGridAspect), intent(inout) :: self + class(VerticalGrid), intent(in) :: vertical_grid + + self%vertical_grid = vertical_grid + call self%set_mirror(.false.) + end subroutine set_vertical_grid + + subroutine set_geom(self, geom) + class(VerticalGridAspect), intent(inout) :: self + type(ESMF_Geom), intent(in) :: geom + + self%geom = geom + end subroutine set_geom + + subroutine set_typekind(self, typekind) + class(VerticalGridAspect), intent(inout) :: self + type(ESMF_Typekind_Flag), intent(in) :: typekind + + self%typekind = typekind + end subroutine set_typekind + +end module mapl3g_VerticalGridAspect diff --git a/generic3g/specs/WildcardSpec.F90 b/generic3g/specs/WildcardSpec.F90 index 16b0d3644818..d064f0993ab8 100644 --- a/generic3g/specs/WildcardSpec.F90 +++ b/generic3g/specs/WildcardSpec.F90 @@ -34,7 +34,6 @@ module mapl3g_WildcardSpec procedure :: connect_to procedure :: can_connect_to - procedure :: make_adapters procedure :: add_to_state procedure :: add_to_bundle procedure :: set_geometry @@ -230,20 +229,6 @@ subroutine write_formatted(this, unit, iotype, v_list, iostat, iomsg) write(unit, "(a)", iostat=iostat, iomsg=iomsg) "WildcardSpec(write not implemented yet)" end subroutine write_formatted - function make_adapters(this, goal_spec, rc) result(adapters) - type(StateItemAdapterWrapper), allocatable :: adapters(:) - class(WildcardSpec), intent(in) :: this - class(StateItemSpec), intent(in) :: goal_spec - integer, optional, intent(out) :: rc - - integer :: status - associate (field_spec => this%reference_spec) - adapters = field_spec%make_adapters(field_spec, _RC) - end associate - - _RETURN(_SUCCESS) - end function make_adapters - function get_reference_spec(this) result(reference_spec) class(WildcardSpec), target, intent(in) :: this class(StateItemSpec), pointer :: reference_spec diff --git a/generic3g/tests/MockItemSpec.F90 b/generic3g/tests/MockItemSpec.F90 index 72940a4812c1..873079c5b186 100644 --- a/generic3g/tests/MockItemSpec.F90 +++ b/generic3g/tests/MockItemSpec.F90 @@ -13,6 +13,10 @@ module MockItemSpecMod use mapl3g_ExtensionAction use mapl3g_NullAction use mapl3g_VerticalGrid + use mapl3g_AspectCollection + use mapl3g_StateItemAspect + use mapl3g_UnitsAspect + use mapl3g_TypekindAspect use esmf implicit none @@ -24,8 +28,6 @@ module MockItemSpecMod ! Note - this leaks memory type, extends(StateItemSpec) :: MockItemSpec character(len=:), allocatable :: name - character(len=:), allocatable :: subtype - character(len=:), allocatable :: adapter_type contains procedure :: create procedure :: destroy @@ -34,7 +36,6 @@ module MockItemSpecMod procedure :: connect_to procedure :: can_connect_to - procedure :: make_adapters procedure :: add_to_state procedure :: add_to_bundle procedure :: write_formatted @@ -57,40 +58,21 @@ module MockItemSpecMod module procedure new_MockAction end interface MockAction - type, extends(StateItemAdapter) :: SubtypeAdapter - character(:), allocatable :: subtype - contains - procedure :: adapt_one => adapt_subtype - procedure :: match_one => match_subtype - end type SubtypeAdapter - - interface SubtypeAdapter - procedure :: new_SubtypeAdapter - end interface SubtypeAdapter - - - type, extends(StateItemAdapter) :: NameAdapter - character(:), allocatable :: name - contains - procedure :: adapt_one => adapt_name - procedure :: match_one => match_name - end type NameAdapter - - interface NameAdapter - procedure :: new_NameAdapter - end interface NameAdapter - contains - function new_MockItemSpec(name, subtype, adapter_type) result(spec) - type(MockItemSpec) :: spec + function new_MockItemSpec(name, typekind, units) result(spec) + type(MockItemSpec), target :: spec character(*), intent(in) :: name - character(*), optional, intent(in) :: subtype - character(*), optional, intent(in) :: adapter_type + type(ESMF_Typekind_Flag), optional, intent(in) :: typekind + character(*), optional, intent(in) :: units + + type(AspectCollection), pointer :: aspects spec%name = name - if (present(subtype)) spec%subtype = subtype - if (present(adapter_type)) spec%adapter_type = adapter_type + + aspects => spec%get_aspects() + call aspects%set_aspect(TypekindAspect(typekind)) + call aspects%set_aspect(UnitsAspect(units)) end function new_MockItemSpec @@ -135,6 +117,7 @@ subroutine connect_to(this, src_spec, actual_pt, rc) integer :: status logical :: can_connect + class(StateItemAspect), pointer :: aspect can_connect = this%can_connect_to(src_spec, _RC) _ASSERT(can_connect, 'illegal connection') @@ -143,9 +126,10 @@ subroutine connect_to(this, src_spec, actual_pt, rc) class is (MockItemSpec) ! ok this%name = src_spec%name - if (allocated(src_spec%subtype)) then - this%subtype = src_spec%subtype - end if + aspect => src_spec%get_aspect('UNITS', _RC) + call this%set_aspect(aspect, _RC) + aspect => src_spec%get_aspect('TYPEKIND', _RC) + call this%set_aspect(aspect, _RC) class default _FAIL('Cannot connect field spec to non field spec.') end select @@ -237,152 +221,20 @@ subroutine update(this, importState, exportState, clock, rc) _FAIL('This procedure should not be called.') end subroutine update - function make_adapters(this, goal_spec, rc) result(adapters) - type(StateItemAdapterWrapper), allocatable :: adapters(:) - class(MockItemSpec), intent(in) :: this - class(StateItemSpec), intent(in) :: goal_spec - integer, optional, intent(out) :: rc - - type(SubtypeAdapter) :: subtype_adapter - type(NameAdapter) :: name_adapter - allocate(adapters(0)) ! just in case - - select type (goal_spec) - type is (MockItemSpec) - - - if (allocated(this%adapter_type)) then - select case (this%adapter_type) - case ('subtype') - deallocate(adapters) - allocate(adapters(1)) - subtype_adapter = SubtypeAdapter(goal_spec%subtype) - allocate(adapters(1)%adapter, source=subtype_adapter) - case ('name') - deallocate(adapters) - allocate(adapters(1)) - name_adapter = NameAdapter(goal_spec%name) - allocate(adapters(1)%adapter, source=name_adapter) - case default - _FAIL('unsupported adapter type') - end select - else - deallocate(adapters) - allocate(adapters(2)) - subtype_adapter = SubtypeAdapter(goal_spec%subtype) - name_adapter = NameAdapter(goal_spec%name) - allocate(adapters(1)%adapter, source=name_adapter) - allocate(adapters(2)%adapter, source=subtype_adapter) - end if - end select - - _RETURN(_SUCCESS) - _UNUSED_DUMMY(this) - _UNUSED_DUMMY(goal_spec) - end function make_adapters - - subroutine adapt_subtype(this, spec, action, rc) - class(SubtypeAdapter), intent(in) :: this - class(StateItemSpec), intent(inout) :: spec - class(ExtensionAction), allocatable, intent(out) :: action - integer, optional, intent(out) :: rc - - select type (spec) - type is (MockItemSpec) - spec%subtype = this%subtype - action = MockAction(spec%subtype, this%subtype) - end select - _RETURN(_SUCCESS) - end subroutine adapt_subtype - - logical function match_subtype(this, spec, rc) result(match) - class(SubtypeAdapter), intent(in) :: this - class(StateItemSpec), intent(in) :: spec - integer, optional, intent(out) :: rc - - match = .false. - select type (spec) - type is (MockItemSpec) - if (allocated(this%subtype)) then - if (allocated(spec%subtype)) then - match = this%subtype == spec%subtype - else - match = .true. - end if - else - match = .true. - end if - end select - - _RETURN(_SUCCESS) - end function match_subtype - - subroutine adapt_name(this, spec, action, rc) - class(NameAdapter), intent(in) :: this - class(StateItemSpec), intent(inout) :: spec - class(ExtensionAction), allocatable, intent(out) :: action - integer, optional, intent(out) :: rc - - select type (spec) - type is (MockItemSpec) - spec%name = this%name - action = MockAction() - end select - - _RETURN(_SUCCESS) - end subroutine adapt_name - - logical function match_name(this, spec, rc) result(match) - class(NameAdapter), intent(in) :: this - class(StateItemSpec), intent(in) :: spec - integer, optional, intent(out) :: rc - - - match = .false. - select type (spec) - type is (MockItemSpec) - if (allocated(this%name)) then - if (allocated(spec%name)) then - match = this%name == spec%name - else - match = .true. - end if - else - match = .true. - end if - end select - - _RETURN(_SUCCESS) - end function match_name - - function new_SubtypeAdapter(subtype) result(adapter) - type(SubtypeAdapter) :: adapter - character(*), optional, intent(in) :: subtype - if (present(subtype)) then - adapter%subtype=subtype - end if - end function new_SubtypeAdapter - - function new_NameAdapter(name) result(adapter) - type(NameAdapter) :: adapter - character(*), optional, intent(in) :: name - if (present(name)) then - adapter%name=name - end if - end function new_NameAdapter - function get_aspect_priorities(src_spec, dst_spec) result(order) character(:), allocatable :: order class(MockItemSpec), intent(in) :: src_spec class(StateItemSpec), intent(in) :: dst_spec select case (src_spec%name) + case ('0') + order = '' case ('1') - order = 'a1' + order = 'TYPEKIND' case ('3') - order = 'a1::b2::c3' + order = 'TYPEKIND::UNITS' case default - order = '' + order = 'TYPEKIND::UNITS' end select end function get_aspect_priorities diff --git a/generic3g/tests/Test_BaseItemSpec.pf b/generic3g/tests/Test_BaseItemSpec.pf index 6faa03c57874..4078e01460c9 100644 --- a/generic3g/tests/Test_BaseItemSpec.pf +++ b/generic3g/tests/Test_BaseItemSpec.pf @@ -1,5 +1,8 @@ ! Test suite that focuses on methods implemented in base class StateItemSpec +! The tests made more sense in the previous adapter scheme. With +! StateItemAspect, the tests are almost trivial. + module Test_BaseItemSpec use MockItemSpecMod use gftl2_StringVector @@ -37,7 +40,7 @@ contains @assert_that(int(expected), is(1)) end associate - @assertEqual(aspect_names%of(1), 'a1') + @assertEqual(aspect_names%of(1), 'TYPEKIND') end subroutine get_aspect_one @@ -51,12 +54,11 @@ contains aspect_names = spec%get_aspect_order(goal) associate ( expected => aspect_names%size() ) ! returns INT64 - @assert_that(int(expected), is(3)) + @assert_that(int(expected), is(2)) end associate - @assertEqual(aspect_names%of(1), 'a1') - @assertEqual(aspect_names%of(2), 'b2') - @assertEqual(aspect_names%of(3), 'c3') + @assertEqual(aspect_names%of(1), 'TYPEKIND') + @assertEqual(aspect_names%of(2), 'UNITS') end subroutine get_aspect_multi diff --git a/generic3g/tests/Test_ExtensionFamily.pf b/generic3g/tests/Test_ExtensionFamily.pf index 669997c03918..cc97b0189a6f 100644 --- a/generic3g/tests/Test_ExtensionFamily.pf +++ b/generic3g/tests/Test_ExtensionFamily.pf @@ -7,9 +7,12 @@ module Test_ExtensionFamily use mapl3g_VirtualConnectionPt use MockItemSpecMod use mapl3g_StateItemExtension + use esmf use funit implicit none + type(ESMF_Typekind_Flag), parameter :: R4 = ESMF_TYPEKIND_R4 + type(ESMF_Typekind_Flag), parameter :: R8 = ESMF_TYPEKIND_R8 contains @test @@ -25,7 +28,7 @@ contains r = StateRegistry('A') v_pt = VirtualConnectionPt(state_intent='export', short_name='E1') - call r%add_primary_spec(v_pt, MockItemSpec('E', subtype='A')) + call r%add_primary_spec(v_pt, MockItemSpec('E', typekind=R8)) family => r%get_extension_family(v_pt, _RC) @@ -44,7 +47,6 @@ contains type(VirtualConnectionPt) :: v_pt type(ExtensionFamily), pointer :: family type(StateItemExtension) :: extension - type(StateItemExtension), pointer :: primary type(StateItemExtension), pointer :: ext_1, ext_2 type(MockItemSpec) :: goal_spec type(StateItemExtension), pointer :: closest @@ -53,17 +55,16 @@ contains r = StateRegistry('A') v_pt = VirtualConnectionPt(state_intent='export', short_name='E1') - call r%add_primary_spec(v_pt, MockItemSpec('E', subtype='A', adapter_type='subtype')) + call r%add_primary_spec(v_pt, MockItemSpec('3', typekind=R4, units='m')) - extension = StateItemExtension(MockItemSpec('E',subtype='B')) + extension = StateItemExtension(MockItemSpec('b',typekind=R8, units='cm')) ext_1 => r%add_extension(v_pt, extension, _RC) - extension = StateItemExtension(MockItemSpec('F',subtype='A')) + extension = StateItemExtension(MockItemSpec('b',typekind=R4, units='km')) ext_2 => r%add_extension(v_pt, extension, _RC) family => r%get_extension_family(v_pt, _RC) - primary => family%get_primary(_RC) - goal_spec = MockItemSpec('E', subtype='B') + goal_spec = MockItemSpec('c', typekind=ESMF_TYPEKIND_R8) closest => family%find_closest_extension(goal_spec,_RC) @@ -86,22 +87,22 @@ contains r = StateRegistry('A') v_pt = VirtualConnectionPt(state_intent='export', short_name='E1') - call r%add_primary_spec(v_pt, MockItemSpec('E', subtype='A', adapter_type='name')) + call r%add_primary_spec(v_pt, MockItemSpec('3', typekind=R8, units='m')) - extension = StateItemExtension(MockItemSpec('E',subtype='B')) + extension = StateItemExtension(MockItemSpec('E',typekind=R4, units='km')) ext_1 => r%add_extension(v_pt, extension, _RC) - extension = StateItemExtension(MockItemSpec('F',subtype='A')) + extension = StateItemExtension(MockItemSpec('F',typekind=R4, units='m')) ext_2 => r%add_extension(v_pt, extension, _RC) family => r%get_extension_family(v_pt, _RC) primary => family%get_primary(_RC) - goal_spec = MockItemSpec('E', subtype='A') + goal_spec = MockItemSpec('E', typekind=R8) closest => family%find_closest_extension(goal_spec,_RC) @assert_that(associated(closest, primary), is(true())) - goal_spec = MockItemSpec('F', subtype='B') + goal_spec = MockItemSpec('F', typekind=R4, units='m') closest => family%find_closest_extension(goal_spec,_RC) @assert_that(associated(closest, ext_2), is(true())) diff --git a/generic3g/tests/Test_StateRegistry.pf b/generic3g/tests/Test_StateRegistry.pf index 317a3af52d67..857c2de7dfd5 100644 --- a/generic3g/tests/Test_StateRegistry.pf +++ b/generic3g/tests/Test_StateRegistry.pf @@ -390,14 +390,15 @@ contains cp_A = VirtualConnectionPt(state_intent='export', short_name='ae') cp_B = VirtualConnectionPt(state_intent='import', short_name='ai') - call r_a%add_primary_spec(cp_A, MockItemSpec('AE')) - call r_b%add_primary_spec(cp_B, MockItemSpec('AI')) + call r_a%add_primary_spec(cp_A, MockItemSpec('AE', typekind=ESMF_TYPEKIND_R4, units='m')) + call r_b%add_primary_spec(cp_B, MockItemSpec('AI',typekind=ESMF_TYPEKIND_R8, units='m')) conn = SimpleConnection(CP('child_A', cp_A), CP('child_B', cp_B)) call conn%connect(r, _RC) ! Check that extension was created family => r_a%get_extension_family(cp_A, _RC) + _HERE, r_a @assert_that(associated(family%get_primary()), is(true())) @assert_that(family%num_variants(), is(2)) From f14b5f3c8a78980f9c63d6b83f7c0f3524c5b6da Mon Sep 17 00:00:00 2001 From: Tom Clune Date: Sun, 12 Jan 2025 14:20:53 -0500 Subject: [PATCH 2/2] Fixed issues with merge. - mostly dt --> timestep - removed debug print --- generic3g/specs/FieldSpec.F90 | 10 +--------- generic3g/specs/TypekindAspect.F90 | 3 --- 2 files changed, 1 insertion(+), 12 deletions(-) diff --git a/generic3g/specs/FieldSpec.F90 b/generic3g/specs/FieldSpec.F90 index 8108092c926a..6e23220aaa52 100644 --- a/generic3g/specs/FieldSpec.F90 +++ b/generic3g/specs/FieldSpec.F90 @@ -187,10 +187,6 @@ function new_FieldSpec_geom(unusable, geom, vertical_grid, vertical_dim_spec, ty if (present(default_value)) field_spec%default_value = default_value - field_spec%accumulation_type = NO_ACCUMULATION - if (present(accumulation_type)) field_spec%accumulation_type = trim(accumulation_type) - if (present(run_dt)) field_spec%run_dt = run_dt - _UNUSED_DUMMY(unusable) end function new_FieldSpec_geom @@ -201,8 +197,6 @@ function new_FieldSpec_varspec(variable_spec) result(field_spec) type(ESMF_RegridMethod_Flag), allocatable :: regrid_method - field_spec%accumulation_type = NO_ACCUMULATION - _SET_FIELD(field_spec, variable_spec, attributes) _SET_ALLOCATED_FIELD(field_spec, variable_spec, standard_name) call field_spec%set_aspect(variable_spec%aspects%get_aspect('GEOM')) @@ -229,7 +223,6 @@ subroutine set_geometry(this, geom, vertical_grid, timestep, rc) type(ESMF_RegridMethod_Flag), allocatable :: regrid_method call target_set_geom(this, geom, vertical_grid) - if (present(run_dt)) this%run_dt = run_dt call target_set_timestep(this, timestep) _RETURN(_SUCCESS) @@ -288,8 +281,7 @@ subroutine target_set_timestep(this, timestep) call frequency_aspect%set_timestep(timestep) return end if - call aspects%set_frequency_aspect(FrequencyAspect(timestep)) - + end subroutine target_set_timestep end subroutine set_geometry diff --git a/generic3g/specs/TypekindAspect.F90 b/generic3g/specs/TypekindAspect.F90 index 74d5c040a832..846a8e2d1fd9 100644 --- a/generic3g/specs/TypekindAspect.F90 +++ b/generic3g/specs/TypekindAspect.F90 @@ -61,12 +61,9 @@ logical function matches(src, dst) class(TypekindAspect), intent(in) :: src class(StateItemAspect), intent(in) :: dst - _HERE select type(dst) class is (TypekindAspect) - _HERE matches = (src%typekind == dst%typekind) .or. count([src%typekind,dst%typekind]==MAPL_TYPEKIND_MIRROR) == 1 - _HERE, matches class default matches = .false. end select