psmile_select_nn_found.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_Select_nn_found
!
! !INTERFACE:

      subroutine psmile_select_nn_found (search, extra_search,    &
                        send_info,                                &
                        selected, sel_info, nrecv, nb_extra,      &
                        neighbors_3d, nloc, num_neigh,            & 
                        grid_valid_shape, ierror)
!
! !USES:
!
      use PRISM
!
      use PSMILe, dummy_interface => PSMILe_Select_nn_found

      Implicit none
!
! !INPUT PARAMETERS:
!
      Type (Enddef_search),     Intent (In) :: search

!     Info's on coordinates to be searched
!
      Integer,                  Intent (In) :: nb_extra
!
!     Number of nearest neigbhbours to be searched per extra point
!
      Integer,            Intent (In)    :: nloc
!
!     Total  Number of locations to be transferred
!     Last dimension of neighbors array "neighbors_3d" and
!     number of neighbors to be searched.

      Integer,            Intent (In)    :: num_neigh
!
!     Last dimension of neighbors array "neighbors_3d" and
!     number of neighbors to be searched.

      Integer,            Intent (In)    :: grid_valid_shape (2, ndim_3d)

!     Specifies the valid block shape for the "ndim_3d"-dimensional block

!     Integer,            Intent (In)    :: use_how

!     Information about how to apply the mask

! !INPUT/OUTPUT PARAMETERS:
!
      Integer,                  Intent (InOut) :: nrecv

!     Number of requests received
!     On return, number of requestes to be received in put call.

      Type (Extra_search_info), Intent (InOut) :: extra_search
!
!     Number of locations where
!       (*) required mask values were not true
!
      Type (Send_information),  Intent (InOut) :: send_info
!
!     Information on the actual send infos to the coupler
!     (contains also info on receives from neighbouring processes)
!
      Integer,                  Intent (InOut) :: selected (2, extra_search%n_extra)
!
!     Vector for global nearest neighbour search of extra points with
!        selected (1, *) = Number (index) of the receive
!                          from which the nearest neigbour was selected.
!                          = 0 : Nearest neighour was found locally
!        selected (2, *) = Index in list of points 
!                          (sent by neighbouring process)
!

      Type (Select_search_info), Intent (InOut) :: sel_info (nrecv)
!
!
      Integer,            Intent (InOut) :: neighbors_3d (ndim_3d, nloc, 
                                                          num_neigh)
!
! !OUTPUT PARAMETERS:
!
      Integer,            Intent (Out)   :: ierror

!     Returns the error code of PSMILe_Select_nn_found;
!             ierror = 0 : No error
!             ierror > 0 : Severe error
!
! !LOCAL PARAMETERS:
!
! masked_out   = Hash value for a point which is masked out
!
      Integer, Parameter           :: masked_out = 0
!
! !LOCAL VARIABLES
!
!     ... loop variables
!
      Integer                         :: i, j, k, n
!
!     ... 
!
      Integer                         :: ndibuf
      Integer                         :: n_liste, nprev_recv
      Integer,            Pointer     :: used (:), ibuf (:)
      Integer,            Pointer     :: indices (:)
!
!     ... reallocated vectors
!
      Integer                         :: nold
      Integer,            Pointer     :: len_sent (:)
      Integer,            Pointer     :: sender_global (:)
      Integer,            Pointer     :: msg_id (:)
      Type (dble_vector), Pointer     :: dble_bufs (:)
      Type (real_vector), Pointer     :: real_bufs (:)
!
!     ... for returning used data info to sender
!
      Integer                         :: nreq, sender
      Integer                         :: msg_sel (nd_msgsel), req (2)
#ifndef PRISM_with_MPI2
      Integer                         :: statuses (MPI_STATUS_SIZE, 2)
#endif
!
!     ... for error handling
!
      Integer, Parameter              :: nerrp = 3
      Integer                         :: ierrp (nerrp)
