transfer_metadata Subroutine

public subroutine transfer_metadata(this)

Type Bound

RegridSupport

Arguments

Type IntentOptional Attributes Name
class(RegridSupport), intent(inout) :: this

Calls

proc~~transfer_metadata~~CallsGraph proc~transfer_metadata RegridSupport%transfer_metadata ESMF_UtilStringLowerCase ESMF_UtilStringLowerCase proc~transfer_metadata->ESMF_UtilStringLowerCase at at proc~transfer_metadata->at begin begin proc~transfer_metadata->begin get get proc~transfer_metadata->get get_index get_index proc~transfer_metadata->get_index interface~mapl_assert MAPL_Assert proc~transfer_metadata->interface~mapl_assert next next proc~transfer_metadata->next none~add_attribute~2 Variable%add_attribute proc~transfer_metadata->none~add_attribute~2 none~add_attribute~3 FileMetadata%add_attribute proc~transfer_metadata->none~add_attribute~3 none~add_dimension FileMetadata%add_dimension proc~transfer_metadata->none~add_dimension none~add_variable FileMetadata%add_variable proc~transfer_metadata->none~add_variable none~at~226 StringAttributeMap%at proc~transfer_metadata->none~at~226 none~begin~52 StringVariableMap%begin proc~transfer_metadata->none~begin~52 none~begin~83 StringAttributeMap%begin proc~transfer_metadata->none~begin~83 none~get_attributes Variable%get_attributes proc~transfer_metadata->none~get_attributes none~get_attributes~2 FileMetadata%get_attributes proc~transfer_metadata->none~get_attributes~2 none~get_dimensions Variable%get_dimensions proc~transfer_metadata->none~get_dimensions none~get_dimensions~2 FileMetadata%get_dimensions proc~transfer_metadata->none~get_dimensions~2 none~get_type Variable%get_type proc~transfer_metadata->none~get_type none~get_value UnlimitedEntity%get_value proc~transfer_metadata->none~get_value none~get_variable FileMetadata%get_variable proc~transfer_metadata->none~get_variable none~get_variables FileMetadata%get_variables proc~transfer_metadata->none~get_variables none~key~117 StringVariableMapIterator%key proc~transfer_metadata->none~key~117 none~key~196 StringAttributeMapIterator%key proc~transfer_metadata->none~key~196 none~next~48 StringVariableMapIterator%next proc~transfer_metadata->none~next~48 none~next~81 StringAttributeMapIterator%next proc~transfer_metadata->none~next~81 proc~mapl_return MAPL_Return proc~transfer_metadata->proc~mapl_return push_back push_back proc~transfer_metadata->push_back

Called by

proc~~transfer_metadata~~CalledByGraph proc~transfer_metadata RegridSupport%transfer_metadata program~main~9 main program~main~9->proc~transfer_metadata

