cub2latlon_regridder.F90 Source File

#include "MAPL_Generic.h"

!---------------------------
! Note - this module abuses global variables as a simple mechanism for
! sharing data among procedures.  The module is only intended to be
! used with this one driver, so the use of globals is (barely)
! forgiveable.  Any further extension should involve creating a data
! type (or types) to encapsulate these and pass them between the
! various procedures.
!---------------------------

module SupportMod
   use ESMF
   use MAPL_ExceptionHandling
   use MAPL_BaseMod
   use pFIO
   use MAPL_Constants
   use MAPL_RangeMod
   use MAPL_StringRouteHandleMapMod
   use gFTL2_StringVector
   use gFTL2_StringIntegerMap
   use, intrinsic :: iso_fortran_env, only: REAL32, REAL64, INT64
   use mpi
   implicit none
   public



   integer :: local_pet
   integer :: pet_count
   integer :: npx, npy, px, py
   integer :: ierror
   integer, parameter :: N_TILES = 6


   type (StringRouteHandleMap) :: route_handles
   integer :: srcTerm
   type (ESMF_RouteHandle), target :: default_route_handle


   type RegridSupport
     ! Cubed-sphere
     integer :: Xdim, Ydim
     integer :: nx_loc, ny_loc
     integer :: x_1, x_n
     integer :: y_1, y_n
     integer :: my_tile
     character(len=:), allocatable :: in_file
     type (FileMetadata) :: cfio_cubed_sphere
     type (ESMF_Grid) :: grid_cubed_sphere
     type (Netcdf4_Fileformatter) :: formatter_cubed_sphere

     ! Lat-lon
     integer :: IM
     integer :: JM
     character(len=:), allocatable :: out_file
     type (FileMetadata) :: cfio_lat_lon
     type (ESMF_Grid) :: grid_lat_lon
     integer :: i_1, i_n
     integer :: j_1, j_n
     type (Netcdf4_Fileformatter) :: formatter_lat_lon
     real(kind=ESMF_KIND_R8), allocatable :: longitudes(:)
     real(kind=ESMF_KIND_R8), allocatable :: latitudes(:)

     ! Both
     logical :: debug = .false.
     integer :: LM
     integer :: NT

     ! Misc
     type (StringVector) :: requested_variables
     type (StringVector) :: scalar_variables
     type (StringVector) :: vector_variables(2)
   contains
     procedure :: process_command_line
     procedure :: read_metadata
     procedure :: create_esmf_grids
     procedure :: create_cubed_sphere_grid
     procedure :: create_lat_lon_grid
     procedure :: transfer_metadata
     procedure :: write_metadata
     procedure :: write_data

   end type RegridSupport

