psmile_recv_req_coords_real.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_Recv_req_coords_real
!
! !INTERFACE:

      subroutine psmile_recv_req_coords_real (sender, tag,      &
                                              search, recv_req, &
                                              receive_mask, new_search, ierror)
!
! !USES:
!
      use PRISM_constants
!
      use PSMILe, dummy_interface => PSMILe_Recv_req_coords_real

      implicit none
!
! !INPUT PARAMETERS:
!
      Integer, Intent (In)                :: sender

!     Specifies the sender of the subgrid.

      Integer, Intent (In)                :: tag

!     Specifies the message tag used

      Logical, Intent (In)                :: receive_mask

!     Should mask array be received ?
!
      Logical, Intent (In)                :: new_search

!     Option:
!     new_search = .true.  : New search; fill search structure
!     new_search = .fasle. : Get only data for a new field
!
! !INPUT/OUTPUT PARAMETERS:
!
      Type (Enddef_search), Intent (InOut) :: search

!     Data on the points to be searched

!
! !OUTPUT PARAMETERS:
!
      integer, Intent (Out)               :: recv_req (ndim_3d+2, search%npart)

!     Receive requests of non-blocking receives

      integer, Intent (Out)               :: ierror

!     Returns the error code of PSMILe_Recv_req_coords_real;
!             ierror = 0 : No error
!             ierror > 0 : Severe error
!
! !LOCAL VARIABLES
!
!     ... for the intersections
!
      integer                      :: i, ipart
      integer                      :: dim (ndim_3d)
      integer                      :: len_mask
!
!     ... for error parameters
!
      integer, parameter           :: nerrp = 3
      integer                      :: ierrp (nerrp)
!
! !DESCRIPTION:
!
! Subroutine "PSMILe_Recv_req_coords_real" receives the subgrid requested
! from the sending 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_recv_req_coords_real.F90 2325 2010-04-21 15:00:07Z valcke $
! $Author: valcke $
!
   Character(len=len_cvs_string), save :: mycvs = 
       '$Id: psmile_recv_req_coords_real.F90 2325 2010-04-21 15:00:07Z valcke $'
!
!----------------------------------------------------------------------
!
!  Initialization
!
      ierror = 0

#ifdef VERBOSE
      print 9990, trim(ch_id), sender, search%npart, receive_mask

      call psmile_flushstd
#endif /* VERBOSE */
!
      if (new_search) then
         Allocate (search%search_real (ndim_3d, search%npart), stat = ierror)
         if ( ierror /= 0 ) then
            ierrp (1) = search%npart * ndim_3d
            ierror = PRISM_Error_Alloc
            call psmile_error ( ierror, 'search%search_real', &
                  ierrp, 1, __FILE__, __LINE__ )
            return
         endif
      endif
!
! ====================================================================
!     Get dimensions of arrays to be allocated and
!     allocate the arrays.
! ====================================================================

      do ipart = 1, search%npart
!
      select case ( search%grid_type )

! -----------------------------------------------------------------------
!         Regular in all directions
! -----------------------------------------------------------------------
!
      case (PRISM_Reglonlatvrt)
!
         dim(:) = search%range (2,:, ipart) - search%range (1,:, ipart) + 1

         len_mask = dim (1) * dim (2) * dim (3)
!
! -----------------------------------------------------------------------
!       Gauss Reduced grid in lonlat direction
!         Regular in vertical direction
!         For now search%range(*,2,*) is 1!
! -----------------------------------------------------------------------
!
      case (PRISM_Gaussreduced_regvrt)

         dim(1) = (search%range(2,1, ipart) - search%range(1,1, ipart) + 1) * &
                  (search%range(2,2, ipart) - search%range(1,2, ipart) + 1)
         dim(2) = dim(1)
         dim(3) =  search%range(2,3, ipart) - search%range(1,3, ipart) + 1

         len_mask = dim (1) * dim (3)
!
! -----------------------------------------------------------------------
!       Irregular in lonlat   direction
!         Regular in vertical direction
! -----------------------------------------------------------------------
!
      case (PRISM_Irrlonlat_regvrt)

         dim(1) = (search%range(2,1, ipart) - search%range(1,1, ipart) + 1) * &
                  (search%range(2,2, ipart) - search%range(1,2, ipart) + 1)
         dim(2) = dim(1)
         dim(3) =  search%range(2,3, ipart) - search%range(1,3, ipart) + 1

         len_mask = dim (1) * dim (3)

! -----------------------------------------------------------------------
!       Irregular in lonlat   and vertical direction
! -----------------------------------------------------------------------
!
      case (PRISM_Irrlonlatvrt)

         dim(1) = (search%range(2,1, ipart) - search%range(1,1, ipart) + 1) * &
                  (search%range(2,2, ipart) - search%range(1,2, ipart) + 1) * &
                  (search%range(2,3, ipart) - search%range(1,3, ipart) + 1)
         dim(2) = dim(1)
         dim(3) = dim(1)

         len_mask = dim (1)