Source Code

   subroutine transfer_metadata(this)!vars)
      class (RegridSupport), intent(inout) :: this

      integer :: status

      call add_grid_dimensions()
      call add_grid_variables()

      call add_global_attributes()
      call add_variables()

   contains

      subroutine add_grid_dimensions()
         integer :: status
         type (StringIntegerMap), pointer :: dims

         dims => this%cfio_cubed_sphere%get_dimensions()

         associate ( ll => this%cfio_lat_lon )
            call ll%add_dimension('lon', this%IM, rc=status)
            call ll%add_dimension('lat', this%JM, rc=status)
            if (associated(dims%at('lev'))) then
               call ll%add_dimension('lev', this%LM, rc=status)
            end if
            call ll%add_dimension('time', this%nt, rc=status)
        end associate

      end subroutine add_grid_dimensions


      subroutine add_grid_variables()
         type (Variable), pointer :: v

         type (Variable) :: tmp
         integer :: status

         associate ( ll => this%cfio_lat_lon, cs => this%cfio_cubed_sphere )

            tmp = Variable(type=pFIO_REAL32, dimensions='lat')
            !call tmp%add_attribute('long_name', Attribute('latitude'))
            call tmp%add_attribute('long_name', 'latitude')
            !call tmp%add_attribute('units', Attribute('degrees_north'))
            call tmp%add_attribute('units', 'degrees_north')
            call ll%add_variable('lat', tmp, rc=status)

            tmp = Variable(type=pFIO_REAL32, dimensions='lon')
            !call tmp%add_attribute('long_name', Attribute('longitudes'))
            call tmp%add_attribute('long_name', 'longitudes')
            !call tmp%add_attribute('units', Attribute('degrees_east'))
            call tmp%add_attribute('units', 'degrees_east')
            call ll%add_variable('lon', tmp, rc=status)

            v => cs%get_variable('lev')
            if (associated(v)) call ll%add_variable('lev', v, rc=status)
            v => cs%get_variable('time')
            call ll%add_variable('time', v, rc=status)

         end associate

      end subroutine add_grid_variables


      subroutine add_global_attributes()
         type (StringAttributeMapIterator) :: iter
         type (StringAttributeMap), pointer :: attributes
         character(len=:), pointer :: name

         type (Attribute), pointer :: attr

         associate ( ll => this%cfio_lat_lon, cs => this%cfio_cubed_sphere )

            attributes => cs%get_attributes()
            iter = attributes%begin()
            do while (iter /= attributes%end())
               name => iter%key()
               attr => iter%value()

               call ll%add_attribute(name, attr)

               call iter%next()
            end do

         end associate

      end subroutine add_global_attributes


      subroutine add_variables()
         type (StringVariableMapIterator) :: var_iter
         type (StringVariableMap), pointer :: variables

         character(len=:), allocatable :: ll_var_dimensions
         character(len=:), pointer :: var_name

         type (Variable), pointer :: cs_variable
         type (StringVector), pointer :: cs_var_dimensions
         type (Variable) :: ll_variable

         associate ( ll => this%cfio_lat_lon, cs => this%cfio_cubed_sphere )

         variables => cs%get_variables()
         var_iter = variables%begin()
         do while (var_iter /= variables%end())
            var_name => var_iter%key()
            select case (var_name)
               ! CS specific variables
            case ('nf', 'ncontact', 'cubed_sphere', &
                 & 'Xdim', 'Ydim', 'lons', 'lats', &
                 & 'contacts', 'orientation', 'anchor', &
                 & 'lev', 'time')
               ! skip CS specific variables
            case default

               if (keep_var(var_name, this%requested_variables)) then

                  cs_variable => var_iter%value()

                  cs_var_dimensions => cs_variable%get_dimensions()
                  ll_var_dimensions = make_dim_string(cs_var_dimensions)

                  if (associated(this%cfio_cubed_sphere%get_variable('lev'))) then
                     ll_variable = Variable(type=cs_variable%get_type(), dimensions=ll_var_dimensions, &
                          & chunksizes = [this%IM/npx,this%JM/npy,1,1,1])
                  else
                     ll_variable = Variable(type=cs_variable%get_type(), dimensions=ll_var_dimensions, &
                          & chunksizes = [this%IM/npx,this%JM/npy,1,1])
                  end if

                  call transfer_attributes(from=cs_variable, to=ll_variable)
                  call ll%add_variable(var_name, ll_variable)

                  call categorize(cs_variable, var_name, variables)

               end if

            end select

            call var_iter%next()
         end do

         end associate

      end subroutine add_variables

      subroutine transfer_attributes(from, to)
         type (Variable), target, intent(in) :: from
         type (Variable), target, intent(inout) :: to

         type (StringAttributeMap), pointer :: attributes
         type (StringAttributeMapIterator) :: attr_iter
         character(len=:), pointer :: attr_name

         attributes => from%get_attributes()
         attr_iter = attributes%begin()
         do while (attr_iter /= attributes%end())
            attr_name => attr_iter%key()
            select case (attr_name)
            case ('grid_mapping','coordinates') ! CS specific attributes
               ! skip
            case default
               associate (val => attr_iter%value())
                  call to%add_attribute(attr_name, val)
               end associate
            end select
            call attr_iter%next()
         end do

      end subroutine transfer_attributes


      ! Is variable a scalar or vector?
      subroutine categorize(var, var_name, vars, rc)
         type (Variable), target, intent(in) :: var
         character(len=*), intent(in) :: var_name
         type (StringVariableMap), target, intent(in) :: vars
         integer, optional, intent(out) :: rc

         type (StringAttributeMap), pointer :: attributes
         type (Attribute), pointer :: long_name_attr
         character(len=:), allocatable :: long_name
         character(len=:), allocatable :: north_component
         integer :: status

         class(*), pointer :: a

         attributes => var%get_attributes()
         long_name_attr => attributes%at('long_name')
         if (.not. associated(long_name_attr)) then
            _RETURN(_SUCCESS)
         end if

         a => long_name_attr%get_value()
         _ASSERT(associated(a),'invalid pointer')
         select type (a)
         type is (character(len=*))
            long_name = ESMF_UtilStringLowerCase(a, rc=STATUS)
         class default
            _FAIL('incorrect type')
         end select

         if (index(long_name, 'east') > 0) then ! East component of a vector
            north_component = find_north_component(vars, long_name)
            _ASSERT(north_component /= '','needs informative message')
            call this%vector_variables(1)%push_back(var_name)
            call this%vector_variables(2)%push_back(north_component)
         elseif (index(long_name, 'north') == 0) then !
            call this%scalar_variables%push_back(var_name)
         end if

      end subroutine categorize


      ! For variables that have 'north' in their long name, we need to
      ! find the corresponding 'east' variable to properly regrid
      ! vector quantities.  The function returns the name of the
      ! corresponding 'north' variable if it exists, otherwise an 0
      ! length string is returned.
      !
      ! NOTE: This routine is called for all variables, not just those
      ! with 'north' in the long name.
      !
      ! The logic is a bit complicated due to the use of unlimited polymorphic
      ! entities to store CFIO attributes.   This means we need to do
      ! SELECT TYPE on each quantity to cast it as a string before we can
      ! compare.
      !
      function find_north_component(vars, long_name, rc) result(north_component)
         character(len=:), allocatable :: north_component
         type (StringVariableMap), target, intent(in) :: vars
         character(len=*), intent(in) :: long_name
         integer, optional, intent(out) :: rc

         type (StringVariableMapIterator) :: var_iter
         type (Variable), pointer :: var
         type (StringAttributeMap), pointer :: attrs
         type (Attribute), pointer :: attr
         character(len=:), allocatable :: trial
         integer :: idx
         class (*), pointer :: a

         north_component = '' ! unless
         var_iter = vars%begin()
         do while (var_iter /= vars%end())
            var => var_iter%value()
            attrs => var%get_attributes()
            attr => attrs%at('long_name')

            if (associated(attr)) then
               a => attr%get_value()
               _ASSERT(associated(a),'invalid pointer')
               select type (a)
               type is (character(len=*))
                  trial = ESMF_UtilStringLowerCase(a, rc=status)
               class default
                  _FAIL('incorrect type')
               end select

               idx = index(trial, 'north')
               if (idx /= 0) then
                  trial = trial(1:idx-1) // 'east' // trial(idx+5:)
                  if (trial == long_name) then ! success
                     north_component = var_iter%key()
                  end if
               end if
            end if
            call var_iter%next()
         end do

      end function find_north_component

      logical function keep_var(var_name, requested_vars)
         character(len=*), intent(in) :: var_name
         type (StringVector), intent(in) :: requested_vars

         if (requested_vars%size() == 0) then
            keep_var = .true.
         else
            keep_var = (requested_vars%get_index(var_name) /= 0)
         end if

      end function keep_var


      ! Convert CS dimensions of a varible into Lat-Lon dimensions.
      ! The former arrive as a StringVector, but this function produces
      ! a string of the form '<d1>,<d2>,...' to mimic the convenient form
      ! for the Variable() constructor.
      function make_dim_string(cs_dims) result(ll_dims)
         character(len=:), allocatable :: ll_dims
         type (StringVector), target, intent(in) :: cs_dims

         type (StringVectorIterator) :: dim_iter
         character(len=:), pointer :: d

         ll_dims = ''
         dim_iter = cs_dims%begin()
         do while (dim_iter /= cs_dims%end())
            d => dim_iter%get()
            select case (d)
            case ('Ydim')
               ll_dims = ll_dims // 'lat' // pFIO_DIMENSION_SEPARATOR
            case ('Xdim')
               ll_dims = ll_dims // 'lon' // pFIO_DIMENSION_SEPARATOR
            case ('nf')
               ! skip
            case default
               ll_dims = ll_dims // d // pFIO_DIMENSION_SEPARATOR
            end select
            call dim_iter%next()
         end do
      end function make_dim_string

   end subroutine transfer_metadata