contains

   ! The following procedure parses the command line to find various
   ! arguments for file names, target grid resolution, etc.
   subroutine process_command_line(regridder, rc)
      class (RegridSupport) :: regridder
      integer, optional, intent(out) :: rc

      integer :: n_args
      integer :: i_arg
      character(len=:), allocatable :: argument
      character(len=:), allocatable :: buffer

      n_args = command_argument_count()

      i_arg = 0
      do
         if (i_arg > n_args) exit

         argument = get_next_argument()

         select case (argument)
         case ('-i', '--ifile')
            regridder%in_file = get_next_argument()
            _ASSERT(regridder%in_file(1:1) /= '-','bad format')
         case ('-o', '--ofile')
             regridder%out_file = get_next_argument()
            _ASSERT(regridder%in_file(1:1) /= '-','bad format')
         case ('--nlats')
            buffer  = get_next_argument()
            _ASSERT(buffer(1:1) /= '-','bad format')
            read(buffer,*) regridder%JM
         case ('--nlons')
            buffer  = get_next_argument()
            _ASSERT(buffer(1:1) /= '-','bad format')
            read(buffer,*) regridder%IM
         case ('--vars')
            buffer = get_next_argument()
            _ASSERT(buffer(1:1) /= '-','bad format')
            regridder%requested_variables = parse_vars(buffer)
         case ('-d', '--debug')
            regridder%debug = .true.
         case default
            ! ignore
         end select

      end do

   contains

      function get_next_argument() result(argument)
         character(len=:), allocatable :: argument

         integer :: length

         i_arg = i_arg + 1

         call get_command_argument(i_arg, length=length)
         allocate(character(len=length) :: argument)
         call get_command_argument(i_arg, value=argument)

      end function get_next_argument


      function parse_vars(buffer) result(vars)
         type (StringVector) :: vars
         character(len=*), intent(in) :: buffer

         integer :: idx
         character(len=1), parameter :: COMMA = ','
         character(len=:), allocatable :: string

         string = buffer // COMMA
         do
            if (len(string) == 0) exit
            idx = index(string,COMMA)
            call vars%push_back(string(1:idx-1))
            string = string(idx+1:)
         end do

      end function parse_vars

   end subroutine process_command_line


   ! Read the NetCDF metadata from the input file and store
   ! in a FileMetadata object.
   subroutine read_metadata(this)
      class (RegridSupport), intent(inout) :: this

      associate (formatter => this%formatter_cubed_sphere )
         call formatter%open(this%in_file, mode=pFIO_READ)
         this%cfio_cubed_sphere = formatter%read()
         this%nt = formatter%inq_dim('time')
         call formatter%close()
      end associate

    end subroutine read_metadata

   ! Create the metadata for a lat-lon grid, and transfer non-grid
   ! metadata from the CS FileMetadata object into the new one.  I.e. copy
   ! what you can/should and create the rest from input parameters.
   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%ftn_begin()
         do while (var_iter /= variables%ftn_end())
            call var_iter%next()

            var_name => var_iter%first()
            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%second()

                  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

         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%ftn_begin()
         do while (var_iter /= vars%ftn_end())
            call var_iter%next()

            var => var_iter%second()
            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%first()
                  end if
               end if
            end if
         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%of()
            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

   function run_length_encode(missing) result(str)
      character(len=:), allocatable :: str
      logical, intent(in) :: missing(:)

      integer :: i
      integer :: count
      logical :: value

      if (size(missing) == 0) then
         str = ''
         return
      end if

      count = 1
      value = missing(1)
      str = to_string_bool(value)

      do i = 2, size(missing)
        if (value .eqv. missing(i)) then
           count = count + 1
        else
           value = missing(i)
           str = str // to_string(count) // to_string_bool(value)
           count = 1
        end if
     end do

     str = str // to_string(count)

   contains

      function to_string(count) result(str)
         character(len=:), allocatable :: str
         integer, intent(in) :: count
         character(len=8) :: buffer

         write(buffer,'(i0)') count
         str = trim(buffer)
      end function to_string

      function to_string_bool(bool) result(str)
         character(len=1) :: str
         logical, intent(in) :: bool
         if (bool) then
            str = 'T'
         else
            str = 'F'
          end if
       end function to_string_bool

   end function run_length_encode

   function all_gather(local) result(global)
      character(len=*), intent(in) :: local
      character(len=:), allocatable :: global

      integer :: p
      integer, allocatable :: counts(:)
      integer, allocatable :: displs(:)
      integer :: ierror, rc

      allocate(counts(0:pet_count-1))
      allocate(displs(0:pet_count-1))

      call mpi_allgather(len(local), 1, MPI_INTEGER, &
           & counts, 1, MPI_INTEGER, MPI_COMM_WORLD, ierror)
      _VERIFY(ierror)

      displs(0) = 0
      do p = 1, pet_count - 1
          displs(p) = displs(p-1) + counts(p-1)
      end do

      allocate(character(len=sum(counts)) :: global)
      call mpi_allgatherv(local, len(local), MPI_CHAR, &
           global, counts, displs, MPI_CHAR, MPI_COMM_WORLD, ierror)
      _VERIFY(ierror)

   end function all_gather


   subroutine regrid(srcField, dstField, missing, rc)
     type (ESMF_Field), intent(in) :: srcField
     type (ESMF_Field), intent(inout) :: dstField
     real (kind=REAL32), optional, intent(in) :: missing
     integer, optional, intent(out) :: rc

     integer :: status
     real(kind=REAL32), pointer :: src_array(:,:)
     real(kind=REAL32), pointer :: dst_array(:,:)
     type (ESMF_RouteHandle), pointer :: handle
     character(len=:), allocatable :: local_key
     character(len=:), allocatable :: global_key
     integer, pointer :: mask(:,:)
     type (ESMF_Array) :: mask_array
     type (ESMF_Grid) :: grid
     logical :: have_missing, any_missing

     call ESMF_FieldGet(srcField, 0, src_array)
     if (present(missing)) then
        have_missing = any(missing == src_array)
        call MPI_AllReduce(have_missing, any_missing, 1, MPI_LOGICAL, MPI_LOR, MPI_COMM_WORLD, ierror)
        _VERIFY(ierror)
        if (any_missing) then
           local_key = run_length_encode(reshape(src_array,[size(src_array)]) == missing)
           global_key = all_gather(local_key)

           handle => route_handles%at(global_key)
           if (.not. associated(handle)) then
              allocate(handle)

              call ESMF_FieldGet(srcfield, grid=grid, rc=status)
              _VERIFY(status)
              call ESMF_GridGetItem(grid, staggerLoc=ESMF_STAGGERLOC_CENTER, &
                   & itemflag=ESMF_GRIDITEM_MASK, array=mask_array, rc=status)
              _VERIFY(status)
              call ESMF_ArrayGet(mask_array, farrayptr=mask, rc=status)
              _VERIFY(status)

              where (src_array == missing)
                 mask = 0
              elsewhere
                 mask = 1
              end where

              call ESMF_FieldRegridStore(srcField, dstField, &
                   & regridmethod=ESMF_REGRIDMETHOD_BILINEAR, lineType=ESMF_LINETYPE_GREAT_CIRCLE, &
                   & srcTermProcessing=srcTerm, &
                   & srcMaskValues = [0], &
                   & unmappedAction=ESMF_UNMAPPEDACTION_IGNORE, &
                   & routehandle=handle, rc=status)
              _VERIFY(status)

              call route_handles%insert(global_key, handle)

           endif

           call ESMF_FieldGet(dstField, 0, dst_array)
           dst_array = missing
           call ESMF_FieldRegrid(srcField, dstField, routeHandle=handle, &
                & termorderflag=ESMF_TERMORDER_SRCSEQ, &
                & zeroregion=ESMF_REGION_SELECT, &
                & rc=status)
           _VERIFY(status)

           _RETURN(_SUCCESS)
        else
           handle => default_route_handle
        end if
     else
        handle => default_route_handle
     end if

     call ESMF_FieldRegrid(srcField, dstField, routeHandle=handle, &
          & termorderflag=ESMF_TERMORDER_SRCSEQ, rc=status)
     _VERIFY(status)

     _RETURN(_SUCCESS)
   end subroutine regrid

   ! This routine does the big work of reading data from one file, regridding, and
   ! then writing to the other file.   Gets a bit messy to handle  2D vs 3D and scalar
   ! vs vector cases.  Certainly could be cleaned further in next pass.

   subroutine write_data(this, rc)
      class (RegridSupport), target, intent(inout) :: this
      integer, optional, intent(out) :: rc


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

      real(kind=REAL32), target, allocatable :: cs_scalar_patch(:,:)
      real(kind=REAL32), target, allocatable :: cs_vector_patch(:,:,:)
      real(kind=REAL32), target, allocatable :: cs_uvw(:,:,:)
      real(kind=REAL32), target, allocatable :: ll_uvw(:,:,:)
      real(kind=REAL32), target, allocatable :: ll_scalar_patch(:,:)
      real(kind=REAL32), target, allocatable :: ll_vector_patch(:,:,:)

      character(len=:), pointer :: var_name
      type (ESMF_Field) :: cs_scalar_field
      type (ESMF_Field) :: ll_scalar_field
      type (ESMF_Field) :: cs_uvw_field(3)
      type (ESMF_Field) :: ll_uvw_field(3)
      integer :: level
      integer :: num_levels
      integer :: status
      integer :: time
      type (StringVector), pointer :: dims
      type (Variable), pointer :: var

      integer, allocatable :: cs_start(:), cs_count(:)
      integer, allocatable :: ll_start(:), ll_count(:)

      real(kind=REAL64), pointer :: lat(:,:)
      real(kind=REAL64), pointer :: lon(:,:)

      type (Attribute), pointer :: missing_attr
      class(*), pointer :: missing_ptr(:)
      real(kind=REAL32), pointer :: missing

      integer :: d
      logical :: is_scalar
      logical :: is_east_vector_component
      integer :: idx
      character(len=:), allocatable :: north_component
      integer(kind=INT64) :: c0, c1,crate

      associate (cs_fmtr => this%formatter_cubed_sphere, ll_fmtr => this%formatter_lat_lon)
      call cs_fmtr%open(this%in_file, mode=pFIO_READ, rc=status)
      if (status /= pFIO_SUCCESS) then
         if (local_pet == 0) then
            print*, 'Unable to open input file: ',this%in_file
          end if
      end if
      call ll_fmtr%open(this%out_file, mode=pFIO_WRITE, rc=status)
      if (status /= pFIO_SUCCESS) then
         if (local_pet == 0) then
            print*, 'Unable to open new output file: ',this%out_file
            print*, 'Possibly it already exists?'
         end if
      end if

      call ll_fmtr%put_var('lat', this%latitudes)
      call ll_fmtr%put_var('lon', this%longitudes)

      block
        real(kind=REAL64) :: lev(this%LM)
        if (associated(this%cfio_cubed_sphere%get_variable('lev'))) then
           call cs_fmtr%get_var('lev', lev)
           call ll_fmtr%put_var('lev', lev)
        end if
      end block
      block
        integer :: time(this%NT)
        call cs_fmtr%get_var('time', time)
        call ll_fmtr%put_var('time', time)
      end block

      allocate(ll_scalar_patch(this%i_1:this%i_n, this%j_1:this%j_n))
      allocate(ll_vector_patch(this%i_1:this%i_n, this%j_1:this%j_n,2))
      allocate(ll_uvw(this%i_1:this%i_n, this%j_1:this%j_n,3))


      allocate(cs_scalar_patch(this%nx_loc,this%ny_loc))
      allocate(cs_vector_patch(this%nx_loc,this%ny_loc,2))

      allocate(cs_uvw(this%nx_loc,this%ny_loc,3))

      ! Create fields
      ll_scalar_field = ESMF_FieldCreate(this%grid_lat_lon, ll_scalar_patch(:,:), ESMF_INDEX_DELOCAL, &
           & datacopyflag=ESMF_DATACOPY_REFERENCE, rc=status)
      _VERIFY(status)
      cs_scalar_field = ESMF_FieldCreate(this%grid_cubed_sphere, cs_scalar_patch(:,:), ESMF_INDEX_DELOCAL, &
           & datacopyflag=ESMF_DATACOPY_REFERENCE, rc=status)
      _VERIFY(status)
      do d = 1, 3
         ll_uvw_field(d) = ESMF_FieldCreate(this%grid_lat_lon, ll_uvw(:,:,d), ESMF_INDEX_DELOCAL, &
              & datacopyflag=ESMF_DATACOPY_REFERENCE, rc=status)
         _VERIFY(status)
         cs_uvw_field(d) = ESMF_FieldCreate(this%grid_cubed_sphere, cs_uvw(:,:,d), ESMF_INDEX_DELOCAL, &
              & datacopyflag=ESMF_DATACOPY_REFERENCE, rc=status)
         _VERIFY(status)
      end do

      ! Create regrid
      srcTerm = 1
      call system_clock(c0,crate)
      call ESMF_FieldRegridStore(cs_scalar_field, ll_scalar_field, &
           & regridmethod=ESMF_REGRIDMETHOD_BILINEAR, lineType=ESMF_LINETYPE_GREAT_CIRCLE, &
           & srcTermProcessing=srcTerm, &
           & routehandle=default_route_handle, rc=status)
      _VERIFY(status)
      call system_clock(c1,crate)
      if (local_pet == 0) then
         print*,'regrid store: ', real(c1-c0)/crate
      end if

      block
        type (ESMF_VM) :: global
        call ESMF_VMGetGlobal(global, rc=status)
        call ESMF_VMBarrier(global, rc=status)
      end block
      variables => this%cfio_cubed_sphere%get_variables()
      var_iter = variables%ftn_begin()
      do while (var_iter /= variables%ftn_end())
         call var_iter%next()

         var_name => var_iter%first()

         select case (var_name)
         case ('nf', 'ncontact', 'cubed_sphere', &
              & 'Xdim', 'Ydim', 'lons', 'lats', &
              & 'contacts', 'orientation', 'anchor', &
              & 'lev','time')
            ! skip
         case default

            if ( local_pet == 0 .and. this%debug) then
               print*, 'var = ', var_name
            end if

            var => var_iter%second()
            missing_attr => var%get_attribute('missing_value')
            missing_ptr => missing_attr%get_values()

            select type (missing_ptr)
            type is (real(kind=REAL64))
               allocate(missing) ! memory leak!
               missing = missing_ptr(1)
            type is (real(kind=REAL32))
               missing => missing_ptr(1)
            class default
               ! no missing value?
            end select
            num_levels = 1
            dims => var%get_dimensions()
            if (dims%get_index('lev') /= 0) then
               num_levels = this%LM
            else
               num_levels = 1
            end if

            is_scalar = .false.
            is_east_vector_component = .false.

            do idx = 1, this%scalar_variables%size()
               if (this%scalar_variables%at(idx) == var_name) then
                  is_scalar = .true.
                  exit
               end if
            end do

            if (.not. is_scalar) then
               do idx = 1, this%vector_variables(1)%size()
                  if (this%vector_variables(1)%at(idx) == var_name) then
                     is_east_vector_component = .true.
                     north_component = this%vector_variables(2)%at(idx)
                     exit
                  end if
               end do
            end if

            if (.not. (is_scalar .or. is_east_vector_component)) then
               cycle
            end if


            do time = 1, this%nt
               do level = 1, num_levels

                  if (num_levels == 1) then
                     cs_start = [this%x_1,this%y_1,this%my_tile,time]
                     ll_start = [this%i_1,this%j_1,time]
                     cs_count = [this%nx_loc,this%ny_loc,1,1]
                     ll_count = [this%i_n-this%i_1+1, this%j_n-this%j_1+1,1]
                  else
                     cs_start = [this%x_1,this%y_1,this%my_tile,level,time]
                     ll_start = [this%i_1,this%j_1,level,time]
                     cs_count = [this%nx_loc,this%ny_loc,1,1,1]
                     ll_count = [this%i_n-this%i_1+1, this%j_n-this%j_1+1,1,1]
                  end if

                  if (is_east_vector_component) then ! vector

                     call cs_fmtr%get_var(var_name, cs_vector_patch(:,:,1), start=cs_start,count=cs_count, rc=status)
                     _VERIFY(status)
                     call cs_fmtr%get_var(north_component, cs_vector_patch(:,:,2), start=cs_start,count=cs_count, rc=status)
                     _VERIFY(status)

                     call ESMF_GridGetCoord(this%grid_cubed_sphere, coordDim=1, localDE=0, &
                          & staggerLoc=ESMF_STAGGERLOC_CENTER, farrayPtr=lon,rc=status)
                     call ESMF_GridGetCoord(this%grid_cubed_sphere, coordDim=2, localDE=0, &
                          & staggerLoc=ESMF_STAGGERLOC_CENTER, farrayPtr=lat,rc=status)

                     associate (u => cs_vector_patch(:,:,1), v => cs_vector_patch(:,:,2))
                       where (u == missing)
                          cs_uvw(:,:,1) = missing
                          cs_uvw(:,:,2) = missing
                          cs_uvw(:,:,3) = missing
                       elsewhere
                          cs_uvw(:,:,1) = - u * sind(lon) - v * sind(lat)*cosd(lon)
                          cs_uvw(:,:,2) = + u * cosd(lon) - v * sind(lat)*sind(lon)
                          cs_uvw(:,:,3) = + v * cosd(lat)
                      end where
                     end associate


                     do d = 1, 3
                        if (associated(missing)) then
                           call regrid(srcField=cs_uvw_field(d), dstField=ll_uvw_field(d), missing=missing, rc=status)
                           _VERIFY(status)
                        else
                           call regrid(srcField=cs_uvw_field(d), dstField=ll_uvw_field(d), rc=status)
                           _VERIFY(status)
                        end if
                     end do

                     call ESMF_GridGetCoord(this%grid_lat_lon, coordDim=1, localDE=0, &
                          & staggerLoc=ESMF_STAGGERLOC_CENTER, farrayPtr=lon,rc=status)
                     call ESMF_GridGetCoord(this%grid_lat_lon, coordDim=2, localDE=0, &
                          & staggerLoc=ESMF_STAGGERLOC_CENTER, farrayPtr=lat,rc=status)

                     associate (u => ll_vector_patch(:,:,1), v => ll_vector_patch(:,:,2))
                       where (ll_uvw(:,:,1) == missing)
                          u = missing
                          v = missing
                       elsewhere
                          u = -ll_uvw(:,:,1) * sind(lon) + ll_uvw(:,:,2) * cosd(lon)
                          v = -ll_uvw(:,:,1) * sind(lat)*cosd(lon) - ll_uvw(:,:,2) * sind(lat)*sind(lon) +  ll_uvw(:,:,3)*cosd(lat)
                       end where
                     end associate

                     call ll_fmtr%put_var(var_name, ll_vector_patch(:,:,1), start=ll_start, count=ll_count, rc=status)
                     _VERIFY(status)
                     call ll_fmtr%put_var(north_component, ll_vector_patch(:,:,2), start=ll_start, count=ll_count, rc=status)
                     _VERIFY(status)

                  else ! scalar
                     call cs_fmtr%get_var(var_name, cs_scalar_patch, start=cs_start,count=cs_count, rc=status)
                     _VERIFY(status)
                     if (associated(missing)) then
                        call regrid(srcField=cs_scalar_field, dstField=ll_scalar_field, missing=missing, rc=status)
                        _VERIFY(status)
                     else
                        call regrid(srcField=cs_scalar_field, dstField=ll_scalar_field, rc=status)
                        _VERIFY(status)
                     end if
                     call ll_fmtr%put_var(var_name, ll_scalar_patch, start=ll_start, count=ll_count, rc=status)
                     _VERIFY(status)

                  end if

               end do
            end do
         end select
       end do


      call ll_fmtr%close()
      call cs_fmtr%close()

      end associate

   end subroutine write_data


   subroutine write_metadata(this, rc)
      class (RegridSupport), intent(inout) :: this
      integer, optional, intent(out) :: rc
      type (ESMF_VM) :: vm_global
      integer :: status

