MPAS Init Atm Core with tests for mpas_stack.F

mpas_init_atm_core.F

! Copyright (c) 2013,  Los Alamos National Security, LLC (LANS)
! and the University Corporation for Atmospheric Research (UCAR).
!
! Unless noted otherwise source code is licensed under the BSD license.
! Additional copyright and license information can be found in the LICENSE file
! distributed with this code, or at http://mpas-dev.github.com/license.html
!
module init_atm_core

   use mpas_stack 
   use mpas_kind_types

   ! Stack payload to hold a cell
   type, extends(mpas_stack_payload_type) :: cell_t
      integer :: id
      real(kind=RKIND) :: lat
      real(kind=RKIND) :: lon
   end type cell_t

   contains


   function init_atm_core_init(domain, startTimeStamp) result(ierr)
   
      use mpas_derived_types
      use mpas_stream_manager
      use mpas_io_streams, only : MPAS_STREAM_NEAREST
      use init_atm_cases
   
      implicit none
   
      type (domain_type), intent(inout) :: domain
      character(len=*), intent(out) :: startTimeStamp

      type (block_type), pointer :: block
      type (mpas_pool_type), pointer :: state, mesh 
      character (len=StrKIND), pointer :: xtime
      character (len=StrKIND), pointer :: initial_time
      character (len=StrKIND), pointer :: config_start_time
      real (kind=RKIND), pointer :: sphere_radius
      integer :: ierr


      ierr = 0

      block => domain % blocklist
      do while (associated(block))
         call mpas_pool_get_subpool(block % structs, 'state', state)
         call mpas_pool_get_subpool(block % structs, 'mesh', mesh)
         call mpas_pool_get_array(state, 'xtime', xtime)
         call mpas_pool_get_array(state, 'initial_time', initial_time)
         call mpas_pool_get_config(mesh, 'sphere_radius', sphere_radius)
         call mpas_pool_get_config(block % configs, 'config_start_time', config_start_time)

         startTimeStamp = config_start_time
         xtime = config_start_time
         initial_time = config_start_time
         domain % sphere_radius = a      ! Appears in output files
         sphere_radius = a               ! Used in setting up test cases

         block => block % next
      end do 

      call MPAS_stream_mgr_add_att(domain % streamManager, 'sphere_radius', domain % sphere_radius, streamID='output', ierr=ierr)
      call MPAS_stream_mgr_add_att(domain % streamManager, 'sphere_radius', domain % sphere_radius, streamID='surface', ierr=ierr)

      !
      ! We don't actually expect the time in the (most likely 'static') file to
      !    match the time in the namelist, so just read whatever time we find in
      !    the input file.
      !
      call MPAS_stream_mgr_read(domain % streamManager, whence=MPAS_STREAM_NEAREST, ierr=ierr)
      call MPAS_stream_mgr_reset_alarms(domain % streamManager, direction=MPAS_STREAM_INPUT, ierr=ierr)

   end function init_atm_core_init
   
   
   function init_atm_core_run(domain) result(ierr)
   
      use mpas_derived_types
      use mpas_stream_manager
      use mpas_timer
      use init_atm_cases
      use mpas_pool_routines
      use mpas_stack
   
      implicit none


      type (domain_type), intent(inout) :: domain
      type (block_type), pointer :: block_ptr
      type (mpas_pool_type), pointer :: mesh

      type(mpas_stack_type), pointer :: stack
      class(cell_t), pointer :: cell, res
      real(kind=RKIND), dimension(:), pointer :: latCell
      real(kind=RKIND), dimension(:), pointer :: lonCell
      integer, pointer :: nCells
      integer :: i
      integer :: ierr

      ierr = 0

      call mpas_log_write('====================================================================')
      call mpas_log_write('=================== STARTING TEST OF MPAS_STACK ====================')

      call mpas_pool_get_subpool(domain % blocklist % structs, 'mesh', mesh)
      call mpas_pool_get_dimension(domain % blocklist % dimensions, 'nCells', nCells)
      call mpas_pool_get_array(mesh, 'latCell', latCell)
      call mpas_pool_get_array(mesh, 'lonCell', lonCell)
      
      
      ! Tests to do 

      ! Call stack routines with unassociated stack or unassociated item
      stack => null()
      cell => null()

      stack => mpas_stack_push(stack, cell)
      res => cell_pop(stack)

      if (associated(res)) then
         call mpas_log_write("FAILED - Res was associated but it should have not been", &
                     messageType=MPAS_LOG_ERR)
      endif

      stack => null()
      res => cell_pop(stack)
      if (associated(res)) then
         call mpas_log_write("FAILED - Res was associated but it should have not been", &
                     messageType=MPAS_LOG_ERR)
      endif
      if (associated(stack)) then
         call mpas_log_write("FAILED - Stack was associated but it should have not been", &
                     messageType=MPAS_LOG_ERR)
      endif

      ! mpas_stack_is_empty
      stack => null()
      if (.not. mpas_stack_is_empty(stack)) then
         call mpas_log_write("FAILED - Stack reported that it was not empty", &
                     messageType=MPAS_LOG_ERR)
      endif

      ! mpas_stack_free
      stack => null()
      call mpas_stack_free(stack)
      if (associated(stack)) then
         call mpas_log_write("FAILED - Stack reported not freed succesfully", &
                     messageType=MPAS_LOG_ERR)
      endif

      ! Tests with nCells and latCell, lonCell
      ! See if stack retains the correct order FILO
      do i = 1, nCells
         ! Allocate a payload and initalize it
         allocate(cell)
         cell % id = i
         cell % lat = latCell(i)
         cell % lon = lonCell(i)

         ! Add the item to the stack
         stack => mpas_stack_push(stack, cell)
      enddo

      if (mpas_stack_is_empty(stack)) then
            call mpas_log_write("FAILED - Stack reported to be empty when it should not be empty!", &
                     messageType=MPAS_LOG_ERR)
      endif
   
      do i = 1, nCells
         res => cell_pop(stack)
         
         if (res % id /= nCells - i + 1) then
            call mpas_log_write("FAILED - Did not get the expected cell in the correct order!", &
                     messageType=MPAS_LOG_ERR)
         endif

         if (res % lat /= latCell(nCells - i + 1) .or. res % lon /= lonCell(nCells - i + 1)) then
            call mpas_log_write("FAILED - Did not get the expected lat or lon in the correct order!", &
                     messageType=MPAS_LOG_ERR)
         endif
         deallocate(res)
      enddo

      if (.not. mpas_stack_is_empty(stack)) then
            call mpas_log_write("FAILED - Stack reported to be non-empty when it should be empty!", &
                     messageType=MPAS_LOG_ERR)
      endif

      ! Test free
      do i = 1, nCells
         ! Allocate a payload and initalize it
         allocate(cell)
         cell % id = i
         cell % lat = latCell(i)
         cell % lon = lonCell(i)

         ! Add the item to the stack
         stack => mpas_stack_push(stack, cell)
      enddo
      call mpas_stack_free(stack)

      if (associated(stack)) then
         call mpas_log_write("FAILED - Stack was associated when it should not have been!", &
                  messageType=MPAS_LOG_ERR)
      endif
      
      call mpas_log_write('=================== COMPLETED TEST OF MPAS_STACK ====================')
   
   end function init_atm_core_run
   
   ! My own function to pop off my mpas_stack_type type
   function cell_pop(stack) result(cell)

      implicit none

      type(mpas_stack_type), intent(inout), pointer :: stack
      type(cell_t), pointer :: cell
      class(mpas_stack_payload_type), pointer :: top

      cell => null()
      if (mpas_stack_is_empty(stack)) then
         cell => null()
         return
      endif
   
      top => mpas_stack_pop(stack)
      if (.not. associated(top)) then
         top => null()
         return
      end if
      
      select type(top)
         type is(cell_t)
            cell => top
         class default
            write(0,*) "BEERP!"
            stop
      end select

   end function cell_pop
   
   function init_atm_core_finalize(domain) result(ierr)
   
      use mpas_derived_types
      use mpas_decomp
      use mpas_stream_manager
      use mpas_log, only : mpas_log_write
   
      implicit none
   
      type (domain_type), intent(inout) :: domain 
      integer :: ierr


      ierr = 0

      call mpas_decomp_destroy_decomp_list(domain % decompositions)

      call mpas_log_write('')
      call mpas_log_write('********************************************************')
      call mpas_log_write('   Finished running the init_atmosphere core')
      call mpas_log_write('********************************************************')
   
   end function init_atm_core_finalize
   
end module init_atm_core