!
! !DESCRIPTION:
!
! Subroutine "PSMILe_Select_nn_found" add information on
! points found by global search to the already existing information.
!
! The points in "neighbors_3d" for which the globally searched
! value is used are marked with "neighbors_3d(1, i, *) = extra_search%global_marker"
!
! !REVISION HISTORY:
!
!   Date      Programmer   Description
! ----------  ----------   -----------
! 02.11.06    H. Ritzdorf  created
!
!EOP
!----------------------------------------------------------------------
!
!  $Id: psmile_select_nn_found.F90 2799 2010-12-03 14:33:35Z hanke $
!  $Author: hanke $
!
   Character(len=len_cvs_string), save :: mycvs = 
       '$Id: psmile_select_nn_found.F90 2799 2010-12-03 14:33:35Z hanke $'
!
!----------------------------------------------------------------------
!
!  Initialization
!
#ifdef VERBOSE
      print 9990, trim(ch_id), nrecv

      call psmile_flushstd
#endif /* VERBOSE */
!
      ierror = 0
      ndibuf = 0
      nprev_recv = send_info%num2recv

      indices    => extra_search%indices

      sel_info(1:nrecv)%num_req = (/ (i, i=1,nrecv) /)
!     outside       = grid_valid_shape(2,1) + 11
#ifdef PRISM_ASSERTION
!
!===> Internal control
!
      if (nb_extra > 1) then
         call psmile_assert (__FILE__, __LINE__, &
                     'nb_extra > 1 currently not supported')
      endif
#endif
!
!===> Prepare answer message on used data
!     Note: The data is received by routine "psmile_enddef_action_sel"
!
!  msg_sel (1) = Code
!  msg_sel (2) = Number of entries in original compact list
!  msg_sel (3) = Number of entries in new      compact list
!  msg_sel (4) = Send info index (of sending process)
!  msg_sel (5) = Method id (in sending process)
!
      msg_sel (1) = PSMILe_nnghbr3D
!
!===> For all receives
!
      i = 1
      do while ( i <= nrecv)
         used => sel_info(i)%used
         n_liste = sel_info(i)%n_liste
         sender  = sel_info(i)%sender

         n = Count (used > 0)
#ifdef DEBUGX
         print *, 'psmile_select_nn_found: i, sender, n, n_liste', &
                  i, sender, n, n_liste 
#endif

         msg_sel (2) = n_liste
         msg_sel (3) = n
         msg_sel (4) = sel_info(i)%index
         msg_sel (5) = sel_info(i)%method_id
!
         nreq = 1
!
!===> ... Send message header to destination process
!
         call MPI_Isend (msg_sel, nd_msgsel, MPI_INTEGER, &
                         sender, seltag, comm_psmile, req(1), ierror)
!
         if (ierror /= MPI_SUCCESS) then
            ierrp (1) = ierror
            ierrp (2) = sender
            ierrp (3) = seltag

            ierror = PRISM_Error_Send

            call psmile_error (ierror, 'MPI_Isend (msg_sel)', ierrp, 3, &
                        __FILE__, __LINE__ )
            return
         endif

         if (n == 0) then
!
!===> ... Nothing used from this sender
!     ... Free memory
!
            if (search%datatype == MPI_REAL) then
               Deallocate (sel_info(i)%real_buf)

            else if (search%datatype == MPI_DOUBLE_PRECISION) then
               Deallocate (sel_info(i)%dble_buf)

#if defined ( PRISM_QUAD_TYPE )
            else if (search%datatype == MPI_REAL16) then
               Deallocate (sel_info(i)%quad_buf)
#endif
            endif
                  
            Deallocate (sel_info(i)%used)
!
!===> ... Overwrite current entry
!
            if (i /= nrecv) then
               sel_info(i:nrecv-1) = sel_info(i+1:nrecv)
            endif

!===> ... Decrement number of receives and continue

            nrecv = nrecv - 1

            cycle
         endif
!
!===> Data used from the sender
!     Return list of points used to sender
!
         if (n < n_liste) then
            if (n > ndibuf) then
               if (ndibuf > 0) then
                  Deallocate (ibuf)
               endif
!
               Allocate (ibuf (n), stat = ierror)
               if (ierror /= 0) then
                  ierrp (1) = ierror
                  ierrp (2) = n

                  ierror = PRISM_Error_Alloc

                  call psmile_error ( ierror, 'ibuf', ierrp, 2, &
                              __FILE__, __LINE__ )
                  return
               endif

               ndibuf = n
           endif
