psmile_send_destinations.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_destinations
!
! !INTERFACE:

      subroutine psmile_send_destinations (method_id, cpl_index, dir_index, &
                                           sender, tag, ierror)
!
! !USES:
!
      use PRISM_constants
!
      use PSMILe, dummy_interface => PSMILe_Send_destinations

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

!     Pointer to the method

      Integer, Intent (In)            :: cpl_index

!     Index of coupler send information
!     cpl_index = PRISM_UNDEFINED if no data from coupler is transferred

      Integer, Intent (In)            :: dir_index

!     Index of direct send information
!     dir_index = PRISM_UNDEFINED if no data is directly transferred

      Integer, Intent (In)            :: sender

!     Rank of destination process in communicator "comm_psmile"

      Integer, Intent (In)            :: tag

!     Message tag
 
! !OUTPUT PARAMETERS:
!
      integer, Intent (Out)           :: ierror

!     Returns the error code of PSMILe_Send_destinations;
!             ierror = 0 : No error
!             ierror > 0 : Severe error
!
! !LOCAL PARAMETERS
!
!     ... for locations to be transferred
!
      Type (Method), Pointer          :: mp
      Type(Send_information), Pointer :: send_info
!
!     ... for communication
!
      Integer                         :: lrequest
      Integer                         :: n, i
#ifdef PRISM_ASSERTION
      Integer                         :: nar, ntot
#endif
!
!     ... for error handling
!
      Integer, parameter              :: nerrp = 3
      Integer                         :: ierrp (nerrp)
!
! !DESCRIPTION:
!
! Subroutine "PSMILe_Send_destinations" sends the locations found to the
! destination process "dest".
! The data is received by routine "PSMILe_Get_locations_3d" in sending process.
!
!
! !REVISION HISTORY:
!
!   Date      Programmer   Description
! ----------  ----------   -----------
! 03.07.21    H. Ritzdorf  created
!
!EOP
!----------------------------------------------------------------------
!
!  $Id: psmile_send_destinations.F90 2887 2011-01-14 09:25:49Z redler $
!  $Author: redler $
!
   Character(len=len_cvs_string), save :: mycvs = 
       '$Id: psmile_send_destinations.F90 2887 2011-01-14 09:25:49Z redler $'
!
!----------------------------------------------------------------------
!
!  Initialization
!
#ifdef VERBOSE
      print 9990, trim(ch_id), cpl_index, dir_index

      call psmile_flushstd
#endif /* VERBOSE */
!
      ierror = 0
!
      mp => Methods(method_id)
!
!===> Transfer grid indices of points to be transferred by the coupler.
!     The message is received after the previous message is found by
!     the receiving process. Therefore, we don't wait for the
!     completion of the send.
!
      if (cpl_index /= PRISM_UNDEFINED) then
         n = mp%send_infos_coupler(cpl_index)%nloc
!

#ifdef DEBUGX
         print *, ' Preparing Isend to ', sender, 'with tag ', tag, &
                  ' request ', lrequest, ' of size ', n*ndim_3d
#endif /* DEBUGX */

         call MPI_Isend (mp%send_infos_coupler(cpl_index)%dstijk, n*ndim_3d, &
                         MPI_INTEGER, &
                         sender, tag, comm_psmile, lrequest, ierror)
!
         if (ierror /= MPI_SUCCESS) then
            ierrp (1) = ierror
            ierrp (2) = sender
            ierrp (3) = tag
            ierror = PRISM_Error_Send

            call psmile_error (ierror, 'MPI_Isend', &
                               ierrp, 3, __FILE__, __LINE__ )
            return
         endif
!
         call MPI_request_free (lrequest, ierror)
         if (ierror /= MPI_SUCCESS) then
            ierrp (1) = ierror
            ierror = PRISM_Error_MPI

            call psmile_error (ierror, 'MPI_Request_free', &
                               ierrp, 1, __FILE__, __LINE__ )
            return
         endif

      endif
!
!===> Transfer grid indices of points to be received directly
!     The message is received after the previous message is found by
!     the receiving process. Therefore, we don't wait for the
!     completion of the send.
!
      if (dir_index /= PRISM_UNDEFINED) then
         send_info => mp%send_infos_direct(dir_index)
