psmile_send_req_mask.F90

Go to the documentation of this file.

!-----------------------------------------------------------------------
! Copyright 2006-2010, NEC Europe Ltd., London, UK.
! All rights reserved. Use is subject to OASIS4 license terms.
!-----------------------------------------------------------------------
!BOP
!
! !ROUTINE: PSMILe_Send_req_mask
!
! !INTERFACE:

      subroutine psmile_send_req_mask (msg_intersections, &
                                       dest, tag, ierror)
!
! !USES:
!
      use PRISM_constants
!
      use PSMILe, dummy_interface => PSMILe_Send_req_mask

      Implicit none
!
! !INPUT PARAMETERS:
!
      Type (enddef_msg_intersections), Intent (In) :: msg_intersections

!     Contains the request for a subgrid.

      Integer, Intent (In)                         :: dest

!     Specifies the sender of the request and the destination
!     of the subgrid to be sent.

      Integer, Intent (In)                         :: tag

!     Specifies the message tag used
!
! !OUTPUT PARAMETERS:
!
      Integer, Intent (Out)                        :: ierror

!     Returns the error code of PSMILe_Send_req_mask;
!             ierror = 0 : No error
!             ierror > 0 : Severe error
!
! !LOCAL VARIABLES
!
!     ... for the grid information
!
      Integer                      :: grid_id
      Integer                      :: mask_id
!
!     ... for datatypes
!
      Integer                      :: subarray_type
      Integer                      :: sizes (ndim_3d)
      Integer                      :: subsizes (ndim_3d)
      Integer                      :: starts (ndim_3d)
!
!     ... for the intersection
!
      Integer                      :: inter (2, ndim_3d)
!
      Integer                      :: ipart, npart
!
!     ... for error parameters
!
      Integer, parameter           :: nerrp = 3
      Integer                      :: ierrp (nerrp)
!
! !DESCRIPTION:
!
! Subroutine "PSMILe_Send_req_mask" sends the mask requested
! to the destination process. The subgrid is sent after the corresponding
! request was received by routine "PSMILe_Get_intersect".
!
! !REVISION HISTORY:
!
!   Date      Programmer   Description
! ----------  ----------   -----------
! 03.07.10    H. Ritzdorf  created
!
!EOP
!----------------------------------------------------------------------
!
! $Id: psmile_send_req_mask.F90 2787 2010-11-29 16:51:32Z hanke $
! $Author: hanke $
!
   Character(len=len_cvs_string), save :: mycvs = 
       '$Id: psmile_send_req_mask.F90 2787 2010-11-29 16:51:32Z hanke $'
!
!----------------------------------------------------------------------
!
!  Initialization
!
      ierror = 0

      npart     = msg_intersections%num_parts
      grid_id   = msg_intersections%tgt_grid_id
!     field_id  = msg_intersections%first_tgt_var_id
!     mask_id = Fields(field_id)%mask_id 
      mask_id   = msg_intersections%tgt_mask_id
!
#ifdef VERBOSE
      print 9990, trim(ch_id), grid_id, dest

      call psmile_flushstd
#endif /* VERBOSE */

#ifdef PRISM_ASSERTION

!    Internal control: Is the data really available

      if (mask_id /= PRISM_UNDEFINED .and.          &
          (mask_id > Number_of_Masks_allocated .or. &
           mask_id < 1)) then
!
         print *, trim(ch_id), ' method id, field_id, mask_id', &
                  msg_intersections%first_tgt_method_id,        &
                  msg_intersections%first_tgt_var_id,           &
                  msg_intersections%tgt_mask_id
         print *, trim(ch_id), ' original mask id', &
                               Fields(msg_intersections%first_tgt_var_id)%mask_id
         call psmile_assert ( __FILE__, __LINE__, &
                'Mask id is out of range')
      endif

#endif /* PRISM_ASSERTION */
!
      if (mask_id /= PRISM_UNDEFINED) then
!
         do ipart = 1, npart
!
            inter = msg_intersections%intersections(ipart)%intersection
!
!===> Send Mask values
!
            sizes (:) = Masks(mask_id)%mask_shape(2,:) -   &
                        Masks(mask_id)%mask_shape(1,:) + 1

            subsizes (:) = inter(2,:) - inter (1,:) + 1

            starts (:) = inter (1,:) - Masks(mask_id)%mask_shape(1,:)

#if defined ( PRISM_with_MPI1 )
            call psmile_type_create_subarray (ndim_3d, sizes, subsizes, starts, &
                                          MPI_LOGICAL, subarray_type, ierror)
            if (ierror /= MPI_SUCCESS) then
               ierrp (1) = ierror
               ierror = PRISM_Error_MPI

               call psmile_error (ierror, 'PSMILe_Type_create_subarry', &
                                 ierrp, 1, __FILE__, __LINE__ )
               return
            endif
#else
            call MPI_Type_create_subarray (ndim_3d, sizes, subsizes, starts, &
                                          MPI_ORDER_FORTRAN, MPI_LOGICAL, &
                                          subarray_type, ierror)
            if (ierror /= MPI_SUCCESS) then
               ierrp (1) = ierror
               ierror = PRISM_Error_MPI

               call psmile_error (ierror, 'MPI_Type_create_subarry', &
                                 ierrp, 1, __FILE__, __LINE__ )
               return
            endif
#endif
!
            call MPI_Type_commit (subarray_type, ierror)
            if (ierror /= MPI_SUCCESS) then
               ierrp (1) = ierror
               ierror = PRISM_Error_MPI

               call psmile_error ( ierror, 'MPI_Type_commit', &
                                 ierrp, 1, __FILE__, __LINE__ )
               return
            endif
!
            call MPI_Send (Masks(mask_id)%mask_array, 1, subarray_type, &
                           dest, tag, comm_psmile, ierror)
            if (ierror /= MPI_SUCCESS) then
               ierrp (1) = ierror
               ierrp (2) = dest
               ierrp (3) = tag
               ierror = PRISM_Error_Send

               call psmile_error (ierror, 'MPI_Send', &
                                 ierrp, 3, __FILE__, __LINE__ )
               return
            endif
!
            call MPI_type_free (subarray_type, ierror)
            if (ierror /= MPI_SUCCESS) then
               ierrp (1) = ierror
               ierror = PRISM_Error_MPI

               call psmile_error (ierror, 'MPI_Type_free', &
                                 ierrp, 1, __FILE__, __LINE__ )
               return
            endif
!
         end do ! ipart

      else
!
!===> ... Send dummy request in order to get progress in psmile_get_intersect
!
         call MPI_Send (mask_id, 0, MPI_LOGICAL, &
                        dest, tag, comm_psmile, ierror)
         if (ierror /= MPI_SUCCESS) then
            ierrp (1) = ierror
            ierrp (2) = dest
            ierrp (3) = tag
            ierror = PRISM_Error_Send

            call psmile_error (ierror, 'MPI_Send', &
                               ierrp, 3, __FILE__, __LINE__ )
            return
         endif
      endif ! (mask_id /= PRISM_UNDEFINED)
!
!===> All done
!
#ifdef VERBOSE
      print 9980, trim(ch_id), grid_id, ierror

      call psmile_flushstd
#endif /* VERBOSE */
!
!  Formats:
!
9990 format (1x, a, ': psmile_send_req_mask: grid_id =', i3, &
                    '; dest =', i4)
9980 format (1x, a, ': psmile_send_req_mask: eof grid_id =', i3, &
                    '; ierror =', i4)

      end subroutine PSMILe_Send_req_mask