psmile_enddef_msg_inters_utils.F90

Go to the documentation of this file.

!-----------------------------------------------------------------------
! Copyright 2010, DKRZ, Hamburg, Germany.
! All rights reserved. Use is subject to OASIS4 license terms.
!-----------------------------------------------------------------------
!
! !DESCRIPTION:
!
! This file contains routines for initiating objects of the derived
! type enddef_msg_intersections. In addition there are two routines
! which allow to convert between object from this type and a integer
! array which is sendable via MPI.
! Since the derived type enddef_field_info is closely related to
! enddef_msg_intersections the respective pack and unpack routines
! are also in this file.
! Since objects of type enddef_msg_intersections have a dynamical
! size it seems unpractically for me to create a MPI datatype for
! sending these objects.
!
!
! !REVISION HISTORY:
!
!   Date      Programmer   Description
! ----------  ----------   -----------
! 25.11.2010  M. Hanke     created
! 08.04.2011  M. Hanke     added routines for enddef_field_info
!
!----------------------------------------------------------------------
!
!  $Id: psmile_enddef_msg_inters_utils.F90 3119 2011-04-08 12:35:20Z hanke $
!  $Author: hanke $
!
!----------------------------------------------------------------------

subroutine psmile_init_enddef_field_info (field_info)
   use psmile_common, only : enddef_field_info, &
                             psmile_undef

   implicit none

   type (enddef_field_info), intent (out) :: field_info

   field_info%tgt_method_id          = psmile_undef
   field_info%tgt_var_id             = psmile_undef
   field_info%tgt_mask_id            = psmile_undef
   field_info%transient_in_id        = psmile_undef
   field_info%transient_out_id       = psmile_undef
   field_info%requires_conserv_remap = psmile_undef

end subroutine psmile_init_enddef_field_info

subroutine psmile_pack_field_info (field_info, buffer, num_field_info)
   use psmile_common, only : enddef_field_info, nd_field_list

   implicit none

   integer, intent (in)                  :: num_field_info
   type (enddef_field_info), intent (in) :: field_info(num_field_info)
   integer, intent (out)                 :: buffer(nd_field_list, num_field_info)

   integer :: i

   do i = 1, num_field_info
      buffer (1,i)    = field_info(i)%tgt_method_id
      buffer (2,i)    = field_info(i)%tgt_var_id
      buffer (3,i)    = field_info(i)%tgt_mask_id
      buffer (4,i)    = field_info(i)%transient_in_id
      buffer (5,i)    = field_info(i)%transient_out_id
      buffer (6,i)    = field_info(i)%requires_conserv_remap

#ifdef DEBUGX
     PRINT *, ' pack tgt_method_id          ', buffer (1,i)
     PRINT *, ' pack tgt_var_id             ', buffer (2,i)
     PRINT *, ' pack tgt_mask_id            ', buffer (3,i)
     PRINT *, ' pack transient_in_id        ', buffer (4,i)
     PRINT *, ' pack transient_out_id       ', buffer (5,i)
     PRINT *, ' pack requires_conserv_remap ', buffer (6,i)
#endif
   enddo ! i

end subroutine psmile_pack_field_info

subroutine psmile_unpack_field_info (field_info, buffer, num_field_info)
   use psmile_common, only : enddef_field_info, nd_field_list

   implicit none

   integer, intent (in)                   :: num_field_info
   type (enddef_field_info), intent (out) :: field_info(num_field_info)
   integer, intent (in)                   :: buffer(nd_field_list, num_field_info)

   integer :: i

   do i = 1, num_field_info
      field_info(i)%tgt_method_id          = buffer  (1,i)
      field_info(i)%tgt_var_id             = buffer  (2,i)
      field_info(i)%tgt_mask_id            = buffer  (3,i)
      field_info(i)%transient_in_id        = buffer  (4,i)
      field_info(i)%transient_out_id       = buffer  (5,i)
      field_info(i)%requires_conserv_remap = buffer  (6,i)

#ifdef DEBUGX
     PRINT *, ' unpack tgt_method_id          ', buffer   (1,i)
     PRINT *, ' unpack tgt_var_id             ', buffer   (2,i)
     PRINT *, ' unpack tgt_mask_id            ', buffer   (3,i)
     PRINT *, ' unpack transient_in_id        ', buffer   (4,i)
     PRINT *, ' unpack transient_out_id       ', buffer   (5,i)
     PRINT *, ' unpack requires_conserv_remap ', buffer   (6,i)
