ESMF_TestCase.F90 Source File

module ESMF_TestCase_mod
   use ESMF
   use ESMF_TestParameter_mod
   use pfunit, only: MpiTestCase, anyExceptions, catch
   use pfunit, only: throw
   use pf_exceptionlist, only: gatherExceptions
   implicit none

   private

   public :: InternalState
   public :: ESMF_TestCase



   type Wrapper
      class (ESMF_TestCase), pointer :: testPtr => null()
   end type Wrapper

   type InternalState
      type (Wrapper), pointer :: wrapped
   end type InternalState

   type, extends(MpiTestCase) :: ESMF_TestCase
      type (InternalState), pointer :: wrapped
      type (ESMF_GridComp), pointer :: gc => null()
      integer :: val = 3
   contains
      procedure :: runBare
      procedure :: setInternalState
      procedure :: clearInternalState
      procedure :: getVM
      procedure :: getPetCount
      procedure :: getLocalPET
      procedure :: barrier
      procedure :: getNumPETsRequested
   end type ESMF_TestCase

contains


   recursive subroutine runBare(this)
      class (ESMF_TestCase), intent(inout) :: this

      ! We need an inner procedure to get the TARGET attribute
      ! added to the TestCase object so that it can be called back from inside the ESMF
      ! gridcomp.  Inelegant but it works around the issue where NAG debug flags do
      ! a copy-in/copy-out which leaves a dangling pointer in the self reference.
      call runbare_inner(this)
   end subroutine runBare
      
   subroutine runbare_inner(this)
      class (ESMF_TestCase), target, intent(inout) :: this
         
      logical :: discard
      type (ESMF_GridComp), target :: gc
      integer :: rc, userRc
      integer :: pet

      ! Gridded component 
      gc = ESMF_GridCompCreate(petList=[(pet,pet=0,this%getNumPETsRequested()-1)], rc=rc)
      if (rc /= ESMF_SUCCESS) call throw('Insufficient PETs for request')

      this%gc => gc
      this%val = 4

      call this%setInternalState(gc,rc=rc)
      if (rc /= ESMF_SUCCESS) call throw('Insufficient PETs for request')

      ! create subcommunicator
      this%context = this%parentContext%makeSubcontext(this%getNumPETsRequested())

      if (.not. anyExceptions(this%parentContext)) then
         if (this%context%isActive()) then
            call ESMF_GridCompInitialize(gc, userRc=userRc, rc=rc)
            if (userRc /= ESMF_SUCCESS) call throw('ESMF_TestCase::initialize() failed.')
            if (rc /= ESMF_SUCCESS) call throw('Failure in ESMF_GridCompInitialize()')

            if (.not. anyExceptions(this%context)) then
               call ESMF_GridCompRun(gc, userRc=userRc, rc=rc)
               if (userRc /= ESMF_SUCCESS) call throw('ESMF_TestCase::run() failed.')
               if (rc /= ESMF_SUCCESS) call throw('Failure in ESMF_GridCompRun()')
               call ESMF_GridCompFinalize(gc, userRc=userRc, rc=rc)
               if (userRc /= ESMF_SUCCESS) call throw('ESMF_TestCase::finalize() failed.')
               if (rc /= ESMF_SUCCESS) call throw('Failure in ESMF_GridCompFinalize()')
            end if
         end if
      else
         ! only report context failure on root PE
         if (.not. this%parentContext%isRootProcess()) then
            discard = catch()
            if (.false.) print*,shape(discard)
         end if
      end if

      call gatherExceptions(this%parentContext)

      call this%clearInternalState(gc, rc=rc)
      if (rc /= ESMF_SUCCESS) call throw('Failure clearing internal state')

   end subroutine runbare_inner

   subroutine setInternalState(this, gc, rc)
      class (ESMF_TestCase), target, intent(inout) :: this
      type (ESMF_GridComp), intent(inout) :: gc
      integer, intent(out) :: rc

      integer :: status

      allocate(this%wrapped) ! note this is a memory leak.
      allocate(this%wrapped%wrapped) ! note this is a memory leak.
      this%wrapped%wrapped%testPtr => this

      ! Note - this%wrapped%wrapped%testPtr must be set outside. Cannot at target attribute to this
      ! interface.
      call ESMF_GridCompSetServices(gc, setServices, rc=status)
      if (status /= ESMF_SUCCESS) then
         rc = status
         return
      end if
      call ESMF_GridCompSetInternalState(gc, this%wrapped, status)
      if (status /= ESMF_SUCCESS) then
         rc = status
         return
      end if
      rc = ESMF_SUCCESS

   end subroutine setInternalState

   subroutine clearInternalState(this, gc, rc)
      class (ESMF_TestCase), intent(inout) :: this
      type (ESMF_GridComp), intent(inout) :: gc
      integer, intent(out) :: rc

      integer :: status

      deallocate(this%wrapped%wrapped)
      deallocate(this%wrapped)