!
!===> ... Pack indices of used values
!
#ifdef USE_PACK
            ibuf (1:n) = PACK ((/ (j, j=1,n_liste) /), used(:) > 0)
#else
            k = 0
!cdir vector
            do j = 1, n_liste
               if (used(j) > 0) then
                  k = k + 1
                  ibuf (k) = j
               endif
            end do
!
#ifdef PRISM_ASSERTION
            if (k /= n) then
               print *, trim(ch_id), ": k, n", k, n
               call psmile_assert (__FILE__, __LINE__, &
                           'Inconsistent number of used points')
            endif
         
#endif
#endif /* USE_PACK */
!
!===> ... Send new compact list "ibuf" to sender
!
            call MPI_Isend (ibuf, n, MPI_INTEGER, &
                            sender, seltag, comm_psmile, req(2), ierror)
!
            if (ierror /= MPI_SUCCESS) then
               ierrp (1) = ierror
               ierrp (2) = sender
               ierrp (3) = seltag

               ierror = PRISM_Error_Send

               call psmile_error (ierror, 'MPI_Isend (ibuf)', ierrp, 3, &
                           __FILE__, __LINE__ )
               return
            endif
!
            nreq = 2
!
!===> ... Generate transformation from 
!         original compact list (1:nliste) into new compact list (1:n).
!         Note: this is the invers of "ibuf"
!
            k = 0
!cdir vector
            do j = 1, n_liste
               if (used (j) > 0) then
                  k = k + 1
                  used (j) = k
               endif
            end do