#endif
   enddo ! i

end subroutine psmile_unpack_field_info

subroutine psmile_init_enddef_msg_inters (msg_intersections)
   use psmile_common, only : enddef_msg_intersections, &
                             psmile_undef

   implicit none

   type (enddef_msg_intersections), intent (out) :: msg_intersections

   call psmile_init_enddef_field_info (msg_intersections%field_info)

   msg_intersections%tgt_comp_id                   = psmile_undef
   msg_intersections%src_comp_id                   = psmile_undef
   msg_intersections%tgt_grid_id                   = psmile_undef
   msg_intersections%src_grid_id                   = psmile_undef
   msg_intersections%first_tgt_all_extents_grid_id = psmile_undef
   msg_intersections%first_src_all_extents_grid_id = psmile_undef
   msg_intersections%method_type                   = psmile_undef
   msg_intersections%method_datatype               = psmile_undef
   msg_intersections%all_comp_infos_comp_idx       = psmile_undef
   msg_intersections%num_vars                      = psmile_undef
   msg_intersections%num_parts                     = psmile_undef
   msg_intersections%relative_msg_tag              = psmile_undef

   nullify (msg_intersections%intersections)

end subroutine psmile_init_enddef_msg_inters

subroutine psmile_pack_msg_intersections (msg_intersections, buffer)
   use psmile_common, only : enddef_msg_intersections, ndim_3d, &
                             ip_msgint_inter, nd_msgint, psmile_undef

   implicit none

   type (enddef_msg_intersections), intent (in) :: msg_intersections
   integer, intent (out)                        :: buffer(nd_msgint)

   integer :: npart, n

   buffer = psmile_undef

   buffer  (1) = msg_intersections%src_comp_id
   buffer  (2) = msg_intersections%first_src_all_extents_grid_id
   buffer  (3) = msg_intersections%tgt_comp_id
   buffer  (4) = msg_intersections%tgt_grid_id
   buffer  (5) = msg_intersections%first_tgt_all_extents_grid_id
   buffer  (6) = msg_intersections%field_info%tgt_method_id
   buffer  (7) = msg_intersections%method_type
   buffer  (8) = msg_intersections%method_datatype
   buffer  (9) = msg_intersections%all_comp_infos_comp_idx
   buffer (10) = msg_intersections%field_info%tgt_var_id
   buffer (11) = msg_intersections%field_info%tgt_mask_id
   buffer (12) = msg_intersections%field_info%transient_in_id
   buffer (13) = msg_intersections%num_parts
   buffer (14) = msg_intersections%field_info%transient_out_id
   buffer (15) = msg_intersections%num_vars
   buffer (16) = msg_intersections%field_info%requires_conserv_remap
   buffer (17) = msg_intersections%relative_msg_tag

   npart = msg_intersections%num_parts

   if (npart > 0) then

      do n = 1, npart
         buffer (ip_msgint_inter+1+(n-1)*2*ndim_3d:ip_msgint_inter+n*2*ndim_3d) = &
               pack (msg_intersections%intersections(n)%intersection, .true.)
      enddo

      buffer (ip_msgint_inter+2*ndim_3d*npart+1:ip_msgint_inter+2*ndim_3d*npart+npart) = &
         msg_intersections%intersections(1:npart)%tgt_all_extents_grid_id

      buffer (ip_msgint_inter+2*ndim_3d*npart+npart+1:ip_msgint_inter+2*ndim_3d*npart+2*npart) = &
         msg_intersections%intersections(1:npart)%src_all_extents_grid_id

      ! if there is additional data for gridless grids
      if (npart < size (msg_intersections%intersections)) then

         buffer(ip_msgint_inter+2*ndim_3d*npart+2*npart+1) = msg_intersections%num_parts

         do n = 1, size (msg_intersections%intersections) - npart

            buffer(ip_msgint_inter+2*ndim_3d*npart+2*npart+2+(n-1)*2*ndim_3d: &
                   ip_msgint_inter+2*ndim_3d*npart+2*npart+1+n*2*ndim_3d) =   &
               pack (msg_intersections%intersections(n+npart)%intersection, .true.)
         enddo
      endif
   endif
