psmile_merge_fields.F90

Go to the documentation of this file.

!-----------------------------------------------------------------------
! Copyright 2010, DKRZ, Hamburg, Germany.
! All rights reserved. Use is subject to OASIS4 license terms.
!-----------------------------------------------------------------------
!
! !DESCRIPTION:
!
! The routine psmile_merge_fields postprocesses the results of enddef
! process. It collects the send and receive information generated by
! the search process of all block for transient and merges them into a
! single field, which is easier to handle than having a field for each
! block.
!  In order to do this the internal data structures need to be edited.
! This is an evil hack, VERY error-prone, and VERY hard to maintain.
! Hence, I do not like it at all. But I currently see no better way.
!  After the merge the user_var_ids generated by psmile_store_user_data_var
! match the internal psmile_var_ids. Therefore, no translation is needed
! (e.g. in psmile_put or get)
!
!
! !REVISION HISTORY:
!
!   Date      Programmer   Description
! ----------  ----------   -----------
! 08.11.10    M. Hanke     created
!
!----------------------------------------------------------------------
!
!  $Id: psmile_merge_fields.F90 2806 2010-12-08 08:06:52Z hanke $
!  $Author: hanke $
!
!----------------------------------------------------------------------

subroutine psmile_merge_fields (ierror)

   use psmile, only            : GridFunction, Method, Mask, Fields, Methods, Masks, &
                                 Grids, taskout_type, taskin_type,                   &
                                 send_field_information, recv_field_information
   use psmile_user_data, only  : var_data, var_id_map,     &
                                 point_data, point_id_map, &
                                 grid_data, grid_id_map,   &
                                 mask_data, mask_id_map
   use psmile_grid, only       : get_size_of_shape
   use psmile_multimap, only   : get_num_values, get_values, get_value, &
                                 multimap, init_multimap, add_pair,     &
                                 is_valid_key, free_multimap
   use psmile_common, only     : number_of_fields_allocated, psmile_status_free, &
                                 Number_of_Methods_allocated,                    &
                                 Number_of_Fields_allocated,                     &
                                 Number_of_Masks_allocated,                      &
                                 ch_id, psmile_undef, ndim_3d
   use psmile_reallocate, only : psmile_realloc
   use prism_constants, only   : prism_undefined

   implicit none

   integer, intent(out) :: ierror

   integer                     :: i, j, k
   integer                     :: num_blocks
   integer, allocatable        :: var_ids(:), method_ids(:), mask_ids(:)
   type(GridFunction), pointer :: field_final(:)
   type(Method), pointer       :: method_final(:)
   type(Mask), pointer         :: mask_final(:)

   type info_index_offset
      integer :: send_direct, send_coupler, send_appl, recv_direct, recv_coupler
   end type

   type method_patch_info
      type (info_index_offset) :: info_offset
      integer :: new_method_id
      integer :: new_mask_id
   end type

   type (info_index_offset)              :: info_offset
   type (method_patch_info), allocatable :: method_patches (:)
   type (multimap)                       :: old_to_new_var_id

#ifdef VERBOSE
   print 9990, trim(ch_id)
   call psmile_flushstd
#endif /* VERBOSE */

   ierror = 0

   call init_multimap (old_to_new_var_id)

   if ( associated (grid_data)) &
      allocate (var_ids   (get_max_num_blocks ()), &
                method_ids(get_max_num_blocks ()), &
                mask_ids  (get_max_num_blocks ()))

   if (number_of_fields_allocated > 0) &
      allocate (method_patches(number_of_fields_allocated))

