psmile_enddef_action_sel.F90

Go to the documentation of this file.

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

      subroutine psmile_enddef_action_sel (sender, ierror)
!
! !USES:
!
      use PRISM_constants
!
      use PSMILe, dummy_interface => PSMILe_Enddef_action_sel

      Implicit none
!
! !INPUT PARAMETERS:
!
      Integer, Intent (In)            :: sender
!
!     Rank of sending process in communicator "comm_psmile".
!
! !OUTPUT PARAMETERS:
!
      Integer, Intent (Out)           :: ierror

!     Returns the error code of PSMILe_Enddef_action_sel
!             ierror = 0 : No error
!             ierror > 0 : Severe error
!
! !LOCAL VARIABLES
!
!     ... Method pointer
!
      Type (Method),         Pointer  :: mp

!     ... Loop variables

      Integer                         :: i

!     ... Info on point selected

      Type (Send_appl_information), Pointer :: send_info
      Integer                         :: index, n_liste, nsel
      Integer,               Pointer  :: neigh_3d (:, :)

!     ... for communication

      Integer, Allocatable            :: ibuf (:)
      Integer                         :: status (MPI_STATUS_SIZE)
!
!     ... for error handling
!
      Integer, Parameter              :: nerrp = 1
      Integer                         :: ierrp (nerrp)
!
! !DESCRIPTION:
!
! Subroutine "PSMILe_Enddef_action_sel" performs the actions for
! the selected points of the (global) neaerest neighbour search.
!
! The data is sent by routine "PSMILe_select_nn_found" in the process
! for which the global nearest neighbour locations were searched.
!
! !REVISION HISTORY:
!
!   Date      Programmer   Description
! ----------  ----------   -----------
! 10.11.06    H. Ritzdorf  created
!
!EOP
!----------------------------------------------------------------------
!
!  $Id: psmile_enddef_action_sel.F90 2082 2009-10-21 13:31:19Z hanke $
!  $Author: hanke $
!
   Character(len=len_cvs_string), save :: mycvs = 
       '$Id: psmile_enddef_action_sel.F90 2082 2009-10-21 13:31:19Z hanke $'
!
!----------------------------------------------------------------------
!
!  Initialization
!
#ifdef VERBOSE
      print 9990, trim(ch_id), sender

      call psmile_flushstd
#endif /* VERBOSE */
!
#ifdef PRISM_ASSERTION
      if (paction%lrequest(5) /= MPI_REQUEST_NULL) then
         call psmile_assert ( __FILE__, __LINE__, &
                              'paction%lrequest(5) should be MPI_REQUEST_NULL !')
      endif
!
      if (paction%msg_sel (1) /= PSMILe_nnghbr3D) then
         print *, 'msg_sel(1)', paction%msg_sel (1), PSMILe_nnghbr3D
         call psmile_assert ( __FILE__, __LINE__, &
                             'Incorrect message received !')
      endif
!
      if (paction%msg_sel (2) < paction%msg_sel (3)) then
         print *, 'msg_sel(2:3)', paction%msg_sel (2:3)
         call psmile_assert ( __FILE__, __LINE__, &
                             'n_liste must be >= nsel !')
      endif
!
      if (paction%msg_sel (5) < 1 .or.                            &
          paction%msg_sel (5) > Number_of_Methods_allocated) then
         print *, trim(ch_id), "method id =", &
                  paction%msg_sel (5), Number_of_Methods_allocated
         call psmile_assert ( __FILE__, __LINE__, &
                             "invalid method id")
      endif
!
      if (paction%n_selected < 1) then
         print *, "n_selected", paction%n_selected
         call psmile_assert ( __FILE__, __LINE__, &
                              'No request outstanding !')
      endif
#endif
!
!===> Decrement number of outstanding requests
!
      paction%n_selected = paction%n_selected - 1
!
      n_liste = paction%msg_sel (2)
      nsel    = paction%msg_sel (3)
      index   = paction%msg_sel (4)
#ifdef DEBUG
      print *, 'nsel, nliste', nsel, n_liste
#endif
!
      mp        => Methods (paction%msg_sel (5))
      send_info => mp%send_infos_appl(index)
!
#ifdef PRISM_ASSERTION
      if (index < 1 .or. index > mp%n_send_info_appl) then
         print *, "index", index, mp%n_send_info_appl
         call psmile_assert ( __FILE__, __LINE__, &
                              'invalid send_info_appl index !')
      endif
!
      if (send_info%dest /= sender) then
         call psmile_assert ( __FILE__, __LINE__, &
                              "Sender doesn't fit !")
      endif
#endif
!
      if (nsel == 0) then
!
!===> ... No point by target process selected
!
         send_info%nloc   = 0

         Deallocate (send_info%neigh_3d)
         Nullify    (send_info%neigh_3d)
!
#ifdef TODO
! TODO: index freigeben, 
!
         if (mp%n_send_info_appl == index) then
!           call psmile_free_info_index ?
!  oder     mp%n_send_info_appl = mp%n_send_info_appl - 1
!
! fieldout%n_send_appl decrementieren
!           call psmile_delete_send_info (send_appl_index)
         endif
#endif

      else if (nsel < n_liste) then
!
!===> ... Not all points required/selected by the target process
!         Extract points
!
         send_info%nloc = nsel
!
         Allocate (neigh_3d(ndim_3d, nsel), ibuf (nsel), stat = ierror)
!
         if (ierror /= 0) then
            ierrp (1) = ndim_3d * nsel + nsel

            ierror = PRISM_Error_Alloc

            call psmile_error ( ierror, 'neigh_3d', ierrp, 1, &
                   __FILE__, __LINE__ )
            return
         endif
!
         call MPI_Recv (ibuf, nsel, MPI_INTEGER,     &
                        sender, seltag, comm_psmile, &
                        status, ierror)
         if ( ierror /= MPI_SUCCESS ) then
            ierrp (1) = ierror
            ierror = PRISM_Error_MPI

            call psmile_error ( ierror, 'MPI_Recv(ibuf)', ierrp, 1, &
                                __FILE__, __LINE__ )
            return
         endif
!
!cdir vector
            do i = 1, nsel
            neigh_3d (:, i) = send_info%neigh_3d (:, ibuf(i))
            end do

         Deallocate (send_info%neigh_3d)
         Deallocate (ibuf)
!
         send_info%neigh_3d => neigh_3d
         send_info%nloc     = nsel
      endif
!
!===> ... Set up new request if required
!
      if (paction%n_selected > 0) then
         call MPI_Irecv (paction%msg_sel, nd_msgsel, MPI_INTEGER, &
                         MPI_ANY_SOURCE, seltag, comm_psmile,     &
                         paction%lrequest(5), ierror)

         if ( ierror /= MPI_SUCCESS ) then
            ierrp (1) = ierror
            ierror = PRISM_Error_MPI

            call psmile_error ( ierror, 'MPI_Irecv(seltag)', ierrp, 1, &
                                __FILE__, __LINE__ )
            return
         endif
      endif
!
!===> All done
!
#ifdef VERBOSE
      print 9980, trim(ch_id), ierror

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

#ifdef VERBOSE

9990 format (1x, a, ': psmile_enddef_action_sel: sender ', i6)
9980 format (1x, a, ': psmile_enddef_action_sel: eof ierror =', i3)

#endif /* VERBOSE */

      end subroutine PSMILe_Enddef_action_sel