end subroutine psmile_pack_msg_intersections

subroutine psmile_unpack_msg_intersections (msg_intersections, buffer)
   use psmile_common, only : enddef_msg_intersections, ndim_3d, &
                             ip_msgint_inter, nd_msgint, psmile_undef

   implicit none

   type (enddef_msg_intersections), intent (out) :: msg_intersections
   integer, intent (in)                          :: buffer(nd_msgint)

   integer :: n, npart, npart_alloc

   msg_intersections%src_comp_id                       = buffer  (1)
   msg_intersections%first_src_all_extents_grid_id     = buffer  (2)
   msg_intersections%tgt_comp_id                       = buffer  (3)
   msg_intersections%tgt_grid_id                       = buffer  (4)
   msg_intersections%first_tgt_all_extents_grid_id     = buffer  (5)
   msg_intersections%field_info%tgt_method_id          = buffer  (6)
   msg_intersections%method_type                       = buffer  (7)
   msg_intersections%method_datatype                   = buffer  (8)
   msg_intersections%all_comp_infos_comp_idx           = buffer  (9)
   msg_intersections%field_info%tgt_var_id             = buffer (10)
   msg_intersections%field_info%tgt_mask_id            = buffer (11)
   msg_intersections%field_info%transient_in_id        = buffer (12)
   msg_intersections%num_parts                         = buffer (13)
   msg_intersections%field_info%transient_out_id       = buffer (14)
   msg_intersections%num_vars                          = buffer (15)
   msg_intersections%field_info%requires_conserv_remap = buffer (16)
   msg_intersections%relative_msg_tag                  = buffer (17)

   npart = msg_intersections%num_parts

   ! In case we have a gridless grid npart is stored twice in buffer
   if (buffer(ip_msgint_inter+2*ndim_3d*npart+2*npart+1) == buffer (13)) then
      npart_alloc = 2 * npart
   else
      npart_alloc = npart
   endif

   if (npart > 0) then

      allocate (msg_intersections%intersections(npart_alloc))

      do n = 1, msg_intersections%num_parts
         msg_intersections%intersections(n)%intersection = &
            reshape (buffer(ip_msgint_inter+1+(n-1)*2*ndim_3d:ip_msgint_inter+n*2*ndim_3d), &
                     (/2,ndim_3d/))
      enddo

      msg_intersections%intersections(1:npart)%tgt_all_extents_grid_id = &
         buffer (ip_msgint_inter+2*ndim_3d*npart+1:ip_msgint_inter+2*ndim_3d*npart+npart)

      msg_intersections%intersections(1:npart)%src_all_extents_grid_id = &
         buffer (ip_msgint_inter+2*ndim_3d*npart+npart+1:ip_msgint_inter+2*ndim_3d*npart+2*npart)

      ! if we have a gridless grid, then there is additional grid information in buffer
      if (npart /= npart_alloc) then

         msg_intersections%intersections(npart+1:npart_alloc)%tgt_all_extents_grid_id = psmile_undef
         msg_intersections%intersections(npart+1:npart_alloc)%src_all_extents_grid_id = psmile_undef

         do n = 1, msg_intersections%num_parts

            msg_intersections%intersections(n+npart)%intersection =                       &
               reshape (buffer(ip_msgint_inter+2*ndim_3d*npart+2*npart+2+(n-1)*2*ndim_3d: &
                               ip_msgint_inter+2*ndim_3d*npart+2*npart+1+n*2*ndim_3d),    &
                        (/2,ndim_3d/))
         enddo
      endif

   else

      nullify (msg_intersections%intersections)

   endif

end subroutine psmile_unpack_msg_intersections

subroutine psmile_copy_msg_intersections (msg_intersections_to, &
                                          msg_intersections_from)
   use psmile_common, only : enddef_msg_intersections

   implicit none

   type (enddef_msg_intersections), intent (in)  :: msg_intersections_from
   type (enddef_msg_intersections), intent (out) :: msg_intersections_to

   msg_intersections_to = msg_intersections_from

   nullify (msg_intersections_to%intersections)

   allocate (msg_intersections_to%intersections (size (msg_intersections_from%intersections)))

   msg_intersections_to%intersections = msg_intersections_from%intersections

end subroutine psmile_copy_msg_intersections