!===============================================================================
!  1st merge methods/points
!===============================================================================

   if (associated (point_data)) then

      allocate (method_final(size (point_data)))

      ! for all point sets
      do i = 1, size (point_data)

         num_blocks = get_num_values (point_id_map, i)

         ! get the method ids of the methods associated of the current method id
         method_ids (1:num_blocks) = get_values (point_id_map, i, num_blocks)

         do j = 1, num_blocks

            if (j == 1) then

               ! make a copy of the first method
               call copy_method (method_final(i), methods(method_ids(1)))
               info_offset = info_index_offset(0,0,0,0,0)

            else

               ! merge the current method with the first one
               call merge_method (method_final(i), methods(method_ids(j)), info_offset)
            endif

            ! for all fields
            do k = 1, number_of_fields_allocated

               ! find fields that reference the current method
               if (Fields(k)%status /= psmile_status_free .and. &
                   Fields(k)%method_id == method_ids(j)) then

                  ! this information is later neede to adjust the merged fields to the new method structure
                  method_patches(k)%info_offset = info_offset
                  method_patches(k)%new_method_id = i

               endif
            enddo ! k = 1, number_of_fields_allocated
         enddo ! j = 1, num_blocks
      enddo ! i = 1, size (point_data)

   else

      nullify (method_final)
   endif ! associated (point_data)

!===============================================================================
!  2nd merge mask
!===============================================================================

   method_patches(:)%new_mask_id = prism_undefined

   if (associated (mask_data)) then

      allocate (mask_final(size (mask_data)))

      do i = 1, size (mask_data)

         num_blocks = get_num_values (mask_id_map, i)

         ! get the mask_ids of the mask associated to the current user mask id
         mask_ids(1:num_blocks) = get_values (mask_id_map, i, num_blocks)

         do j = 1, num_blocks

            k = get_value (mask_id_map, i, j)

            if (j == 1) then

               ! make a copy of the first mask
               call copy_mask (mask_final (i), Masks (k))

               ! adjust mask shape in order be able to store mask information of all blocks
               call adjust_mask_shape (mask_final (i), mask_ids (1:num_blocks))

            else

               ! merge current field with first field (copy ta)
               call merge_mask (mask_final(i), Masks (k))
            endif

            ! for all fields
            do k = 1, number_of_fields_allocated

               ! find fields that reference the current mask
               if (Fields(k)%status /= psmile_status_free .and. &
                   Fields(k)%mask_id == mask_ids(j)) then

                  method_patches(k)%new_mask_id = i

               endif
            enddo ! k = 1, number_of_fields_allocated
         enddo ! j = 1, num_blocks
      enddo ! i = 1, size (mask_data)

   else

      nullify (mask_final)
   endif ! (associated (mask_data))

!===============================================================================
!  3rd merge vars/fields
!===============================================================================

   if (associated (var_data)) then

      allocate (field_final(size (var_data)))

      !for all transients
      do i = 1, size (var_data)

         num_blocks = get_num_values (var_id_map, i)

         ! get the var_ids of the vars associated to the current user var id
         var_ids(1:num_blocks) = get_values (var_id_map, i, num_blocks)

         do j = 1, num_blocks

            k = get_value (var_id_map, i, j)

            if (j == 1) then

               ! make a copy of the first field and its Taskin/out (we do not need to adjust the
               ! send/recv_indices in taskin/out for the first field)
               call copy_field_information (field_final (i), Fields (k),     &
                                            method_patches(k)%new_method_id, &
                                            method_patches(k)%new_mask_id)

            else

               ! merge current field with first field (copy ta)
               call merge_fields (field_final(i), Fields (k), method_patches(k)%info_offset)
            endif

            call add_pair (old_to_new_var_id, k ,i)

         enddo ! j = 1, num_blocks
      enddo ! i = 1, size (var_data)
   else
      nullify (field_final)
   endif

!===============================================================================
!  4th cleanup
!===============================================================================

   ! free old data structures, might be omitted later if the data needs to be reused. One needs
   ! to be careful when deleting data, because the new Fields and Methods are in some parts just
   ! shallow copies of the original data structures
   call psmile_deallocate_fields (ierror)
   call psmile_deallocate_methods (ierror)
   call psmile_deallocate_masks (ierror)

   ! set data structures to new ones
   Fields  => field_final
   Methods => method_final
   Masks   => mask_final

