StateItemExtension.F90 Source File

#include "MAPL_Generic.h"

module mapl3g_StateItemExtension
   use mapl3g_StateItemSpec
   use mapl3g_ComponentDriver
   use mapl3g_GriddedComponentDriver
   use mapl3g_ComponentDriverVector
   use mapl3g_ComponentDriverVector
   use mapl3g_ExtensionAction
   use mapl3g_GenericCoupler
   use mapl3g_StateItemAspect
   use mapl3g_MultiState
   use mapl_ErrorHandling
   use gftl2_StringVector
   use esmf
   implicit none
   private

   public :: StateItemExtension
   public :: StateItemExtensionPtr

   ! A StateItemExtension "owns" a spec as well as the coupler
   ! that produces it (if any).

   type StateItemExtension
      private
      class(StateItemSpec), allocatable :: spec
      type(ComponentDriverVector) :: consumers ! couplers that depend on spec
      class(ComponentDriver), pointer :: producer => null() ! coupler that computes spec
   contains
      procedure :: get_spec

      procedure :: has_producer
      procedure :: get_producer
      procedure :: set_producer

      procedure :: has_consumers
      procedure :: add_consumer
      procedure :: get_consumers

      procedure :: make_extension
   end type StateItemExtension

   type :: StateItemExtensionPtr
      type(StateItemExtension), pointer :: ptr => null()
   end type StateItemExtensionPtr

   interface StateItemExtension
      procedure :: new_StateItemExtension_spec
   end interface StateItemExtension

contains

   function new_StateItemExtension_spec(spec) result(ext)
      type(StateItemExtension) :: ext
      class(StateItemSpec), intent(in) :: spec
      ext%spec = spec
   end function new_StateItemExtension_spec

   function get_spec(this) result(spec)
      class(StateItemExtension), target, intent(in) :: this
      class(StateItemSpec), pointer :: spec
      spec => this%spec
   end function get_spec

   logical function has_producer(this)
      class(StateItemExtension), target, intent(in) :: this
      has_producer = associated(this%producer)
   end function has_producer

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

      producer => this%producer

   end function get_producer

   subroutine set_producer(this, producer, rc)
      class(StateItemExtension), intent(inout) :: this
      class(ComponentDriver), pointer, 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


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


   function get_consumers(this) result(consumers)
      class(StateItemExtension), target, intent(in) :: this
      type(ComponentDriverVector), pointer :: consumers
      consumers => this%consumers
   end function get_consumers

   function add_consumer(this, consumer) result(reference)
      class(ComponentDriver), pointer :: reference
      class(StateItemExtension), target, intent(inout) :: this
      type(GriddedComponentDriver), intent(in) :: consumer

      call this%consumers%push_back(consumer)
      reference => this%consumers%back()

   end function add_consumer

   ! Creation of an extension requires a new coupler that transforms
   ! from source (this) spec to dest (extension) spec.
   ! This coupler is a "consumer" of the original spec (this), and a "producer" of
   ! the new spec (extension).

   recursive function make_extension(this, goal, rc) result(extension)
      type(StateItemExtension) :: extension
      class(StateItemExtension), target, intent(inout) :: this
      class(StateItemSpec), target, intent(in) :: goal
      integer, intent(out) :: rc

      integer :: status
      integer :: i
      class(StateItemSpec), target, allocatable :: new_spec
      class(ExtensionAction), allocatable :: action
      class(ComponentDriver), pointer :: producer
      class(ComponentDriver), 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


      call this%spec%set_active()

      new_spec = this%spec

      aspect_names = this%spec%get_aspect_order(goal)
      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
            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(action)) then
         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 if

      _RETURN(_SUCCESS)
   end function make_extension

end module mapl3g_StateItemExtension