!$$      if (local_pet == 0) then
         call this%formatter_lat_lon%create_par(this%out_file, comm=MPI_COMM_WORLD, rc=status)
         _VERIFY(status)
         call this%formatter_lat_lon%write(this%cfio_lat_lon, rc=status)
         _VERIFY(status)
         call this%formatter_lat_lon%close(rc=status)
         _VERIFY(status)
!$$       end if

      call ESMF_VMGetGlobal(vm_global, rc=status)
      _VERIFY(status)
      call ESMF_VMBarrier(vm_global, rc=status)
      _VERIFY(status)

   end subroutine write_metadata


   ! Trig functions to work with angles in degrees.
   ! Current ESMF CS grid is hardwired to produce coordinates
   ! in degrees.  (Good and bad.)
   elemental function sind(x) result(s)
      real(kind=REAL64), intent(in) :: x
      real(kind=REAL64) :: s

      s = sin(x * MAPL_DEGREES_TO_RADIANS_R8)

   end function sind

   elemental function cosd(x) result(c)
      real(kind=REAL64), intent(in) :: x
      real(kind=REAL64) :: c

      c = cos(x * MAPL_DEGREES_TO_RADIANS_R8)

   end function cosd

   subroutine create_esmf_grids(this, rc)
      class (RegridSupport), intent(inout) :: this
      integer, optional, intent(out) :: rc
      integer :: status


      call this%create_cubed_sphere_grid(rc=status)
      _VERIFY(status)
      call this%create_lat_lon_grid(rc=status)
      _VERIFY(status)

      _RETURN(_SUCCESS)


   end subroutine create_esmf_grids


   subroutine create_cubed_sphere_grid(this, rc)
      class (RegridSupport), intent(inout) :: this
      integer, optional, intent(out) :: rc
      type (ESMF_DistGrid):: distgrid

      integer :: deToTileMap(0:pet_count-1)
      integer :: minIndex(2,0:pet_count-1), maxIndex(2,0:pet_count-1)
      integer :: ijms(2,6),NX,NY,i,lcnts(2)
      integer :: nPetPerTile
      integer :: status

      this%Xdim = this%cfio_cubed_sphere%get_dimension('Xdim')
      this%LM = this%cfio_cubed_sphere%get_dimension('lev',rc=status)
      ! ignore status
      if (status /= pFIO_SUCCESS) then
        this%LM = 1
        status = pFIO_SUCCESS
      end if

      nPetPerTile = pet_count/n_tiles
      nx = nint(sqrt(real(nPetPerTile*this%Xdim)/this%Xdim))
      nx = max(nx,1)
      do while( mod(nPetPerTile,nx).NE.0)
         nx = nx - 1
      enddo
      ny=nPetPerTile/nx
      ijms(1,1)=NX
      ijms(2,1)=NY
      do i=2,6
         ijms(:,i)=ijms(:,1)
      enddo

      this%grid_cubed_sphere = ESMF_GridCreateCubedSphere(this%Xdim, regDecompPTile=ijms, rc=status)
      _VERIFY(status)

      call ESMF_GridGet(this%grid_cubed_sphere, distgrid=distgrid,rc=status)
      _VERIFY(status)
      call ESMF_DistGridGet(distgrid, deToTileMap=deToTileMap, rc=status)
      _VERIFY(status)
      call MAPL_DistGridGet(distgrid, MaxIndex=maxIndex, MinIndex=minIndex, rc=status)
      _VERIFY(status)
      this%my_tile = deToTileMap(local_pet)

      call ESMF_GridGet(this%grid_cubed_sphere,localDE=0,staggerloc=ESMF_STAGGERLOC_CENTER, &
           exclusiveCount=lcnts,rc=status)
      _VERIFY(status)
      call ESMF_GridAddItem(this%grid_cubed_sphere,itemflag=ESMF_GRIDITEM_MASK,staggerloc=ESMF_STAGGERLOC_CENTER, &
           & itemTypeKind=ESMF_TYPEKIND_I4, rc=status)
      _VERIFY(status)
      this%nx_loc=lcnts(1)
      this%ny_loc=lcnts(2)
      select case (this%my_tile)
         case(1)
            this%x_1=minIndex(1,local_pet)
            this%x_n=maxIndex(1,local_pet)
            this%y_1=minIndex(2,local_pet)
            this%y_n=maxIndex(2,local_pet)
         case(2)
            this%x_1=minIndex(1,local_pet) - this%Xdim
            this%x_n=maxIndex(1,local_pet) - this%Xdim
            this%y_1=minIndex(2,local_pet)
            this%y_n=maxIndex(2,local_pet)
         case(3)
            this%x_1=minIndex(1,local_pet) - this%Xdim
            this%x_n=maxIndex(1,local_pet) - this%Xdim
            this%y_1=minIndex(2,local_pet) - this%Xdim
            this%y_n=maxIndex(2,local_pet) - this%Xdim
         case(4)
            this%x_1=minIndex(1,local_pet) - 2*this%Xdim
            this%x_n=maxIndex(1,local_pet) - 2*this%Xdim
            this%y_1=minIndex(2,local_pet) - this%Xdim
            this%y_n=maxIndex(2,local_pet) - this%Xdim
         case(5)
            this%x_1=minIndex(1,local_pet) - 2*this%Xdim
            this%x_n=maxIndex(1,local_pet) - 2*this%Xdim
            this%y_1=minIndex(2,local_pet) - 2*this%Xdim
            this%y_n=maxIndex(2,local_pet) - 2*this%Xdim
         case(6)
            this%x_1=minIndex(1,local_pet) - 3*this%Xdim
            this%x_n=maxIndex(1,local_pet) - 3*this%Xdim
            this%y_1=minIndex(2,local_pet) - 2*this%Xdim
            this%y_n=maxIndex(2,local_pet) - 2*this%Xdim
      end select

      _RETURN(_SUCCESS)
   end subroutine create_cubed_sphere_grid



   subroutine create_lat_lon_grid(this, rc)
      class (RegridSupport), intent(inout) :: this
      integer, optional, intent(out) :: rc

      real(kind=ESMF_KIND_R8), pointer :: centers(:,:)

      integer :: status
      integer :: i, j

      integer, allocatable :: jms(:)
      integer, allocatable :: ims(:)
      integer :: np
      integer :: npx

      np = floor(sqrt(real(pet_count)))
      do npx = np, 1, -1
         ! will always be true in the final iteration
         if (mod(pet_count, npx) == 0) exit
      end do
      npy = pet_count / npx