!    Number_of_Masks_allocated   = size (Masks)
   if (associated (Methods)) then
      Number_of_Methods_allocated = size (Methods)
   else
      Number_of_Methods_allocated = 0
   endif
   if (associated (Fields)) then
      Number_of_Fields_allocated  = size (Fields)
   else
      Number_of_Fields_allocated = 0
   endif
   if (associated (Masks)) then
      Number_of_Masks_allocated  = size (Masks)
   else
      Number_of_Masks_allocated = 0
   endif

   ! we need to do some adjustments for fields that use userdefined interpolation

   ! for all fields
   do i = 1, Number_of_Fields_allocated
      call adjust_assoc_var_ids (Fields(i))
   enddo

   call free_multimap (old_to_new_var_id)

#ifdef VERBOSE
   print 9980, trim(ch_id), ierror
   call psmile_flushstd
#endif /* VERBOSE */

9990 format (1x, a, ': psmile_merge_fields: ')
9980 format (1x, a, ': psmile_merge_fields: eof ierror =', i5)

contains

   ! ===========================================================================

   subroutine copy_method (method_to, method_from)

      type (method), intent (in)  :: method_from
      type (method), intent (out) :: method_to

      call debug_routine_start("copy_method")

      ! this is just a shallow copy of the method, which means that
      ! all pointers of method_to point to the same objects in memory
      ! than method_from
      method_to = method_from

      ! we need to avoid having multiple pointers to the same objects,
      ! because this causes problems in psmile_deallocate
      nullify (method_to%coords_pointer, method_to%subgrid_pointer, &
               method_to%vector_pointer, method_to%halo_pointer)

      ! because we want to adjust the send and recv infos we have to do a deep copy of them
      if (method_from%n_send_info_direct > 0) then

         allocate (method_to%send_infos_direct(method_from%n_send_info_direct))
         method_to%send_infos_direct = &
            method_from%send_infos_direct(1:method_from%n_send_info_direct)
      endif
      if (method_from%n_send_info_coupler > 0) then

         allocate (method_to%send_infos_coupler(method_from%n_send_info_coupler))
         method_to%send_infos_coupler = &
            method_from%send_infos_coupler(1:method_from%n_send_info_coupler)
      endif
      if (method_from%n_send_info_appl > 0) then

         allocate (method_to%send_infos_appl(method_from%n_send_info_appl))
         method_to%send_infos_appl = &
            method_from%send_infos_appl(1:method_from%n_send_info_appl)
      endif
      if (method_from%n_recv_info_direct > 0) then

         allocate (method_to%recv_infos_direct(method_from%n_recv_info_direct))
         method_to%recv_infos_direct = &
            method_from%recv_infos_direct(1:method_from%n_recv_info_direct)
      endif
      if (method_from%n_recv_info_coupler > 0) then

         allocate (method_to%recv_infos_coupler(method_from%n_recv_info_coupler))
         method_to%recv_infos_coupler = &
            method_from%recv_infos_coupler(1:method_from%n_recv_info_coupler)
      endif

      call debug_routine_end("copy_method")

   end subroutine copy_method

   ! ===========================================================================

   subroutine merge_method (method_to, method_from, info_offset)

      type (method), intent (in)             :: method_from
      type (method), intent (inout)          :: method_to
      type (info_index_offset), intent (out) :: info_offset

      call debug_routine_start("merge_method")

      info_offset%send_direct  = method_to%n_send_info_direct
      info_offset%send_coupler = method_to%n_send_info_coupler
      info_offset%send_appl    = method_to%n_send_info_appl
      info_offset%recv_direct  = method_to%n_recv_info_direct
      info_offset%recv_coupler = method_to%n_recv_info_coupler

      if (method_from%n_send_info_direct > 0) then

         method_to%send_infos_direct => psmile_realloc(method_to%send_infos_direct, &
                                                       method_to%n_send_info_direct + &
                                                       method_from%n_send_info_direct)

         method_to%send_infos_direct(method_to%n_send_info_direct+1:) = &
            method_from%send_infos_direct(1:method_from%n_send_info_direct)

         method_to%n_send_info_direct = method_to%n_send_info_direct + &
                                        method_from%n_send_info_direct
      endif

      if (method_from%n_send_info_coupler > 0) then

         method_to%send_infos_coupler => psmile_realloc(method_to%send_infos_coupler, &
                                                       method_to%n_send_info_coupler + &
                                                       method_from%n_send_info_coupler)

         method_to%send_infos_coupler(method_to%n_send_info_coupler+1:) = &
            method_from%send_infos_coupler(1:method_from%n_send_info_coupler)

         method_to%n_send_info_coupler = method_to%n_send_info_coupler + &
                                        method_from%n_send_info_coupler
      endif

      if (method_from%n_send_info_appl > 0) then

         method_to%send_infos_appl => psmile_realloc(method_to%send_infos_appl, &
                                                       method_to%n_send_info_appl + &
                                                       method_from%n_send_info_appl)

         method_to%send_infos_appl(method_to%n_send_info_appl+1:) = &
            method_from%send_infos_appl(1:method_from%n_send_info_appl)

         method_to%n_send_info_appl = method_to%n_send_info_appl + &
                                        method_from%n_send_info_appl
      endif

      if (method_from%n_recv_info_direct > 0) then

         method_to%recv_infos_direct => psmile_realloc(method_to%recv_infos_direct, &
                                                       method_to%n_recv_info_direct + &
                                                       method_from%n_recv_info_direct)

         method_to%recv_infos_direct(method_to%n_recv_info_direct+1:) = &
            method_from%recv_infos_direct(1:method_from%n_recv_info_direct)

         method_to%n_recv_info_direct = method_to%n_recv_info_direct + &
                                        method_from%n_recv_info_direct
      endif

      if (method_from%n_recv_info_coupler > 0) then

         method_to%recv_infos_coupler => psmile_realloc(method_to%recv_infos_coupler, &
                                                       method_to%n_recv_info_coupler + &
                                                       method_from%n_recv_info_coupler)

         method_to%recv_infos_coupler(method_to%n_recv_info_coupler+1:) = &
            method_from%recv_infos_coupler(1:method_from%n_recv_info_coupler)
         method_to%n_recv_info_coupler = method_to%n_recv_info_coupler + &
                                        method_from%n_recv_info_coupler
      endif

      call debug_routine_end("merge_method")

   end subroutine merge_method

   ! ===========================================================================

   subroutine adjust_send_field_information (send_field_infos, offset)

      type (send_field_information), intent (inout) :: send_field_infos(:)
      integer, intent (in)                          :: offset

      integer :: i

      do i = 1, size (send_field_infos)
         send_field_infos(i)%send_info_index = send_field_infos(i)%send_info_index + offset
      enddo

   end subroutine

   ! ===========================================================================

   subroutine adjust_recv_field_information (recv_field_infos, offset)

      type (recv_field_information), intent (inout) :: recv_field_infos(:)
      integer, intent (in)                          :: offset

      integer :: i

      do i = 1, size (recv_field_infos)
         recv_field_infos(i)%recv_info_index = recv_field_infos(i)%recv_info_index + offset
      enddo

   end subroutine

   ! ===========================================================================

   function get_max_num_blocks ()

      integer :: get_max_num_blocks
      integer :: i

      get_max_num_blocks = 1

      if (associated (grid_data)) then

         do i = 1, size (grid_data)
            get_max_num_blocks = max (get_max_num_blocks, &
                                    get_num_values(grid_id_map, i))
         enddo
      else
         get_max_num_blocks = 0
      endif

   end function get_max_num_blocks

   ! ===========================================================================

   subroutine insert_sub_array (tgt, tgt_shape, src, src_shape)

      integer, intent (in) :: tgt_shape(2,ndim_3d)

      logical, intent (out)   :: tgt(tgt_shape(1,1):tgt_shape(2,1), 
                                     tgt_shape(1,2):tgt_shape(2,2), 
                                     tgt_shape(1,3):tgt_shape(2,3))

      integer, intent (in) :: src_shape(2,ndim_3d)

      logical, intent (in)    :: src(src_shape(1,1):src_shape(2,1), 
                                     src_shape(1,2):src_shape(2,2), 
                                     src_shape(1,3):src_shape(2,3))

      tgt(src_shape(1,1):src_shape(2,1), &
          src_shape(1,2):src_shape(2,2), &
          src_shape(1,3):src_shape(2,3)) = src

   end subroutine insert_sub_array

   ! ===========================================================================

   subroutine adjust_mask_shape (mask_data, mask_ids)

      type (mask), intent (inout) :: mask_data
      integer, intent (in)        :: mask_ids (:)

      integer          :: mask_actual_shape(2, ndim_3d)
      integer          :: i, size_of_shape(2)
      logical, pointer :: new_mask_array(:)

      size_of_shape = get_size_of_shape (Grids(mask_data%grid_id)%grid_type)

      do i = 1, size_of_shape(2)

         mask_actual_shape(1, i) = minval (Masks(mask_ids)%mask_shape(1, i))
         mask_actual_shape(2, i) = maxval (Masks(mask_ids)%mask_shape(2, i))
      enddo

      do i = size_of_shape(2) + 1, ndim_3d

         mask_actual_shape(1, i) = 1
         mask_actual_shape(2, i) = 1
      enddo

      nullify (new_mask_array)
      new_mask_array => psmile_realloc(new_mask_array, product (mask_actual_shape(2,:) - &
                                                                mask_actual_shape(1,:) + 1))

      call insert_sub_array (new_mask_array, mask_actual_shape, &
                             mask_data%mask_array, mask_data%mask_shape)

      mask_data%mask_shape = mask_actual_shape
      mask_data%mask_array => new_mask_array

   end subroutine adjust_mask_shape

   ! ===========================================================================

   subroutine copy_mask (mask_to, mask_from)

      type (mask), intent (in)  :: mask_from
      type (mask), intent (out) :: mask_to

      logical, pointer :: mask_array

      call debug_routine_start("copy_mask")

      mask_to = mask_from

      nullify (mask_to%mask_array)
      mask_to%mask_array => psmile_realloc (mask_to%mask_array, size (mask_from%mask_array))

      mask_to%mask_array = mask_from%mask_array

      call debug_routine_end("copy_mask")

   end subroutine copy_mask

   ! ===========================================================================

   subroutine merge_mask (mask_to, mask_from)

      type (mask), intent (in)    :: mask_from
      type (mask), intent (inout) :: mask_to

      call debug_routine_start("merge_mask")

      call insert_sub_array (mask_to%mask_array, mask_to%mask_shape, &
                             mask_from%mask_array, mask_from%mask_shape)

      call debug_routine_end("merge_mask")

   end subroutine merge_mask

   ! ===========================================================================

   subroutine copy_taskin_type (taskin_to, taskin_from)

      type (taskin_type), intent (in)  :: taskin_from
      type (taskin_type), intent (out) :: taskin_to

      call debug_routine_start("copy_taskin_type")

      ! this is just a shallow copy of the taskin, which means that
      ! all pointers of taskin_to point to the same objects in memory
      ! than taskin_from
      taskin_to = taskin_from

      ! make a deep copy of taskin_from%Judate_axis
      if (associated (taskin_from%Judate_axis)) then
         nullify (taskin_to%Judate_axis)
         taskin_to%Judate_axis => psmile_realloc (taskin_to%Judate_axis, &
                                                  size (taskin_from%Judate_axis))
         taskin_to%Judate_axis = taskin_from%Judate_axis
      endif

      ! make a deep copy of taskin_from%In_channel
      if (associated (taskin_from%In_channel)) then
         nullify (taskin_to%In_channel)
         taskin_to%In_channel => psmile_realloc (taskin_to%In_channel, &
                                                 size (taskin_from%In_channel))
         taskin_to%In_channel = taskin_from%In_channel
      endif

      if (taskin_from%n_recv_direct > 0) then

         allocate (taskin_to%recv_direct(taskin_from%n_recv_direct))
         taskin_to%recv_direct = taskin_from%recv_direct(1:taskin_from%n_recv_direct)
         taskin_to%n_recv_direct = taskin_from%n_recv_direct
      else
         taskin_to%n_recv_direct = 0
         nullify (taskin_to%recv_direct)
      endif

      if (taskin_from%n_recv_coupler > 0) then

         allocate (taskin_to%recv_coupler(taskin_from%n_recv_coupler))
         taskin_to%recv_coupler = taskin_from%recv_coupler(1:taskin_from%n_recv_coupler)
         taskin_to%n_recv_coupler = taskin_from%n_recv_coupler
      else
         nullify (taskin_to%recv_coupler)
         taskin_to%n_recv_coupler = 0
      endif

      call debug_routine_end("copy_taskin_type")

   end subroutine copy_taskin_type

   ! ===========================================================================

   subroutine copy_taskout_type (taskout_to, taskout_from)

      type (taskout_type), intent (in)  :: taskout_from(:)
      type (taskout_type), intent (out) :: taskout_to(:)

      integer :: i

      call debug_routine_start("copy_taskout_type")

      ! this is just a shallow copy of the taskout, which means that
      ! all pointers of taskout_to point to the same objects in memory
      ! than taskout_from
      taskout_to = taskout_from

      do i = 1, size (taskout_from)

         ! make a deep copy of taskin_from%Judate_axis
         if (associated (taskout_from(i)%Judate_axis)) then
            nullify (taskout_to(i)%Judate_axis)
            taskout_to(i)%Judate_axis => psmile_realloc (taskout_to(i)%Judate_axis, &
                                                      size (taskout_from(i)%Judate_axis))
            taskout_to(i)%Judate_axis = taskout_from(i)%Judate_axis
         endif

         if (taskout_from(i)%n_send_direct > 0) then

            allocate (taskout_to(i)%send_direct(taskout_from(i)%n_send_direct))
            taskout_to(i)%send_direct = taskout_from(i)%send_direct(1:taskout_from(i)%n_send_direct)
            taskout_to(i)%n_send_direct = taskout_from(i)%n_send_direct
         else
            nullify (taskout_to(i)%send_direct)
            taskout_to(i)%n_send_direct = 0
         endif

         if (taskout_from(i)%n_send_coupler > 0) then

            allocate (taskout_to(i)%send_coupler(taskout_from(i)%n_send_coupler))
            taskout_to(i)%send_coupler = taskout_from(i)%send_coupler(1:taskout_from(i)%n_send_coupler)
            taskout_to(i)%n_send_coupler = taskout_from(i)%n_send_coupler
         else
            nullify (taskout_to(i)%send_coupler)
            taskout_to(i)%n_send_coupler = 0
         endif

         if (taskout_from(i)%n_send_appl > 0) then

            allocate (taskout_to(i)%send_appl(taskout_from(i)%n_send_appl))
            taskout_to(i)%send_appl = taskout_from(i)%send_appl(1:taskout_from(i)%n_send_appl)
            taskout_to(i)%n_send_appl = taskout_from(i)%n_send_appl
         else
            nullify (taskout_to(i)%send_appl)
            taskout_to(i)%n_send_appl = 0
         endif
      enddo

      call debug_routine_end("copy_taskout_type")

   end subroutine copy_taskout_type

   ! ===========================================================================

   subroutine copy_field_information (field_to, field_from, new_method_id, new_mask_id)

      type (gridfunction), intent (in)  :: field_from
      type (gridfunction), intent (out) :: field_to
      integer, intent (in)              :: new_method_id
      integer, intent (in)              :: new_mask_id

      call debug_routine_start("copy_field_information")

      field_to = field_from

      field_to%method_id = new_method_id
      field_to%mask_id   = new_mask_id

      call copy_taskin_type(field_to%Taskin, field_from%Taskin)

      if (associated (field_from%Taskout)) then
         if (size (field_from%Taskout) > 0) then

            allocate (field_to%Taskout(size (field_from%Taskout)))
            call copy_taskout_type(field_to%Taskout, field_from%Taskout)

         endif
      endif

      ! I do not know what to do with the io stuff, therefore I am leaving this for later

      call debug_routine_end("copy_field_information")

   end subroutine copy_field_information

   ! ===========================================================================

   subroutine merge_taskin (taskin_to, taskin_from, info_offset)

      type (taskin_type), intent (in)       :: taskin_from
      type (taskin_type), intent (inout)    :: taskin_to
      type (info_index_offset), intent (in) :: info_offset

      call debug_routine_start("merge_taskin")

      if (taskin_from%n_recv_direct > 0) then

         taskin_to%recv_direct => psmile_realloc (taskin_to%recv_direct, &
                                                  taskin_to%n_recv_direct + &
                                                  taskin_from%n_recv_direct)

         taskin_to%recv_direct(taskin_to%n_recv_direct+1:) = &
            taskin_from%recv_direct(1:taskin_from%n_recv_direct)

         call adjust_recv_field_information (taskin_to%recv_direct(taskin_to%n_recv_direct+1:), &
                                             info_offset%recv_direct)
         taskin_to%n_recv_direct = taskin_to%n_recv_direct + taskin_from%n_recv_direct
      endif

      if (taskin_from%n_recv_coupler > 0) then

         taskin_to%recv_coupler => psmile_realloc (taskin_to%recv_coupler, &
                                                  taskin_to%n_recv_coupler + &
                                                  taskin_from%n_recv_coupler)

         taskin_to%recv_coupler(taskin_to%n_recv_coupler+1:) = &
            taskin_from%recv_coupler(1:taskin_from%n_recv_coupler)

         call adjust_recv_field_information (taskin_to%recv_coupler(taskin_to%n_recv_coupler+1:), &
                                             info_offset%recv_coupler)

         taskin_to%n_recv_coupler = taskin_to%n_recv_coupler + taskin_from%n_recv_coupler
      endif

      call debug_routine_end("merge_taskin")

   end subroutine merge_taskin

   ! ===========================================================================

   subroutine merge_taskout (taskout_to, taskout_from, info_offset)

      type (taskout_type), intent (in)      :: taskout_from(:)
      type (taskout_type), intent (inout)   :: taskout_to(:)
      type (info_index_offset), intent (in) :: info_offset

      integer :: i

      call debug_routine_start("merge_taskout")