!!$      call ESMF_GridCompDestroy(gc, rc=status)
!!$      if (status /= ESMF_SUCCESS) then
!!$         rc = status
!!$         return
!!$      end if
      rc = ESMF_SUCCESS

   end subroutine clearInternalState

   subroutine initialize(comp, importState, exportState, clock, rc)
      type(ESMF_GridComp) :: comp
      type(ESMF_State) :: importState            ! must not be optional
      type(ESMF_State) :: exportState            ! must not be optional
      type(ESMF_Clock) :: clock                  ! must not be optional
      integer, intent(out)  :: rc                ! must not be optional

      type (InternalState), target :: wrap
      class (ESMF_TestCase), pointer :: testPtr
      integer :: finalrc

      ! To prevent "unused variable" warnings, we do something useless here.
      if (.false.) print*,shape(importState)
      if (.false.) print*,shape(exportState)
      if (.false.) print*,shape(clock)

      ! Get Internal State
      call ESMF_GridCompGetInternalState(comp, wrap, rc)
      if (rc .ne. ESMF_SUCCESS) then
         finalrc = ESMF_FAILURE
      else
         finalrc = ESMF_SUCCESS
      end if

      ! Access private data block and verify data
      testPtr => wrap%wrapped%testPtr
      
      call testPtr%setUp()
   
      rc = finalrc

   end subroutine initialize


   subroutine run(comp, importState, exportState, clock, rc)
      type(ESMF_GridComp)   :: comp                   ! must not be optional
      type(ESMF_State)      :: importState            ! must not be optional
      type(ESMF_State)      :: exportState            ! must not be optional
      type(ESMF_Clock)      :: clock                  ! must not be optional
      integer, intent(out)  :: rc                     ! must not be optional

      type (InternalState) :: wrap
      class (ESMF_TestCase), pointer :: testPtr

      integer :: finalrc

      ! To prevent "unused variable" warnings, we do something useless here.
      if (.false.) print*,shape(importState)
      if (.false.) print*,shape(exportState)
      if (.false.) print*,shape(clock)

      call ESMF_GridCompGetInternalState(comp, wrap, rc)
      if (rc .ne. ESMF_SUCCESS) then
         finalrc = ESMF_FAILURE
      else
         finalrc = ESMF_SUCCESS
      end if

      ! Access private data block and verify data
      testPtr => wrap%wrapped%testPtr 
      call testPtr%runMethod()

      rc = finalRc

   end subroutine run


   subroutine finalize(comp, importState, exportState, clock, rc)
      type(ESMF_GridComp)   :: comp                   ! must not be optional
      type(ESMF_State)      :: importState            ! must not be optional
      type(ESMF_State)      :: exportState            ! must not be optional
      type(ESMF_Clock)      :: clock                  ! must not be optional
      integer, intent(out)  :: rc                     ! must not be optional


      type (InternalState) :: wrap
      class (ESMF_TestCase), pointer :: testPtr
      integer :: finalrc

      ! To prevent "unused variable" warnings, we do something useless here.
      if (.false.) print*,shape(importState)
      if (.false.) print*,shape(exportState)
      if (.false.) print*,shape(clock)

      ! This is where the model specific computation goes.

      call ESMF_GridCompGetInternalState(comp, wrap, rc)
      if (rc .ne. ESMF_SUCCESS) then
         finalrc = ESMF_FAILURE
      else
         finalrc = ESMF_SUCCESS
      end if

      ! Access private data block and verify data
      testPtr => wrap%wrapped%testPtr 
      call testPtr%tearDown()

      rc = finalRc

   end subroutine finalize

  subroutine setServices(comp, rc)
      type(ESMF_GridComp)   :: comp   ! must not be optional
      integer, intent(out)  :: rc     ! must not be optional

      call ESMF_GridCompSetEntryPoint(comp, ESMF_METHOD_INITIALIZE, &
                                userRoutine=initialize, rc=rc)
      call ESMF_GridCompSetEntryPoint(comp, ESMF_METHOD_RUN, &
                                userRoutine=run, rc=rc)
      call ESMF_GridCompSetEntryPoint(comp, ESMF_METHOD_FINALIZE, &
                                userRoutine=finalize, rc=rc)

      rc = ESMF_SUCCESS

   end subroutine setServices

   function getVM(this) result(vm)
      class (ESMF_TestCase), intent(in) :: this
      type (ESMF_VM) :: vm
      integer :: rc

      call ESMF_GridCompGet(this%gc, VM=vm, rc=rc)

   end function getVM

   integer function getPetCount(this) result(petCount)
      class (ESMF_TestCase), intent(in) :: this

      type (ESMF_VM) :: vm
      
      vm = this%getVM()
      call ESMF_VMGet(vm, petCount=petCount)

   end function getPetCount

   integer function getLocalPET(this) result(localPET)
      class (ESMF_TestCase), intent(in) :: this

      type (ESMF_VM) :: vm
      
      vm = this%getVM()
      call ESMF_VMGet(vm, localPET=localPET)

   end function getLocalPET


   subroutine barrier(this)
      class (ESMF_TestCase), intent(in) :: this

      type (ESMF_VM) :: vm
      
      vm = this%getVM()
      call ESMF_VMBarrier(vm)

   end subroutine barrier

   
   integer function getNumPETsRequested(this) result(numPETsRequested)
      class (ESMF_TestCase), intent(in) :: this
      select type (p => this%testParameter)
      class is (ESMF_TestParameter)
         numPETsRequested = p%getNumPETsRequested()
      class default
         numPETsRequested = 0
         call throw('Incorrect type of test parameter in ESMF_TestCase::getNumPETsRequested()')
      end select
   end function getNumPETsRequested


end module ESMF_TestCase_mod