!
!  ........ Send info on "n" points to be received
!
         n = 0
         do i = 1, send_info%nparts
            n = n + Product(send_info%npoints (1:send_info%nvec,i))
         enddo

#ifdef PRISM_ASSERTION
         ntot = n
#endif
         if (n > 0) then
#ifdef DEBUGX
            print *, ' Preparing Isend to ', sender, 'with tag ', tag, &
                     ' request ', lrequest, ' of size ', n*ndim_3d
#endif /* DEBUGX */
            call MPI_Isend (send_info%dstijk, n*ndim_3d, MPI_INTEGER, &
                            sender, tag, comm_psmile, lrequest, ierror)
!
            if (ierror /= MPI_SUCCESS) then
               ierrp (1) = ierror
               ierrp (2) = sender
               ierrp (3) = tag
               ierror = PRISM_Error_Send

               call psmile_error (ierror, 'MPI_Isend(dstijk)', &
                                  ierrp, 3, __FILE__, __LINE__ )
               return
            endif
!
            call MPI_request_free (lrequest, ierror)
            if (ierror /= MPI_SUCCESS) then
               ierrp (1) = ierror
               ierror = PRISM_Error_MPI

               call psmile_error (ierror, 'MPI_Request_free', &
                                  ierrp, 1, __FILE__, __LINE__ )
               return
            endif
         endif
!
!  ........ Send info on clustered receive areas
!
!        n = Sum(send_info%nars (1:send_info%nvec, 1:send_info%nparts))
         n = send_info%nars(1,1)

         if (n > 0) then

#ifdef PRISM_ASSERTION
!
! ........  Control internal restrictions
!
            if (send_info%nvec > 1 .or. send_info%nparts > 1) then
               print *, 'nvec nparts', send_info%nvec, send_info%nparts
               call psmile_assert ( __FILE__, __LINE__, &
                  'Routine is designed only for nvec = nparts = 1 for clustered areas')
            endif
!
! ........  Control consistency in number of locations
!
               do nar = 1, n
               ntot = ntot +                                                &
                      (send_info%dstars(2,1,nar)-send_info%dstars(1,1,nar)+1) * &
                      (send_info%dstars(2,2,nar)-send_info%dstars(1,2,nar)+1) * &
                      (send_info%dstars(2,3,nar)-send_info%dstars(1,3,nar)+1)
               end do

            if (ntot /= send_info%nloc) then
               print *, 'nloc, ntot, nars', send_info%nloc, ntot, n
               call psmile_assert ( __FILE__, __LINE__, &
                   "nloc doesn't match npoints + SUM(clustered areas)")
            endif
#endif

!
! ........ Send extensions of "n" clusted areas
!
#ifdef DEBUGX
            print *, ' Preparing Isend to ', sender, 'with tag ', tag, &
                     ' request ', lrequest, ' of size ', n*ndim_3d
#endif /* DEBUGX */
            call MPI_Isend (send_info%dstars, n*2*ndim_3d,             &
                            MPI_INTEGER, sender, tag, comm_psmile,     &
                            lrequest, ierror)
!
            if (ierror /= MPI_SUCCESS) then
               ierrp (1) = ierror
               ierrp (2) = sender
               ierrp (3) = tag
               ierror = PRISM_Error_Send

               call psmile_error (ierror, 'MPI_Isend(dstars)', &
                                  ierrp, 3, __FILE__, __LINE__ )
               return
            endif
!
            call MPI_request_free (lrequest, ierror)
            if (ierror /= MPI_SUCCESS) then
               ierrp (1) = ierror
               ierror = PRISM_Error_MPI

               call psmile_error (ierror, 'MPI_Request_free', &
                                  ierrp, 1, __FILE__, __LINE__ )
               return
            endif
         endif

      endif
!
!===> All done
!     TODO: Nach dem Ende der Send Requests kann man dstijk und dstars
!           free'en.
!
#ifdef VERBOSE
      print 9980, trim(ch_id), ierror

      call psmile_flushstd
#endif /* VERBOSE */
!
!  Formats:
!

#ifdef VERBOSE

9990 format (1x, a, ': psmile_send_destinations: cpl/dir index ', 2i10)
9980 format (1x, a, ': psmile_send_destinations: eof ierror =', i3)

#endif /* VERBOSE */

      end subroutine PSMILe_Send_destinations