Skip to content

Commit

Permalink
Merge pull request #3263 from GEOS-ESM/feature/tclune/#3250-integrate…
Browse files Browse the repository at this point in the history
…-aspect

Fixes #3250 - integration of aspects
  • Loading branch information
tclune authored Dec 23, 2024
2 parents bf4b0fc + 3ea0fbe commit 47b57e0
Show file tree
Hide file tree
Showing 16 changed files with 494 additions and 277 deletions.
3 changes: 0 additions & 3 deletions generic3g/GriddedComponentDriver/run.F90
Original file line number Diff line number Diff line change
Expand Up @@ -20,7 +20,6 @@ module recursive subroutine run(this, unusable, phase_idx, rc)
integer :: status, user_status

_ASSERT(present(phase_idx), 'until made not optional')
call this%run_import_couplers(_RC)

associate ( &
importState => this%states%importState, &
Expand All @@ -34,8 +33,6 @@ module recursive subroutine run(this, unusable, phase_idx, rc)

end associate

call this%run_export_couplers(phase_idx=phase_idx, _RC)

_RETURN(_SUCCESS)
_UNUSED_DUMMY(unusable)
end subroutine run
Expand Down
2 changes: 1 addition & 1 deletion generic3g/OuterMetaComponent/run_user.F90
Original file line number Diff line number Diff line change
Expand Up @@ -36,9 +36,9 @@ module recursive subroutine run_user(this, phase_name, unusable, rc)
call drvr%ptr%run(phase_idx=GENERIC_COUPLER_UPDATE, _RC)
end do


call this%user_gc_driver%run(phase_idx=phase, _RC)


export_couplers = this%registry%get_export_couplers()
do i = 1, export_couplers%size()
drvr = export_couplers%of(i)
Expand Down
6 changes: 5 additions & 1 deletion generic3g/connection/SimpleConnection.F90
Original file line number Diff line number Diff line change
Expand Up @@ -123,7 +123,7 @@ recursive subroutine connect(this, registry, rc)

_ASSERT(associated(src_registry), 'Unknown source registry')
_ASSERT(associated(dst_registry), 'Unknown destination registry')

call this%connect_sibling(dst_registry, src_registry, _RC)

_RETURN(_SUCCESS)
Expand Down Expand Up @@ -171,6 +171,10 @@ recursive subroutine connect_sibling(this, dst_registry, src_registry, unusable,
call dst_spec%connect_to(new_spec, effective_pt, _RC)
call dst_spec%set_active()

if (new_extension%has_producer()) then
call dst_extension%set_producer(new_extension%get_producer(), _RC)
!# dst_extension%dependency => new_extension%get_producer()
end if
end do

_RETURN(_SUCCESS)
Expand Down
1 change: 0 additions & 1 deletion generic3g/couplers/GenericCoupler.F90
Original file line number Diff line number Diff line change
Expand Up @@ -37,7 +37,6 @@ function make_coupler(action, source, rc) result(coupler_gridcomp)
#else
call ridiculous(coupler_meta, CouplerMetaComponent(action,source))
#endif

call ESMF_GridCompSetServices(coupler_gridComp, setServices, _RC)

_RETURN(_SUCCESS)
Expand Down
35 changes: 28 additions & 7 deletions generic3g/registry/ExtensionFamily.F90
Original file line number Diff line number Diff line change
Expand Up @@ -30,6 +30,7 @@ module mapl3g_ExtensionFamily
procedure :: get_extension
procedure :: add_extension
procedure :: num_variants
procedure :: merge

procedure :: find_closest_extension
end type ExtensionFamily
Expand Down Expand Up @@ -133,7 +134,6 @@ function find_closest_extension(family, goal_spec, rc) result(closest_extension)
subgroup = family%get_extensions()
primary => family%get_primary() ! archetype defines the rules
archetype => primary%get_spec()

! new
aspect_names = archetype%get_aspect_order(goal_spec)
do i = 1, aspect_names%size()
Expand All @@ -145,18 +145,19 @@ function find_closest_extension(family, goal_spec, rc) result(closest_extension)
do j = 1, subgroup%size()
extension_ptr = subgroup%of(j)
spec => extension_ptr%ptr%get_spec()

src_aspect => spec%get_aspect(aspect_name, _RC)

if (src_aspect%matches(dst_aspect)) then
call new_subgroup%push_back(extension_ptr)
end if
_ASSERT(associated(src_aspect),'aspect '// aspect_name// ' not found')

if (src_aspect%needs_extension_for(dst_aspect)) cycle
call new_subgroup%push_back(extension_ptr)

end do

if (new_subgroup%size() == 0) exit
subgroup = new_subgroup

end do

! old

adapters = archetype%make_adapters(goal_spec, _RC)
Expand Down Expand Up @@ -184,6 +185,26 @@ function find_closest_extension(family, goal_spec, rc) result(closest_extension)
_RETURN(_SUCCESS)
end function find_closest_extension

subroutine merge(this, other)
class(ExtensionFamily), target, intent(inout) :: this
type(ExtensionFamily), target, intent(in) :: other

integer :: i, j
type(StateItemExtensionPtr) :: extension, other_extension

outer: do i = 1, other%num_variants()
other_extension = other%extensions%of(i)

do j = 1, this%num_variants()
extension = this%extensions%of(j)
if (associated(extension%ptr, other_extension%ptr)) cycle outer
end do
call this%extensions%push_back(other_extension)

end do outer
this%has_primary_ = other%has_primary_

end subroutine merge

end module mapl3g_ExtensionFamily

51 changes: 36 additions & 15 deletions generic3g/registry/StateItemExtension.F90
Original file line number Diff line number Diff line change
Expand Up @@ -30,8 +30,10 @@ module mapl3g_StateItemExtension
contains
procedure :: get_spec
procedure :: get_producer
procedure :: set_producer
procedure :: get_consumers
procedure :: has_producer
procedure :: has_consumers
procedure :: add_consumer
procedure :: make_extension
end type StateItemExtension
Expand Down Expand Up @@ -72,19 +74,32 @@ logical function has_producer(this)
has_producer = allocated(this%producer)
end function has_producer

logical function has_consumers(this)
class(StateItemExtension), target, intent(in) :: this
has_consumers = this%consumers%size() > 0
end function has_consumers

function get_producer(this) result(producer)
class(StateItemExtension), target, intent(in) :: this
type(GriddedComponentDriver), pointer :: producer

if (.not. allocated(this%producer)) then
producer => null()
return
end if

producer => null()
if (.not. allocated(this%producer)) return
producer => this%producer

end function get_producer

subroutine set_producer(this, producer, rc)
class(StateItemExtension), intent(inout) :: this
type(GriddedComponentDriver), intent(in) :: producer
integer, optional, intent(out) :: rc

_ASSERT(.not. this%has_producer(), 'cannot set producer for extension that already has one')
this%producer = producer

_RETURN(_SUCCESS)
end subroutine set_producer

function get_consumers(this) result(consumers)
class(StateItemExtension), target, intent(in) :: this
type(ComponentDriverPtrVector), pointer :: consumers
Expand Down Expand Up @@ -116,14 +131,15 @@ recursive function make_extension(this, goal, rc) result(extension)
class(StateItemSpec), allocatable :: new_spec
class(ExtensionAction), allocatable :: action
type(GriddedComponentDriver) :: producer
type(GriddedComponentDriver), pointer :: source
type(ESMF_GridComp) :: coupler_gridcomp
type(StateItemAdapterWrapper), allocatable :: adapters(:)
type(ESMF_Clock) :: fake_clock
logical :: match
type(StringVector), target :: aspect_names
character(:), pointer :: aspect_name
class(StateItemAspect), pointer :: src_aspect, dst_aspect
type(AspectExtension) :: aspect_extension


call this%spec%set_active()

Expand All @@ -135,23 +151,27 @@ recursive function make_extension(this, goal, rc) result(extension)
src_aspect => new_spec%get_aspect(aspect_name, _RC)
dst_aspect => goal%get_aspect(aspect_name, _RC)
_ASSERT(src_aspect%can_connect_to(dst_aspect), 'cannoct connect aspect ' // aspect_name)
if (.not. src_aspect%needs_extension_for(dst_aspect)) cycle
aspect_extension = src_aspect%make_extension(dst_aspect, _RC)
call new_spec%set_aspect(aspect_name, aspect_extension%aspect)
exit

if (src_aspect%needs_extension_for(dst_aspect)) then
allocate(action, source=src_aspect%make_action(dst_aspect, rc=status))
_VERIFY(status)
call new_spec%set_aspect(dst_aspect, _RC)
exit
end if

end do

if (allocated(aspect_extension%action)) then
if (allocated(action)) then
call new_spec%create(_RC)
call new_spec%set_active()
coupler_gridcomp = make_coupler(aspect_extension%action, _RC)
source => this%get_producer()
coupler_gridcomp = make_coupler(action, source, _RC)
producer = GriddedComponentDriver(coupler_gridcomp, fake_clock, MultiState())
extension = StateItemExtension(new_spec, producer)
_RETURN(_SUCCESS)
end if


! The logic belowe should be removed once Aspects have fully
! The logic below should be removed once Aspects have fully
! replaced Adapters.
adapters = this%spec%make_adapters(goal, _RC)
do i = 1, size(adapters)
Expand All @@ -169,7 +189,8 @@ recursive function make_extension(this, goal, rc) result(extension)
call new_spec%create(_RC)
call new_spec%set_active()

coupler_gridcomp = make_coupler(action, _RC)
source => this%get_producer()
coupler_gridcomp = make_coupler(action, source, _RC)
producer = GriddedComponentDriver(coupler_gridcomp, fake_clock, MultiState())
extension = StateItemExtension(new_spec, producer)

Expand Down
79 changes: 45 additions & 34 deletions generic3g/registry/StateRegistry.F90
Original file line number Diff line number Diff line change
Expand Up @@ -36,9 +36,6 @@ module mapl3g_StateRegistry

type(VirtualPtFamilyMap) :: family_map

!# type(GriddedComponentDriverPtrVector) :: export_couplers
!# type(GriddedComponentDriverPtrVector) :: import_couplers

contains

procedure :: add_subregistry
Expand Down Expand Up @@ -444,7 +441,7 @@ end subroutine link

end subroutine propagate_unsatisfied_imports_virtual_pt

! Loop over subregistryren and propagate unsatisfied imports of each
! Loop over subregistry and propagate unsatisfied imports of each
subroutine propagate_exports_all(this, rc)
class(StateRegistry), target, intent(inout) :: this
integer, optional, intent(out) :: rc
Expand Down Expand Up @@ -495,7 +492,7 @@ subroutine propagate_exports_virtual_pt(this, subregistry_name, iter, rc)
type(VirtualConnectionPt), pointer :: virtual_pt
type(VirtualConnectionPt) :: new_virtual_pt
type(ExtensionFamily), pointer :: family
!# integer :: n
type(ExtensionFamily), pointer :: parent_family
type(VirtualPtFamilyMapIterator) :: new_iter

virtual_pt => iter%first()
Expand All @@ -506,18 +503,13 @@ subroutine propagate_exports_virtual_pt(this, subregistry_name, iter, rc)
new_virtual_pt = VirtualConnectionPt(virtual_pt, comp_name=subregistry_name)
end if

! TODO: Better logic would be the following line. But gFTL has
! a missing TARGET attribute (bug)
!# n = this%family_map%erase(new_virtual_pt)
! instead we do this:
associate(e => this%family_map%end())
new_iter = this%family_map%find(new_virtual_pt)
new_iter = this%family_map%erase(new_iter, e)
end associate
if (.not. this%has_virtual_pt(new_virtual_pt)) then
call this%add_virtual_pt(new_virtual_pt)
end if

call this%add_virtual_pt(new_virtual_pt, _RC)
family => iter%second()
call this%family_map%insert(new_virtual_pt, family)
parent_family => this%get_extension_family(new_virtual_pt)
call parent_family%merge(family)

_RETURN(_SUCCESS)
end subroutine propagate_exports_virtual_pt
Expand Down Expand Up @@ -746,54 +738,73 @@ function filter(this, pattern) result(matches)

end function filter

! An item has a user-level export coupler iff:
! - it is owned
! - has a consumer
! - has no producers
! The export couplers are all consumers.
function get_export_couplers(this) result(export_couplers)
type(ComponentDriverPtrVector) :: export_couplers
class(StateRegistry), target, intent(in) :: this

type(ComponentDriverPtr) :: wrapper
type(StateItemExtension), pointer :: extension
type(StateItemExtensionVectorIterator) :: iter
type(ComponentDriverPtrVector), pointer :: consumers
integer :: i


associate (e => this%owned_items%ftn_end())
iter = this%owned_items%ftn_begin()
do while (iter /= e)
call iter%next()
extension => iter%of()

if (extension%has_producer()) then
wrapper%ptr => extension%get_producer()
if (extension%has_producer()) cycle
consumers => extension%get_consumers()
do i = 1, consumers%size()
wrapper = consumers%of(i) ! copy ptr
call export_couplers%push_back(wrapper)
cycle
end if
end do

end do
end associate

end function get_export_couplers

! An item is an import coupler iff:
! - it is has a producer, but no consumer (end of chain)
! - is primary
function get_import_couplers(this) result(import_couplers)
type(ComponentDriverPtrVector) :: import_couplers
class(StateRegistry), target, intent(in) :: this

integer :: i

type(VirtualPtFamilyMapIterator) :: family_iter
type(ExtensionFamily), pointer :: family
type(VirtualConnectionPt), pointer :: v_pt
type(ComponentDriverPtr) :: wrapper
type(StateItemExtension), pointer :: extension
type(StateItemExtensionVectorIterator) :: iter
type(ComponentDriverPtrVector), pointer :: consumers

associate (e => this%owned_items%ftn_end())
iter = this%owned_items%ftn_begin()
do while (iter /= e)
call iter%next()
extension => iter%of()
type(StateItemExtension), pointer :: primary

consumers => extension%get_consumers()
do i = 1, consumers%size()
wrapper = consumers%of(i) ! copy ptr
associate (e => this%family_map%ftn_end())
family_iter = this%family_map%ftn_begin()
do while (family_iter /= e)
call family_iter%next()
v_pt => family_iter%first()
family => family_iter%second()

if (v_pt%get_comp_name() /= '') cycle
if (.not. family%has_primary()) cycle
primary => family%get_primary()

if (primary%has_producer() .and. .not. primary%has_consumers()) then
wrapper%ptr => primary%get_producer()
call import_couplers%push_back(wrapper)
end do
end if

end do
end associate

end function get_import_couplers

! Repeatedly extend family at v_pt until extension can directly
Expand Down
Loading

0 comments on commit 47b57e0

Please sign in to comment.