!$$      npx = 2
!$$      npy = pet_count/2
      npx = 1
      npy = pet_count

      if (local_pet == 0) print*,'Topology: ', npx, npy
      ims = [((((j+1)*this%IM)/npx) - ((j*this%IM)/npx),j=0,npx-1)]
      jms = [((((j+1)*this%JM)/npy) - ((j*this%JM)/npy),j=0,npy-1)]

      this%grid_lat_lon = ESMF_GridCreate( &
           & countsPerDEDim1 = ims, &
           & countsPerDEDim2 = jms, &
           & indexFlag=ESMF_INDEX_DELOCAL, &
           & gridEdgeLWidth=[0,0], &
           & gridEdgeUWidth=[0,0], &
           & coordDep1=[1,2], &
           & coordDep2=[1,2], &
           & rc=status &
           & )

      call ESMF_GridAddCoord(this%grid_lat_lon, rc=status)
      _VERIFY(status)

      px = mod(local_pet, npx)
      py = local_pet / npx

      this%i_1 = 1 + (px*this%IM)/npx
      this%i_n = ((px+1)*this%IM)/npx
      this%j_1 = 1 + (py*this%JM)/npy
      this%j_n = ((py+1)*this%JM)/npy

      call ESMF_GridGetCoord(this%grid_lat_lon, coordDim=1, localDE=0, &
           staggerloc=ESMF_STAGGERLOC_CENTER, &
           farrayPtr=centers, rc=status)
      _VERIFY(status)

      this%longitudes = MAPL_RANGE(-180.d0, 180.d0 - (360.d0/this%IM), this%IM, rc=status)
      _VERIFY(status)

      centers(:,1) = this%longitudes(this%i_1:this%i_n)
      do j = 2, size(centers,2)
        centers(:,j) = centers(:,1)
      end do

      ! Now latitudes
      call ESMF_GridGetCoord(this%grid_lat_lon, coordDim=2, localDE=0, &
           staggerloc=ESMF_STAGGERLOC_CENTER, &
           farrayPtr=centers, rc=status)
      _VERIFY(status)

      this%latitudes = MAPL_RANGE(-90.d0, +90.d0, this%JM, rc=status)
      _VERIFY(status)

      centers(1,:) = this%latitudes(this%j_1:this%j_n)
      do i = 2, size(centers,1)
        centers(i,:) = centers(1,:)
      end do

      _RETURN(_SUCCESS)
   end subroutine create_lat_lon_grid



