psmile_add_nn_found_dble.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_Add_nn_found_dble
!
! !INTERFACE:

      subroutine psmile_add_nn_found_dble (search, extra_search,  &
                        index_sent, found, n_send,                &
                        index_found, distance, n_found, nb_extra, &
                        selected, sel_info, nrecv, ierror)
!
! !USES:
!
      use PRISM
!
      use PSMILe, dummy_interface => PSMILe_Add_nn_found_dble

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

!     Info's on coordinates to be searched
!
      Integer,           Intent (In)     :: n_send
!
!     Number of points for which additional interpolation data was found.
!     Dimension "indices_returned".

      Integer,            Intent (In)    :: index_sent (n_send)
!
!     Indices (in dist_dble/indices) of points which were 
!     transferred to neighbour process for global search.
!     1 <= index_sent (i) <= search%n_extra
!
      Integer,            Intent (In)    :: found (n_send)
!
!     Number of nearest neighbours found for each point sent.

      Integer,            Intent (In)    :: n_found
!
!     Total number of points found which are used for interpolation.
!     Dimension of "index_found" and "distance".
!
      Integer,            Intent (In)    :: index_found (n_found)
!
!     Index of n-th point in compact list "liste"
!     Mapping of sequence of points found (1:n_found) to (1:n_liste)
!
      Double Precision,   Intent (In)    :: distance (n_found)
!
!     Nearest neighbour distance for each point found,

      Integer,            Intent (In)    :: nb_extra
!
!     Number of nearest neigbhbours to be searched per extra point
!
!     Integer,            Intent (In)    :: use_how

!     Information about how to apply the mask

      Integer,            Intent (InOut) :: nrecv

!     Number of the request received

! !INPUT/OUTPUT PARAMETERS:
!
      Type (Extra_search_info), Intent (InOut) :: extra_search
!
!     Number of locations where
!       (*) required mask values were not true
!
      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)
!
!     Info on the data received which is used to select 
!     the appropriate points.
!     
!
! !OUTPUT PARAMETERS:
!
      Integer,            Intent (Out)   :: ierror

!     Returns the error code of PSMILe_Add_nn_found_dble;
!             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, n
!
!     ... 
!
      Integer                         :: n_liste, nsel
      Integer                         :: prev
      Integer,          Pointer       :: used (:)
      Double Precision, Pointer       :: dist_dble (:, :)
!
!     ... for communication
!
      Integer                         :: msg_sel (nd_msgsel)
!
!     ... for error handling
!
      Integer, Parameter              :: nerrp = 3
      Integer                         :: ierrp (nerrp)
!
! !DESCRIPTION:
!
! Subroutine "PSMILe_Add_nn_found_dble" add information on
! points found by global search to the already existing information.
!
! !REVISION HISTORY:
!
!   Date      Programmer   Description
! ----------  ----------   -----------
! 02.11.06    H. Ritzdorf  created
!
!EOP
!----------------------------------------------------------------------
!
!  $Id: psmile_add_nn_found_dble.F90 2082 2009-10-21 13:31:19Z hanke $
!  $Author: hanke $
!
   Character(len=len_cvs_string), save :: mycvs = 
       '$Id: psmile_add_nn_found_dble.F90 2082 2009-10-21 13:31:19Z hanke $'
!
!----------------------------------------------------------------------
!
!  Initialization
!
#ifdef VERBOSE
      print 9990, trim(ch_id), n_send, n_found, sel_info(nrecv)%n_liste

      call psmile_flushstd
#endif /* VERBOSE */
!
      ierror = 0
!
      dist_dble => extra_search%dist_dble
!
!  n_liste = Number of points in the compact list
!
      n_liste = sel_info(nrecv)%n_liste
!
#ifdef PRISM_ASSERTION
!
!===> Internal control
!
!     n_liste <= n_found <= n_send
!
!cdir vector
         do i = 1, n_found
         if (index_found (i) <= 0 .and. &
             index_found (i) /= masked_out) exit
         end do
!
      if (i <= n_found) then
         print *, 'i, n_found, index_found', i, n_found, index_found (i)
         call psmile_assert ( __FILE__, __LINE__, &
                 'invalid index in found list')
      endif
!
!cdir vector
         do i = 1, n_found
         if (index_found (i) > n_liste) exit
         end do
!
      if (i <= n_found) then
         print *, 'i, n_found, index_found, n_liste', &
                   i, n_found, index_found (i), n_liste
         call psmile_assert ( __FILE__, __LINE__, &
                 'invalid index (> n_liste) in found list')
      endif