!
!===>
!      selected (2,j) = Index in original compact list
! used(selected (2,j) = Index in the new  compact list.
!
! the point is marked with
! the global marker in 1st index and
! the index in the complete list is stored in 2nd index of "neighbors_3d".
!
!cdir vector
            do j = 1, extra_search%n_extra
               if (selected(1,j) == sel_info(i)%num_req) then
                  neighbors_3d (1, indices(j), 1) = extra_search%global_marker
                  neighbors_3d (2, indices(j), 1) = used(selected (2,j)) + nprev_recv
               endif
            enddo
!
!===> ... update info
!         Note: The coordinates are separatedly stored in dble_buf.
!
             sel_info(i)%n_liste = n
!
             if (search%datatype == MPI_REAL) then

                call psmile_assert (__FILE__, __LINE__, "TODO")

             else if (search%datatype == MPI_DOUBLE_PRECISION) then

!            call psmile_compress_coords_dble (extra_search%dble_bufs(i),
!                 n_liste, ibuf, n, ierror)
#ifdef DEBUG
              print *, 'psmile_select_nn_found: #### real implementation is needed !!!'
#endif
!cdir vector
               do j = 1, n
                  if (search%datatype == MPI_REAL) then
                     sel_info(i)%real_buf(j)     = sel_info(i)%real_buf(ibuf(j))
                     sel_info(i)%real_buf(j+n)   = sel_info(i)%real_buf(ibuf(j)+n_liste)
                     sel_info(i)%real_buf(j+n*2) = sel_info(i)%real_buf(ibuf(j)+n_liste*2)
                  else if (search%datatype == MPI_DOUBLE_PRECISION) then
                     sel_info(i)%dble_buf(j)     = sel_info(i)%dble_buf(ibuf(j))
                     sel_info(i)%dble_buf(j+n)   = sel_info(i)%dble_buf(ibuf(j)+n_liste)
                     sel_info(i)%dble_buf(j+n*2) = sel_info(i)%dble_buf(ibuf(j)+n_liste*2)
                  endif
               end do
#if defined ( PRISM_QUAD_TYPE )
            else if (search%datatype == MPI_REAL16) then

                call psmile_assert (__FILE__, __LINE__, "TODO")

#endif
            endif
!
         else
!cdir vector
            do j = 1, extra_search%n_extra
               if (selected(1,j) == sel_info(i)%num_req) then
                  neighbors_3d (1, indices(j), 1) = extra_search%global_marker
                  neighbors_3d (2, indices(j), 1) = selected (2,j) + nprev_recv
               endif
            enddo
         endif
!
         Deallocate (sel_info(i)%used)
!
!===> ... next receive entry
!
         nprev_recv = nprev_recv + n
         i = i + 1
!
!===> ... wait for end of transfer
!
#ifdef PRISM_with_MPI2
         call MPI_Waitall (nreq, req, MPI_STATUSES_IGNORE, ierror)
#else
         call MPI_Waitall (nreq, req, statuses,            ierror)
#endif
!
         if (ierror /= MPI_SUCCESS) then
            ierrp (1) = ierror

            ierror = PRISM_Error_MPI

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

      enddo !while ( i <= nrecv)
!
!===> Free buffer if necessary
!
      if (ndibuf > 0) then
         Deallocate (ibuf)
      endif
!
!===> Save number of data to be received in "extra_search"
!
      if (nrecv > 0) then
!
!===> ... Extend vectors 
!
         nold = send_info%nrecv
         n = send_info%nrecv + nrecv
!
         Allocate (len_sent(n), sender_global(n), dble_bufs(n), &
                   real_bufs(n), msg_id(n), stat = ierror)
         if (ierror /= 0) then
            ierrp (1) = ierror
            ierrp (2) = n * 3

            ierror = PRISM_Error_Alloc

            call psmile_error ( ierror, 'len_sent, ...', ierrp, 2, &
                        __FILE__, __LINE__ )
            return
         endif
!
         if (nold > 0) then
            len_sent(1:nold)      = send_info%len_sent (1:nold)
            sender_global(1:nold) = send_info%sender_global (1:nold)
            msg_id(1:nold)        = send_info%msg_id (1:nold)
!
            if (search%datatype == MPI_REAL) then

               do i = 1, nold
                  real_bufs(i)%vector => extra_search%real_bufs(i)%vector
               enddo

               Deallocate (extra_search%real_bufs)

            else if (search%datatype == MPI_DOUBLE_PRECISION) then
!cdir vector
               do i = 1, nold
                  dble_bufs(i)%vector => extra_search%dble_bufs(i)%vector
               enddo 

               Deallocate (extra_search%dble_bufs)
#if defined ( PRISM_QUAD_TYPE )
            else if (search%datatype == MPI_REAL16) then
#endif
            endif


            Deallocate (send_info%len_sent, send_info%sender_global, send_info%msg_id)
         endif

!cdir vector
         do i = 1, nrecv
            len_sent (nold+i)        = sel_info(i)%n_liste
            sender_global (nold+i)   = sel_info(i)%sender
            msg_id(nold+i)           = sel_info(i)%msg_id
            if (search%datatype == MPI_REAL) then
               real_bufs(nold+i)%vector => sel_info(i)%real_buf
            else if (search%datatype == MPI_DOUBLE_PRECISION) then
               dble_bufs(nold+i)%vector => sel_info(i)%dble_buf
            endif
         end do
!
         send_info%len_sent      => len_sent
         send_info%sender_global => sender_global
         send_info%msg_id        => msg_id

         if (search%datatype == MPI_REAL) then
            extra_search%real_bufs  => real_bufs
         else if (search%datatype == MPI_DOUBLE_PRECISION) then
            extra_search%dble_bufs  => dble_bufs
         endif
!
#ifdef DEBUGX
         print *, 'psmile_select_nn_found: nold, nrecv, num2recv, nprec_recv', &
                   nold, nrecv, send_info%num2recv, nprev_recv
         print *, 'psmile_select_nn_found: len_sent', len_sent(1), len_sent(2)
#endif

         send_info%nrecv    = nold + nrecv
         send_info%num2recv = nprev_recv
!
#ifdef PRISM_ASSERTION
         if (send_info%num2recv /= &
             SUM (send_info%len_sent(1:send_info%nrecv))) then
            print *, 'num2recv', send_info%num2recv, &
                     SUM (send_info%len_sent(1:send_info%nrecv)), &
                     send_info%nrecv
            call psmile_assert (__FILE__, __LINE__, &
                 "inconsistent num2recv")
         endif
#endif
      endif
!
!===> All done
!
#ifdef VERBOSE
      print 9980, trim(ch_id), ierror, nrecv

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

9990 format (1x, a, ': psmile_select_nn_found: nrecv', i7)
9980 format (1x, a, ': psmile_select_nn_found: eof ierror =', i3, &
             '; nrecv', i7)

#endif /* VERBOSE */

#ifdef DEBUG
#endif

      end subroutine PSMILe_Select_nn_found