Test_Scenarios.pf Source File

#include "MAPL_TestErr.h"

module Test_Scenarios
   use mapl3g_Generic
   use mapl3g_GenericPhases
   use mapl3g_MultiState
   use mapl3g_OuterMetaComponent
   use mapl3g_GriddedComponentDriver
   use mapl3g_GenericGridComp, generic_setservices => setservices
   use mapl3g_UserSetServices
   use mapl3g_ESMF_Utilities
   use esmf
   use nuopc
   ! testing framework
   use ESMF_TestCase_mod
   use ESMF_TestParameter_mod
   use funit
   implicit none


   abstract interface
      subroutine I_check_stateitem(expectations, state, short_name, description, rc)
         import ESMF_HConfig, ESMF_State
         type(ESMF_HConfig), intent(in) :: expectations
         type(ESMF_State), intent(inout) :: state
         character(*), intent(in) :: short_name
         character(*), intent(in) :: description
         integer, intent(out) :: rc
      end subroutine I_check_stateitem
   end interface

   @testParameter
   type, extends(ESMF_TestParameter) :: ScenarioDescription
      character(:), allocatable :: name
      character(:), allocatable :: root
      character(:), allocatable :: check_name
      procedure(I_check_stateitem), nopass, pointer :: check_stateitem
   contains
      procedure :: tostring => tostring_description
   end type ScenarioDescription


   @testCase(constructor=Scenario, testParameters={get_parameters()})
   type, extends(ESMF_TestCase) :: Scenario
      character(:), allocatable :: scenario_name
      character(:), allocatable :: scenario_root
      character(:), allocatable :: check_name
      procedure(I_check_stateitem), nopass, pointer :: check_stateitem

      type(ESMF_HConfig), allocatable :: expectations
      type(ESMF_GridComp) :: outer_gc
      type(MultiState) :: outer_states
      type(ESMF_Grid) :: grid
   contains
      procedure :: setup
      procedure :: tearDown
   end type Scenario


   interface Scenario
      procedure :: new_Scenario
   end interface


   interface ScenarioDescription
      procedure :: new_ScenarioDescription
   end interface