#ifdef PRISM_ASSERTION
      if (size (taskout_to) /= size (taskout_from)) then
         call psmile_assert (__FILE__, __LINE__, &
                             "merge_taskout taskout_to and taskout_from have different sizes")
      endif
#endif

      do i = 1, size (taskout_to)

         if (taskout_from(i)%n_send_direct > 0) then

            taskout_to(i)%send_direct => psmile_realloc (taskout_to(i)%send_direct, &
                                                         taskout_to(i)%n_send_direct + &
                                                         taskout_from(i)%n_send_direct)

            taskout_to(i)%send_direct(taskout_to(i)%n_send_direct+1:) = &
               taskout_from(i)%send_direct(1:taskout_from(i)%n_send_direct)

            call adjust_send_field_information (taskout_to(i)%send_direct(taskout_to(i)%n_send_direct+1:), &
                                                info_offset%send_direct)
            taskout_to(i)%n_send_direct = taskout_to(i)%n_send_direct + taskout_from(i)%n_send_direct
         endif

         if (taskout_from(i)%n_send_coupler > 0) then

            taskout_to(i)%send_coupler => psmile_realloc (taskout_to(i)%send_coupler, &
                                                          taskout_to(i)%n_send_coupler + &
                                                          taskout_from(i)%n_send_coupler)

            taskout_to(i)%send_coupler(taskout_to(i)%n_send_coupler+1:) = &
               taskout_from(i)%send_coupler(1:taskout_from(i)%n_send_coupler)

            call adjust_send_field_information (taskout_to(i)%send_coupler(taskout_to(i)%n_send_coupler+1:), &
                                                info_offset%send_coupler)
            taskout_to(i)%n_send_coupler = taskout_to(i)%n_send_coupler + taskout_from(i)%n_send_coupler
         endif

         if (taskout_from(i)%n_send_appl > 0) then

            taskout_to(i)%send_appl => psmile_realloc (taskout_to(i)%send_appl, &
                                                       taskout_to(i)%n_send_appl + &
                                                       taskout_from(i)%n_send_appl)

            taskout_to(i)%send_appl(taskout_to(i)%n_send_appl+1:) = &
               taskout_from(i)%send_appl(1:taskout_from(i)%n_send_appl)

            call adjust_send_field_information (taskout_to(i)%send_appl(taskout_to(i)%n_send_appl+1:), &
                                                info_offset%send_appl)
            taskout_to(i)%n_send_appl = taskout_to(i)%n_send_appl + taskout_from(i)%n_send_appl
         endif
      enddo ! i = 1, size (taskout_to)

      call debug_routine_end("merge_taskout")

   end subroutine merge_taskout

   ! ===========================================================================

   subroutine merge_fields (field_to, field_from, info_offset)

      type (gridfunction), intent (in)      :: field_from
      type (gridfunction), intent (inout)   :: field_to
      type (info_index_offset), intent (in) :: info_offset

      call debug_routine_start("merge_fields")

      ! I do not know what to do with IO stuff...but it did not work for multiblock before as well...

      call merge_taskin (field_to%taskin, field_from%taskin, info_offset)
      if (associated (field_from%taskout)) then
         call merge_taskout (field_to%taskout, field_from%taskout, info_offset)
      else
         nullify (field_to%taskout)
      endif

      call debug_routine_end("merge_fields")

   end subroutine merge_fields

   ! ===========================================================================

   subroutine adjust_assoc_var_ids (field)

      type (gridfunction), intent (inout) :: field

      integer :: i

      call debug_routine_start ("adjust_assoc_var_ids")

      ! if there taskout's defined for this field
      if (associated (field%taskout)) then

         ! for all taskout's
         do i = 1, size (field%taskout)

            ! if the current taskout has a associated var_id
            if (field%taskout(i)%assoc_var_id /= psmile_undef) then

               ! if we have a new var id for the current assoc_var_id
               if (is_valid_key (old_to_new_var_id, field%taskout(i)%assoc_var_id)) then

                  ! adjust assoc_var_id
                  field%taskout(i)%assoc_var_id = get_value (old_to_new_var_id, &
                                                             field%taskout(i)%assoc_var_id, 1)
               endif
            endif
         enddo ! i
      endif ! associated (field%taskout)

      ! for all inchannels of the field
      do i = 1, field%taskin%nbr_inchannels

         ! if the current inchannel has a associated var_id
         if (field%taskin%in_channel(i)%assoc_var_id /= psmile_undef) then

            ! if we have a new var id for the current assoc_var_id
            if (is_valid_key (old_to_new_var_id, field%taskin%in_channel(i)%assoc_var_id)) then

               ! adjust assoc_var_id
               field%taskin%in_channel(i)%assoc_var_id = get_value (old_to_new_var_id, &
                                                      field%taskin%in_channel(i)%assoc_var_id, 1)
            endif
         endif
      enddo ! i

      call debug_routine_end ("adjust_assoc_var_ids")

   end subroutine adjust_assoc_var_ids

   ! ===========================================================================

   subroutine debug_routine_start (name)

      character (len=*), intent (in) :: name
#ifdef VERBOSE
      print "(1x, a, ': ', a,': ')", trim(ch_id), name
      call psmile_flushstd
#endif /* VERBOSE */
   end subroutine debug_routine_start

   ! ===========================================================================

   subroutine debug_routine_end (name)

      character (len=*), intent (in) :: name
#ifdef VERBOSE
      print "(1x, a, ': ', a,': eof')", trim(ch_id), name
      call psmile_flushstd
#endif /* VERBOSE */
   end subroutine debug_routine_end

end subroutine psmile_merge_fields