!
#endif
!
!===> Allocate and initialize vector "used" for compact list
!     of points sent.
!
      Allocate (sel_info(nrecv)%used(n_liste), stat = ierror)
      if (ierror /= 0) then
         ierrp (1) = n_liste

         ierror = PRISM_Error_Alloc

         call psmile_error ( ierror, 'sel_info(nrecv)%used', ierrp, 1, &
                     __FILE__, __LINE__ )
         return
      endif
!
      used => sel_info(nrecv)%used
!
      used (:) = 0
!
!cdir vector
         do n = 1, n_found
         if (index_found(n) > 0) then
            used (index_found(n)) = used (index_found(n)) + 1
         endif
         end do 
!
!===> Control distances found in neighbouring block
!
! 1 <= i <= n_extra : Index in list of extra points for
!                     which nearest neighbours have to be found.
! 1 <= j <= n_send  : Index in list of points sent (to the process
!                     which should search for nearest neighbours)
! 1 <= n <= n_found : Index in sequence of points found (by the process
!                     which has searched for nearest neigbours)
!                    
! nsel = Number of points selected from the list of points found
!
      nsel = 0
      n = 0
         do j = 1, n_send
         if (found (j) > 0) then
            n = n + 1
            if (index_found(n) > 0) then
               i = index_sent (j)

#ifdef DEBUGX
               print *, 'psmile_add_nn_found_dble: n, j, i, i_liste, dists', &
                        n, j, i, index_found(n), dist_dble (i,1), distance (n)
#endif

               if (dist_dble (i,1) <= distance (n)) then
!
!===> ... Distance is not smaller than distance which was already found.
!         Remove point from list of points.
!         Index_found(n) is index in compact list of points
!
                  used (index_found(n)) = used (index_found(n)) - 1

               else

!           Select this point
!           If previous point was already selected by
!           another global search, remove this point
!
                  if (selected (1, i) > 0) then
                     prev = selected (1, i)

#ifdef PRISM_ASSERTION
                     if (prev > nrecv) then
                        print *, trim(ch_id), "prev, nrecv", prev, nrecv
                        call psmile_assert ( __FILE__, __LINE__, &
                                'invalid recv request')
                     endif
#endif

                     sel_info(prev)%used (selected (2, i)) =   &
                     sel_info(prev)%used (selected (2, i)) - 1
                  endif
!
                  nsel = nsel + 1
!
                  dist_dble (i,1) = distance (n)
                  selected (1, i) = nrecv
                  selected (2, i) = index_found(n)
               endif
            endif
         endif
         end do
!
!===> Remove points which are masked out
!
!     if (use_how /= PSMILE_novalue) then
!     endif
!
!===> If no point was selected, remove vector "used"
!
      if (nsel == 0) then
!
!        Return answer to sending process
!
!  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) = index
!  msg_sel (5) = method id
!
         msg_sel (1) = PSMILe_nnghbr3D
         msg_sel (2) = n_liste
         msg_sel (3) = 0
         msg_sel (4) = sel_info(nrecv)%index
         msg_sel (5) = sel_info(nrecv)%method_id
!
!===> ... Send message header to destination process
!
         call MPI_Send (msg_sel, nd_msgsel, MPI_INTEGER, &
                        sel_info(nrecv)%sender, seltag, comm_psmile, ierror)
!
         if (ierror /= MPI_SUCCESS) then
            ierrp (1) = ierror
            ierrp (2) = sel_info(nrecv)%sender
            ierrp (3) = seltag

            ierror = PRISM_Error_Send

            call psmile_error (ierror, 'MPI_send (msg_sel)', ierrp, 3, &
                        __FILE__, __LINE__ )
            return
         endif
!
!===> ... Free memory
!
         Deallocate (sel_info(nrecv)%used)
         Deallocate (sel_info(nrecv)%dble_buf)
!
!===> ... Decrement number of recv's
!
         nrecv = nrecv - 1
      endif
!
!===> All done
!
#ifdef VERBOSE
      print 9980, trim(ch_id), ierror, nsel

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

#ifdef VERBOSE

9990 format (1x, a, ': psmile_add_nn_found_dble: n_send', i7, &
             '; n_found', i7, '; n_liste ', i7)
9980 format (1x, a, ': psmile_add_nn_found_dble: eof ierror =', i3, &
             '; nsel', i7)

#endif /* VERBOSE */

#ifdef DEBUG
#endif

      end subroutine PSMILe_Add_nn_found_dble