contains

   function new_Scenario(desc) result(s)
      type(ScenarioDescription), intent(in) :: desc
      type(Scenario) :: s
      s%scenario_name = desc%name
      s%scenario_root = desc%root
      s%check_name = desc%check_name
      s%check_stateitem => desc%check_stateitem
   end function new_Scenario

   function new_ScenarioDescription(name, root, check_name, check_stateitem) result(s)
      type(ScenarioDescription) :: s
      character(*), intent(in) :: name
      character(*), intent(in) :: root
      character(*), intent(in) :: check_name
      procedure(I_check_stateitem) :: check_stateitem
      s%name = name
      s%root = root
      s%check_name = check_name
      s%check_stateitem => check_stateitem

      call s%setNumPETsRequested(1)
   end function new_ScenarioDescription

   function get_parameters() result(params)
      type(ScenarioDescription), allocatable :: params(:)

      params = [ScenarioDescription:: ]
      
      ! Field oriented tests
      params = [params, add_params('item exist', check_item_type)]
      params = [params, add_params('field status', check_field_status)]
      params = [params, add_params('field typekind', check_field_typekind)]
      params = [params, add_params('field value', check_field_value)]
      params = [params, add_params('field exists', check_field_rank)]
      
      ! Service oriented tests
      params = [params, ScenarioDescription('service_service', 'parent.yaml', 'field count', check_fieldcount)]
      
   contains

      function add_params(check_name, check_stateitem) result(params)
         type(ScenarioDescription), allocatable :: params(:)
         character(*), intent(in) :: check_name
         procedure(I_check_stateitem) :: check_stateitem
      
         params = [ &
              ScenarioDescription('scenario_1',              'parent.yaml',      check_name, check_stateitem), &
              ScenarioDescription('scenario_2',              'parent.yaml',      check_name, check_stateitem), &
              ScenarioDescription('scenario_reexport_twice', 'grandparent.yaml', check_name, check_stateitem), &
              ScenarioDescription('history_1',               'cap.yaml',         check_name, check_stateitem), &
              ScenarioDescription('history_wildcard',        'cap.yaml',         check_name, check_stateitem), &
              ScenarioDescription('extdata_1',               'cap.yaml',         check_name, check_stateitem), &
              ScenarioDescription('precision_extension',     'parent.yaml',      check_name, check_stateitem), &
              ScenarioDescription('precision_extension_3d',  'parent.yaml',      check_name, check_stateitem), &
              ScenarioDescription('3d_specs',                'parent.yaml',      check_name, check_stateitem), & 
              ScenarioDescription('ungridded_dims',          'parent.yaml',      check_name, check_stateitem), &
              ScenarioDescription('service_service',         'parent.yaml',      check_name, check_stateitem), &
              ScenarioDescription('export_dependency',       'parent.yaml',      check_name, check_stateitem), &
              ScenarioDescription('regrid',                  'cap.yaml',         check_name, check_stateitem), &
              ScenarioDescription('propagate_geom',          'parent.yaml',      check_name, check_stateitem) &
      ]
      end function add_params
   end function get_parameters


   subroutine setup(this)
      class(Scenario), intent(inout) :: this

      type(ESMF_HConfig) :: config
      integer :: status, user_status
      integer :: i
      type(ESMF_State) :: importState, exportState
      character(:), allocatable :: file_name
      type(ESMF_Time) :: t
      type(ESMF_TimeInterval) :: dt
      type(ESMF_Clock) :: clock

      file_name = './scenarios/' // this%scenario_name // '/' // this%scenario_root
      config = ESMF_HConfigCreate(filename=file_name)

      call NUOPC_FieldDictionarySetup(filename='./scenarios/FieldDictionary.yml', _RC)
      @assert_that(status, is(0))


      associate (outer_gc => this%outer_gc, outer_states => this%outer_states, grid => this%grid)

        call ESMF_TimeSet(t, h=0)
        call ESMF_TimeIntervalSet(dt, h=1)
        clock = ESMF_ClockCreate(dt, t)

        outer_gc = create_grid_comp('ROOT', user_setservices('libsimple_parent_gridcomp'), config, clock, _RC)
        call ESMF_GridCompSetServices(outer_gc, generic_setServices, userRC=user_status, _RC)
        _VERIFY(user_status)

        importState = ESMF_StateCreate(_RC)
        exportState = ESMF_StateCreate(_RC)
        outer_states = MultiState(importState=importState, exportState=exportState)

        do i = 1, size(GENERIC_INIT_PHASE_SEQUENCE)
           associate (phase => GENERIC_INIT_PHASE_SEQUENCE(i))
             call ESMF_GridCompInitialize(outer_gc, &
                  importState=importState, exportState=exportState, clock=clock, &
                  phase=phase, userRC=user_status, _RC)
             _VERIFY(user_status)
           end associate
        end do

           call ESMF_GridCompRun(outer_gc, & 
                  importState=importState, exportState=exportState, clock=clock, &
                  userRC=user_status, phase=GENERIC_RUN_USER, _RC)
           _VERIFY(user_status)

      end associate

      file_name = './scenarios/' // this%scenario_name // '/expectations.yaml'
      this%expectations = ESMF_HConfigCreate(filename=file_name, _RC)

   end subroutine setup

   ! In theory we want to call finalize here and then destroy ESMF objects in this
   subroutine teardown(this)
      class(Scenario), intent(inout) :: this

      integer :: status

!#      call ESMF_GridCompDestroy(this%outer_gc, _RC)