!
! -----------------------------------------------------------------------
!     Error: unsupported grid type
! -----------------------------------------------------------------------
!
      case DEFAULT
!
          ierrp (1) = search%grid_type

          ierror = PRISM_Error_Internal

          call psmile_error ( ierror, 'unsupported grid generation type', &
                              ierrp, 1, __FILE__, __LINE__ )

      end select
!
      search%dims(:, ipart) = dim (:)
!
!  ... Allocate arrays
!
      if (new_search) then
         do i = 1, ndim_3d

         Allocate (search%search_real(i, ipart)%vector(dim(i)), STAT = ierror)
         if ( ierror > 0 ) then
            ierrp (1) = ierror
            ierrp (2) = dim(i)
            ierror = PRISM_Error_Alloc
            call psmile_error ( ierror, 'search%search_real(i)%vector', &
                                ierrp, 2, __FILE__, __LINE__ )
            return
         endif

         end do
      endif
!
!===> ... Post receive
!         !!! Das ist unschoen mit den vielen sends/receives.
!         !!! Was schoeneres faellt mir aber im Moment nicht ein.
!
!     if (sender /= psmile_rank) then
!     endif

         do i = 1, ndim_3d

         call MPI_Irecv (search%search_real(i, ipart)%vector, dim(i), &
                         MPI_REAL, &
                         sender, tag, comm_psmile, recv_req (i, ipart), ierror)
         if (ierror /= MPI_SUCCESS) then
            ierrp (1) = ierror
            ierrp (2) = sender
            ierrp (3) = tag
            ierror = PRISM_Error_Recv

            call psmile_error (ierror, 'MPI_Irecv', &
                               ierrp, 3, __FILE__, __LINE__ )
            return
         endif
!
         end do
!
!===> Post receive for the mask if required
!
      if (receive_mask) then

         if (new_search .or. .not. Associated (search%search_mask(ipart)%vector)) &
            then

            Allocate (search%search_mask(ipart)%vector(len_mask), STAT = ierror)
            if ( ierror > 0 ) then
               ierrp (1) = ierror
               ierrp (2) = len_mask
               ierror = PRISM_Error_Alloc
               call psmile_error ( ierror, 'search%search_mask(ipart)%vector', &
                                   ierrp, 2, __FILE__, __LINE__ )
               return
            endif
         endif

         call MPI_Irecv (search%search_mask(ipart)%vector, len_mask, &
                         MPI_LOGICAL, sender, tag, comm_psmile, &
                         recv_req (ndim_3d+1, ipart), ierror)
         if (ierror /= MPI_SUCCESS) then
            ierrp (1) = ierror
            ierrp (2) = sender
            ierrp (3) = tag
            ierror = PRISM_Error_Recv

            call psmile_error (ierror, 'MPI_Irecv of mask', &
                               ierrp, 3, __FILE__, __LINE__ )
            return
         endif

      else
!
!Rene: WARNING: We have to keep search_mask here when this call was preceded
!      psmile_recv_req_corners_real which may have received a mask already.
!      What shall we do if the cell-based search required the mask but
!      the point-based search does not require a mask? We need more information
!      from the target to make a decision, something like a no-mask flag. We could
!      initiate a new search : new_search == .true. ???
!
!      Workaraound for the user in case:
!        - only point-based search is required for a particular grid
!        - some fields for this grid have a PRISM_Undefined mask
!        ->  define a mask with all values flagged as .true. for those fields
!        
!
         if ( Associated(search%search_mask) ) then
            if (.not. new_search .and. Associated (search%search_mask(ipart)%vector)) &
                 then

!rr               Deallocate (search%search_mask(ipart)%vector)
            endif

!rr               Nullify    (search%search_mask(ipart)%vector)
!rr               if ( ipart == search%npart ) Nullify (search%search_mask)

         endif

         recv_req (ndim_3d+1, ipart) = MPI_REQUEST_NULL

      endif
      end do ! ipart
!
!===> All done
!
#ifdef VERBOSE
      print 9980, trim(ch_id), ierror

      call psmile_flushstd
#endif /* VERBOSE */
!
!  Formats:
!
9990 format (1x, a, ': PSMILe_Recv_req_coords_real: ', &
                    'sender =', i4, ', npart =', i3, ', receive_mask', l2)
9980 format (1x, a, ': PSMILe_Recv_req_coords_real: eof ', &
                    'ierror =', i4)

      end subroutine PSMILe_Recv_req_coords_real