end module SupportMod


! Macros for main program should STOP.  Macros for module above
! throw an exception and RETURN.

! The main program.   Misleadingly simple.
#define I_AM_MAIN
#include "MAPL_Generic.h"
program main
   use ESMF
   use SupportMod
   use pFIO
   implicit none

   integer(kind=INT64) :: c00, c0, c1, crate

   integer :: status
   type (RegridSupport) :: regridder

   call ESMF_Initialize(logKindFlag=ESMF_LOGKIND_NONE)

   call check_resources(rc=status)
   _VERIFY(status)

   call regridder%process_command_line(rc=status)
   _VERIFY(status)

   call system_clock(c0,crate)
   c00 = c0
   call regridder%read_metadata()
   call system_clock(c1)
   if (local_pet == 0) then
     print*,'read_metadata()', real(c1-c0)/crate
   end if

   call system_clock(c0)
   call regridder%create_esmf_grids()
   call system_clock(c1)
   if (local_pet == 0) then
     print*,'create_esmf_grids()', real(c1-c0)/crate
   end if

   call system_clock(c0)
   call regridder%transfer_metadata()
   call system_clock(c1)
   if (local_pet == 0) then
     print*,'transfer_metadata()', real(c1-c0)/crate
   end if

   call system_clock(c0)
   call regridder%write_metadata() ! to out_file
   call system_clock(c1)
   if (local_pet == 0) then
     print*,'write_metadata()', real(c1-c0)/crate
   end if


   call system_clock(c0)
   call regridder%write_data(_RC)
   call system_clock(c1)
   if (local_pet == 0) then
     print*,'write_data()', real(c1-c0)/crate
     print*,'total: ', real(c1-c00)/crate
     print*,'num regridders = ',  1 + route_handles%size()

   end if

   call ESMF_finalize()

contains


#undef I_AM_MAIN
#include "MAPL_Generic.h"

   subroutine check_resources(rc)
      use SupportMod
      integer, optional, intent(out) :: rc
      integer:: status

      type (ESMF_VM) :: vm_global

      call ESMF_VMGetGlobal(vm_global, rc=status)
      call ESMF_VMGet(vm_global, petcount=pet_count, localpet=local_pet, rc=status)

      if (mod(pet_count,N_TILES) /= 0) then ! should just require a multiple, but ...
         rc = -1
         if (local_pet == 0) then
            write(*,*)'The number of mpi processes must be a multile of 6.'
         end if
         _RETURN(_FAILURE)
      end if

      _RETURN(_SUCCESS)

   end subroutine check_resources


end program