!#      call ESMF_StateDestroy(this%outer_states%importState,_RC)
!#      call ESMF_StateDestroy(this%outer_states%exportState, _RC)
      
   end subroutine teardown

   @test
   subroutine test_anything(this)
      class(Scenario), intent(inout) :: this

      integer :: status
      integer :: i
      character(:), allocatable :: comp_path, item_name
      type(ESMF_HConfig) :: comp_expectations, expected_properties
      type(MultiState) :: comp_states
      type(ESMF_HConfig) :: state_items
      integer :: item_count, expected_item_count
      type(ESMF_Field) :: field
      type(ESMF_FieldStatus_Flag) :: expected_field_status, field_status
      character(:), allocatable :: expected_status

     components: do i = 1, ESMF_HConfigGetSize(this%expectations)

         comp_expectations = ESMF_HConfigCreateAt(this%expectations,index=i,_RC)
         comp_path = ESMF_HConfigAsString(comp_expectations,keyString='component',_RC)
         call get_substates(this%outer_gc, this%outer_states, comp_path, substates=comp_states, _RC)

         call check_items_in_state('import', _RC)
         call check_items_in_state('export', _RC)
         call check_items_in_state('internal', _RC)
            
      end do components

   contains

     subroutine check_items_in_state(state_intent, rc)
         character(*), intent(in) :: state_intent
         integer, intent(out) :: rc

         integer :: status
         type(ESMF_HConfig) :: state_items
         type(ESMF_State) :: state
         character(:), allocatable :: msg
         type(ESMF_HConfigIter) :: hconfigIter,hconfigIterBegin,hconfigIterEnd

         rc = -1

         if (.not. ESMF_HConfigIsDefined(comp_expectations,keyString=state_intent)) then
            rc = 0 ! that's ok
            return
         end if

         call comp_states%get_state(state, state_intent, _RC)

         
         msg = comp_path // '::' // state_intent

         state_items = ESMF_HConfigCreateAt(comp_expectations,keyString=state_intent,_RC)
         @assertTrue(ESMF_HConfigIsMap(state_items), msg)


         hconfigIter = ESMF_HConfigIterBegin(state_items)
         hconfigIterBegin = ESMF_HConfigIterBegin(state_items)
         hconfigIterEnd = ESMF_HConfigIterEnd(state_items)
         do while (ESMF_HConfigIterLoop(hconfigIter,hconfigIterBegin,hconfigIterEnd))
            item_name = ESMF_HConfigAsStringMapKey(hconfigIter,_RC)
            expected_properties = ESMF_HConfigCreateAtMapVal(hconfigIter,_RC)

             msg = comp_path // '::' // state_intent // '::' // item_name

             associate (test_description => msg // '::' // this%check_name)
               call this%check_stateitem(expected_properties, state, item_name, test_description, _RC)
             end associate
              
           end do

         rc = 0

      end subroutine check_items_in_state
      
   end subroutine test_anything


   function get_itemtype(state, short_name, rc) result(itemtype)
      type(ESMF_StateItem_Flag) :: itemtype
      type(ESMF_State) :: state
      character(*), intent(in) :: short_name
      integer, intent(out) :: rc

      integer :: status
      integer :: idx
      type(ESMF_State) :: substate, tmp_state
      character(:), allocatable :: name

      integer :: itemcount
      
      rc = 0
      name = short_name
      substate = state

      do
         idx = index(name, '/')
         if (idx == 0) then
            call ESMF_StateGet(substate, name, itemtype=itemtype, _RC)
            return
         end if
         call ESMF_StateGet(substate, name(:idx-1), tmp_state, rc=status)
         @assert_that(short_name, status, is(0))
         name = name(idx+1:)
         substate = tmp_state
      end do

      rc = 0
   end function get_itemtype

   subroutine check_item_type(expectations, state, short_name, description, rc)
      type(ESMF_HConfig), intent(in) :: expectations
      type(ESMF_State), intent(inout) :: state
      character(*), intent(in) :: short_name
      character(*), intent(in) :: description
      integer, intent(out) :: rc

      type(ESMF_StateItem_Flag) :: expected_itemtype, itemtype
      character(len=:), allocatable :: msg
      integer :: status
      integer :: idx

      msg = description
      expected_itemtype = get_expected_itemtype(expectations, _RC)

      itemtype = get_itemtype(state, short_name, _RC)
      @assert_that(msg // ':: check item type of '//short_name, expected_itemtype == itemtype, is(true()))

      rc = 0

   contains

      function get_expected_itemtype(expectations, rc) result(expected_itemtype)
         type(ESMF_StateItem_Flag) :: expected_itemtype
         type(ESMF_HConfig), intent(in) :: expectations
         integer, intent(out) :: rc

         character(:), allocatable :: itemtype_str
         integer :: status

         if (.not. ESMF_HConfigIsDefined(expectations,keyString='class')) then
            expected_itemtype = ESMF_STATEITEM_FIELD
            rc=0
            return
         end if

         itemtype_str= ESMF_HConfigAsString(expectations,keyString='class',_RC)
         
         select case (itemtype_str)
         case ('field')
            expected_itemtype = ESMF_STATEITEM_FIELD
         case ('bundle')
            expected_itemtype = ESMF_STATEITEM_FIELDBUNDLE
         case default
            expected_itemtype = ESMF_STATEITEM_UNKNOWN
         end select

         rc = 0
         
      end function get_expected_itemtype
         
   end subroutine check_item_type
      
   subroutine check_field_status(expectations, state, short_name, description, rc)
      type(ESMF_HConfig), intent(in) :: expectations
      type(ESMF_State), intent(inout) :: state
      character(*), intent(in) :: short_name
      character(*), intent(in) :: description
      integer, intent(out) :: rc

      character(len=:), allocatable :: expected_field_status_str
      type(ESMF_FieldStatus_Flag) :: expected_field_status
      type(ESMF_FieldStatus_Flag) :: found_field_status
      type(ESMF_StateItem_Flag) :: itemtype
      type(ESMF_Field) :: field
      integer :: status
      character(len=:), allocatable :: msg


      msg = short_name // ':: '// description

      call ESMF_StateGet(state, short_name, itemtype=itemtype, _RC)
      if (itemtype /= ESMF_STATEITEM_FIELD) then
         rc = 0
         return
      end if

      expected_field_status_str = ESMF_HConfigAsString(expectations,keyString='status',_RC)
      expected_field_status = ESMF_FIELDSTATUS_GRIDSET
      select case (expected_field_status_str)
      case ('complete')
         expected_field_status = ESMF_FIELDSTATUS_COMPLETE
      case ('gridset')
         expected_field_status = ESMF_FIELDSTATUS_GRIDSET
      case ('empty')
         expected_field_status = ESMF_FIELDSTATUS_EMPTY
      case default
         _VERIFY(-1)
      end select

      call ESMF_StateGet(state, short_name, field, _RC)
      call ESMF_FieldGet(field, status=found_field_status, _RC)
      @assert_that(msg // ' field status: ',expected_field_status == found_field_status, is(true()))

      rc = 0
   end subroutine check_field_status
      
   subroutine check_field_typekind(expectations, state, short_name, description, rc)
      type(ESMF_HConfig), intent(in) :: expectations
      type(ESMF_State), intent(inout) :: state
      character(*), intent(in) :: short_name
      character(*), intent(in) :: description
      integer, intent(out) :: rc

      character(len=:), allocatable :: expected_field_typekind_str
      type(ESMF_TypeKind_Flag) :: expected_field_typekind
      type(ESMF_TypeKind_Flag) :: found_field_typekind
      type(ESMF_StateItem_Flag) :: itemtype
      integer :: status
      character(len=:), allocatable :: msg
      type(ESMF_Field) :: field

      msg = description

      call ESMF_StateGet(state, short_name, itemtype=itemtype, _RC)
      if (itemtype /= ESMF_STATEITEM_FIELD) then
         rc = 0
         return
      end if


      if (.not. ESMF_HConfigIsDefined(expectations,keyString='typekind')) then
         rc = 0
         return
      end if

      expected_field_typekind_str = ESMF_HConfigAsString(expectations,keyString='typekind',_RC)
      select case (expected_field_typekind_str)
      case ('R4')
         expected_field_typekind = ESMF_TYPEKIND_R4
      case ('R8')
         expected_field_typekind = ESMF_TYPEKIND_R8
      case default
         _VERIFY(-1)
      end select
      
      call ESMF_StateGet(state, short_name, field, _RC)
      call ESMF_FieldGet(field, typekind=found_field_typekind, _RC)
      @assert_that(msg // ' field typekind: ',expected_field_typekind == found_field_typekind, is(true()))

      rc = 0
   end subroutine check_field_typekind
      
   subroutine check_field_value(expectations, state, short_name, description, rc)
      type(ESMF_HConfig), intent(in) :: expectations
      type(ESMF_State), intent(inout) :: state
      character(*), intent(in) :: short_name
      character(*), intent(in) :: description
      integer, intent(out) :: rc

      character(len=:), allocatable :: expected_field_typekind_str
      real :: expected_field_value
      integer :: rank
      type(ESMF_TypeKind_Flag) :: typekind
      integer :: status
      character(len=:), allocatable :: msg
      type(ESMF_Field) :: field
      type(ESMF_StateItem_Flag) :: itemtype

      msg = description

      itemtype = get_itemtype(state, short_name, _RC)
      if (itemtype /= ESMF_STATEITEM_FIELD) then ! that's ok
         rc = 0
         return
      end if

     if (.not. ESMF_HConfigIsDefined(expectations,keyString='value')) then 
         rc = 0
         return
      end if

      expected_field_value = ESMF_HConfigAsR4(expectations,keyString='value',_RC)

      call ESMF_StateGet(state, short_name, field, _RC)
      call ESMF_FieldGet(field, typekind=typekind, rank=rank, rc=status)
      @assert_that('field get failed '//short_name,  status, is(0))

      if (typekind == ESMF_TYPEKIND_R4) then
         block
           real(kind=ESMF_KIND_R4), pointer :: x2(:,:),x3(:,:,:),x4(:,:,:,:)
           select case(rank)
           case(2)
              call ESMF_FieldGet(field, farrayptr=x2, _RC)
              @assert_that('value of '//short_name, all(x2 == expected_field_value), is(true()))
           case(3)
              call ESMF_FieldGet(field, farrayptr=x3, _RC)
              @assert_that('value of '//short_name, all(x3 == expected_field_value), is(true()))
           case(4)
              call ESMF_FieldGet(field, farrayptr=x4, _RC)
              @assert_that('value of '//short_name, all(x4 == expected_field_value), is(true()))
           end select
         end block
      elseif (typekind == ESMF_TYPEKIND_R8) then
         block
           real(kind=ESMF_KIND_R8), pointer :: x2(:,:),x3(:,:,:),x4(:,:,:,:)
           select case(rank)
           case(2)
              call ESMF_FieldGet(field, farrayptr=x2, _RC)
              @assert_that('value of '//short_name, all(x2 == expected_field_value), is(true()))
           case(3)
              call ESMF_FieldGet(field, farrayptr=x3, _RC)
              @assert_that('value of '//short_name, all(x3 == expected_field_value), is(true()))
           case(4)
              call ESMF_FieldGet(field, farrayptr=x4, _RC)
              @assert_that('value of '//short_name, all(x4 == expected_field_value), is(true()))
           end select
         end block
      else
         _VERIFY(-1)
      end if

      rc = 0
   end subroutine check_field_value

   subroutine check_field_rank(expectations, state, short_name, description, rc)
      type(ESMF_HConfig), intent(in) :: expectations
      type(ESMF_State), intent(inout) :: state
      character(*), intent(in) :: short_name
      character(*), intent(in) :: description
      integer, intent(out) :: rc

      type(ESMF_Field) :: field
      integer :: expected_field_rank
      integer :: rank
      integer :: status
      type(ESMF_StateItem_Flag) :: itemtype
      character(len=:), allocatable :: msg

      msg = description

      if (.not. ESMF_HConfigIsDefined(expectations,keyString='rank')) then
         rc = 0
         return
      end if

      call ESMF_StateGet(state, short_name, itemtype=itemtype)
      if (itemtype /= ESMF_STATEITEM_FIELD) then ! that's ok
         rc = 0
         return
      end if

      call ESMF_StateGet(state, short_name, field, _RC)
      call ESMF_FieldGet(field, rank=rank, _RC)

      expected_field_rank = ESMF_HConfigAsI4(expectations,keyString='rank',_RC)
      @assert_that(msg // 'field rank:', rank == expected_field_rank, is(true()))

      rc = 0
   end subroutine check_field_rank

   subroutine check_fieldCount(expectations, state, short_name, description, rc)
      type(ESMF_HConfig), intent(in) :: expectations
      type(ESMF_State), intent(inout) :: state
      character(*), intent(in) :: short_name
      character(*), intent(in) :: description
      integer, intent(out) :: rc

      integer :: status
      character(len=:), allocatable :: msg
      integer :: found_fieldCount, expected_fieldCount
      type(ESMF_FieldBundle) :: bundle
      type(ESMF_StateItem_Flag) :: itemtype

      msg = description

      rc = 0

      call ESMF_StateGet(state, short_name, itemtype=itemtype)
      if (itemtype /= ESMF_STATEITEM_FIELDBUNDLE) return ! that's ok

      if (.not. ESMF_HConfigIsDefined(expectations,keyString='fieldcount')) return

      expected_fieldCount = ESMF_HConfigAsI4(expectations,keyString='fieldcount',_RC)
      call ESMF_StateGet(state, short_name, bundle, _RC)
      call ESMF_FieldBundleGet(bundle, fieldCount=found_fieldCount, _RC)

      @assert_that(found_fieldCount, is(expected_fieldCount))
      
   end subroutine check_fieldCount


   recursive subroutine get_substates(gc, states, component_path, substates, rc)
      use mapl3g_GriddedComponentDriver
      type(ESMF_GridComp), target, intent(inout) :: gc
      type(MultiState), intent(in) :: states
      character(*), intent(in) :: component_path
      type(MultiState), intent(out) :: substates
      integer, intent(out) :: rc

      integer :: status
      character(:), allocatable :: child_name
      type(GriddedComponentDriver) :: child
      type(ESMF_GridComp) :: child_gc
      type(OuterMetaComponent), pointer :: outer_meta
      integer :: idx
      type(GriddedComponentDriver), pointer :: user_component

      rc = 0

      if (component_path == '<root>' .or. component_path == '') then
         substates = states
         return
      end if

      outer_meta => get_outer_meta(gc, _RC)

      ! Parse path
      idx = index(component_path, '/')
      if (idx == 0) idx = len(component_path) + 1
      child_name = component_path(:idx-1)
      
      if (child_name == '<user>') then
         user_component => outer_meta%get_user_gc_driver()
         substates = user_component%get_states()
         return
      end if

      ! Otherwise drill down 1 level.
      child = outer_meta%get_child(child_name, _RC)

      child_gc = child%get_gridcomp()

      call get_substates(child_gc, child%get_states(), component_path(idx+1:), &
           substates, _RC)

      return
   end subroutine get_substates


   function tostring_description(this) result(s)
      character(:), allocatable :: s
      class(ScenarioDescription), intent(in) :: this

      s = this%name
   end function tostring_description


   recursive function num_fields(state, rc) result(n)
      integer :: n
      type(ESMF_State), intent(inout) :: state
      integer, optional, intent(out) :: rc

      integer :: status
      integer :: itemCount, i
      character(ESMF_MAXSTR), allocatable :: itemNameList(:)
      type(ESMF_StateItem_Flag) :: itemType
      type(ESMF_State) :: substate

      n = 0 ! default

      call ESMF_StateGet(state, itemCount=itemCount, _RC)
      allocate(itemNameList(itemCount))
      call ESMF_StateGet(state, itemNameList=itemNameList, _RC)
      
      do i = 1, itemCount
         call ESMF_StateGet(state, itemName=trim(itemNameList(i)), itemType=itemType, _RC)

         if (itemType == ESMF_STATEITEM_FIELD) then
            n = n + 1
         elseif (itemType == ESMF_STATEITEM_STATE) then
            call ESMF_StateGet(state, trim(itemNameList(i)), substate, _RC)
            n = n + num_fields(substate, _RC)
         end if

      end do

      return
   end function num_fields
   

end module Test_Scenarios