psmile_search_donor_extra_nn.F90

Go to the documentation of this file.

! #include "psmile.prep"
!-----------------------------------------------------------------------
! Copyright 2006-2010, NEC Europe Ltd., London, UK.
! All rights reserved. Use is subject to OASIS4 license terms.
!-----------------------------------------------------------------------
!BOP
!
! !ROUTINE: PSMILe_Search_donor_extra_nn
!
! !INTERFACE:

      subroutine psmile_search_donor_extra_nn (comp_info, search, &
                        var_id, tol, ierror)
!
! !USES:
!
      use PRISM
!
      use PSMILe, dummy_interface => PSMILe_Search_donor_extra_nn

      implicit none
!
! !INPUT PARAMETERS:
!
      Type (Enddef_comp),          Intent (In)    :: comp_info
!
!     Info on the component in which the donor cells
!     should be searched.

      Integer,                     Intent (In)    :: var_id

!     Handle to the grid function

      Double Precision,            Intent (In)    :: tol

!     Absolute tolerance for search of "identical" points
!     TOL >= 0.0

!
! !INPUT/OUTPUT PARAMETERS:
!
      Type (Enddef_global_search), Intent (InOut) :: search

!     Data on the points to be searched
!
! !OUTPUT PARAMETERS:
!
      Integer,                     Intent (Out)   :: ierror

!     Returns the error code of PSMILe_Search_donor_extra_nn;
!             ierror = 0 : No error
!             ierror > 0 : Severe error
!
! !LOCAL VARIABLES
!
!     ... field pointer
!
      Type (Gridfunction), Pointer  :: field
!
      Integer                       :: method_id
!
!     ... Grid pointer
!
      Type (Grid), Pointer          :: grid_info
      Integer                       :: datatype, grid_id
!
!     ... for points to be searched
!
! len_item = Length of a data item per point in search%ibuf
!
      Integer                       :: len_item, n_send
      Integer                       :: ip_dist, nb_extra
!
      Integer                       :: ip (ndim_3d)
      Real                          :: rtol

!     Integer                       :: shift (ndim_3d)
!
!     ... for masks
!         dummy_mask_array is a dummy array for to be
!         transferred to interpolation routines
!         Note: The target attributes (see !rr) were removed
!               since there problems with a compiler and array bound checking
!
      Integer                       :: mask_id
      Logical                       :: src_mask_available
!
      Logical, Target               :: dummy_mask_array (1)
!rr   Integer, target               :: dummy_mask_shape (2, ndim_3d)
      Integer                       :: dummy_mask_shape (2, ndim_3d)
!
      Logical, Pointer              :: mask_array (:) 
!rr   Integer, Pointer              :: mask_shape (:, :)
      Integer                       :: mask_shape (2, ndim_3d)
!
!     ... for locations found
!
      Integer                       :: i, n, nlocs
!
      Integer, Allocatable          :: nfound (:)
      Integer, Pointer              :: locations (:, :), locs (:, :)
      Integer, Allocatable          :: hash (:)
!
!     ... for error parameters
!
      Integer, Parameter            :: nerrp = 2
      Integer                       :: ierrp (nerrp)
!
! !DESCRIPTION:
!
! Subroutine "PSMILe_Search_donor_extra_nn" performs the additional (global)
! search for coordinates sent by the requesting process if nearest neigbour
! search is required.
!
! !REVISION HISTORY:
!
!   Date      Programmer   Description
! ----------  ----------   -----------
! 23.10.06    H. Ritzdorf  created
!
!EOP
!----------------------------------------------------------------------
!
! $Id: psmile_search_donor_extra_nn.F90 3112 2011-04-07 15:03:18Z hanke $
! $Author: hanke $
!
   Character(len=len_cvs_string), save :: mycvs = 
       '$Id: psmile_search_donor_extra_nn.F90 3112 2011-04-07 15:03:18Z hanke $'
!----------------------------------------------------------------------
!
!  Initialization
!
#ifdef VERBOSE
      print 9990, trim(ch_id), comp_info%comp_id, search%sender

      call psmile_flushstd
#endif /* VERBOSE */
!
      ierror = 0
!
      field     => Fields (var_id)
!
      method_id = field%method_id
      mask_id   = field%mask_id
!
      grid_id   = Methods(method_id)%grid_id
      grid_info => Grids (grid_id)
!
      src_mask_available = mask_id /= PRISM_UNDEFINED
!
      if (src_mask_available) then
         mask_array => Masks(mask_id)%mask_array
!rr      mask_shape => Masks(mask_id)%mask_shape
         mask_shape =  Masks(mask_id)%mask_shape
      else
         mask_array => dummy_mask_array
!rr      mask_shape => dummy_mask_shape
         mask_shape =  dummy_mask_shape
      endif
!
!  n_send   = Number of points to be searched
!  len_item = Number of pieces of information in integer buffer "ibuf".
!             #1  : Index in indices/dist_dble/send_mask of sending process
!
      n_send   = search%msg_extra%num_volumes
      len_item = search%msg_extra%num_int_per_vol
      nb_extra = search%msg_extra%num_neigh
!
#ifdef PRISM_ASSERTION
!
!===> Internal control
!
      if (search%msg_extra%reqest_type /= PSMILe_nnghbr3D) then
          call psmile_assert ( __FILE__, __LINE__, &
                              'Interpolation method must be Nearest Neighbour')
      endif
!
      if (search%msg_extra%num_items_per_coord < ndim_3d + 1 ) then
          call psmile_assert ( __FILE__, __LINE__, &
                              'expected at least len_rtem = 4')
      endif
!
#endif
!
#ifdef TODO_GLOBAL_COORDS
!  Transfer global grid indices from remote grid
!      into local  grid indices of  current grid
!  Weiss nicht, ob sich das wirklich fuer nearest neigbour lohnt ?
!
      shift (1:ndim_3d) = grid_info%grid_shape(1, 1:ndim_3d) - &
                          grid_info%partition (1, 1:ndim_3d) - 1
!
!cdir vector
          do i = 1, n_send
          search%ibuf ((i-1)*len_item+1) = &
          search%ibuf ((i-1)*len_item+1) + shift (1)
          search%ibuf ((i-1)*len_item+2) = &
          search%ibuf ((i-1)*len_item+2) + shift (2)
          search%ibuf ((i-1)*len_item+3) = &
          search%ibuf ((i-1)*len_item+3) + shift (3)
          end do
!
#ifdef DEBUGX
      print *, 'grid shape', grid_info%grid_shape
      print *, 'srcloc (1:3), indices (j), len_item', len_item
         do i = 1, n_send
         print 8900, search%ibuf ((i-1)*len_item+1:i*len_item)
         end do
#endif
#endif
!
!===> Allocations locations array
!
      Allocate (nfound(n_send), locations (ndim_3d, n_send), STAT = ierror)
!     TRACE_ALLOCATE ("nfound", nfound,    n_send)
!     TRACE_ALLOCATE ("locations", locations, n_send*ndim_3d)

      if ( ierror > 0 ) then
         ierrp (1) = ierror
         ierrp (2) = (ndim_3d + 1) * n_send

         ierror = PRISM_Error_Alloc
         call psmile_error ( ierror, 'locations, nfound', &
                 ierrp, 2, __FILE__, __LINE__ )
         return
      endif
!
      nfound = 0
!
!----------------------------------------------------------------------
!    Get nearest neighbour
!----------------------------------------------------------------------
!
!===> Pointer to (lon, lat, z, distance) in buffer
!
      ip(1)   = 1
      ip(2)   = ip(1) + n_send
      ip(3)   = ip(2) + n_send
      ip_dist = ip(3) + n_send
!
      datatype  = grid_info%corner_pointer%corner_datatype
!
      if (datatype == MPI_REAL) then

         rtol = tol

         call psmile_search_donor_nnx_real (comp_info,  &
                 search, var_id,                        &
                 search%rbuf(ip(1):ip(1)+n_send-1),     &
                 search%rbuf(ip(2):ip(2)+n_send-1),     &
                 search%rbuf(ip(3):ip(3)+n_send-1),     &
                 search%rbuf(ip_dist:ip_dist+n_send-1), &
                 nfound, locations, n_send, nb_extra, rtol, ierror)

      else if (datatype == MPI_DOUBLE_PRECISION) then

         call psmile_search_donor_nnx_dble (comp_info,  &
                 search, var_id,                        &
                 search%dbuf(ip(1):ip(1)+n_send-1),     &
                 search%dbuf(ip(2):ip(2)+n_send-1),     &
                 search%dbuf(ip(3):ip(3)+n_send-1),     &
                 search%dbuf(ip_dist:ip_dist+n_send-1), &
                 nfound, locations, n_send, nb_extra, tol, ierror)

#if defined ( PRISM_QUAD_TYPE )
      else if (datatype == MPI_REAL16) the
#endif
      endif

      if (ierror > 0) return
!
!----------------------------------------------------------------------
!    Get number of found locations
!----------------------------------------------------------------------
!
      nlocs = SUM (nfound)
!
#ifdef DEBUGX
      print *, 'psmile_search_donor_extra_nn: nlocs, n_send', nlocs, n_send
      do i = 1, n_send
      if (nfound(i) < 0 .or. nfound (i) > 1) then
         print *, 'i, nfound', i, nfound(i)
      endif
      end do
#endif
!
      if (nlocs > 0) then
         Allocate (hash (nlocs), stat = ierror)
         if (ierror /= 0) then
            ierrp (1) = nlocs

            ierror = PRISM_Error_Alloc

            call psmile_error ( ierror, 'hash', ierrp, 1, &
                    __FILE__, __LINE__ )
            return
         endif
!
         if (nlocs < n_send) then
            Allocate (locs (ndim_3d, nlocs), stat = ierror)
            if (ierror /= 0) then
               ierrp (1) = ndim_3d * nlocs

               ierror = PRISM_Error_Alloc

               call psmile_error ( ierror, 'locs', ierrp, 1, &
                       __FILE__, __LINE__ )
               return
            endif
!
            n = 0
!cdir vector
               do i = 1, n_send
               if (nfound (i) > 0) then
                  n = n + 1
                  locs (1, n) = locations (1, i)
                  locs (2, n) = locations (2, i)
                  locs (3, n) = locations (3, i)
               endif
               end do

#ifdef PRISM_ASSERTION
            if (n /= nlocs) then
               print *, 'nlocs, n', nlocs, n, n_send
               call psmile_assert ( __FILE__, __LINE__, &
                       'nlocs != n')
            endif
#endif

            Deallocate (locations)
         else

            locs => locations

         endif
!
!===> Create compact list of points to be sent and 
!     return hash value "hash" (index in fortran order) for each location
!
         call psmile_hash_extra (search, locs, hash, nlocs,  &
                 mask_array, mask_shape, src_mask_available, &
                 grid_info%grid_shape, ierror)
         if (ierror > 0) return
!
         Deallocate (locs, hash)
!
      else
!
!===> ... No point found. Set values in "search"
!
         search%n_liste = 0
         search%n_found = 0

         NULLIFY (search%neigh_3d)
         NULLIFY (search%index_found)

         Deallocate (locations)

      endif
!
!----------------------------------------------------------------------
!    Return info to the destination process
!----------------------------------------------------------------------
!
      if (datatype == MPI_REAL) then
         call psmile_return_extra_off_real (comp_info, search, var_id,      &
                     nfound, search%rbuf(ip_dist:ip_dist+n_send-1), n_send, &
                     nb_extra, ierror)

      else if (datatype == MPI_DOUBLE_PRECISION) then
         call psmile_return_extra_off_dble (comp_info, search, var_id,      &
                     nfound, search%dbuf(ip_dist:ip_dist+n_send-1), n_send, &
                     nb_extra, ierror)

#if defined ( PRISM_QUAD_TYPE )
      else if (datatype == MPI_REAL16) the
         call psmile_return_extra_off_quad (comp_info, search, var_id,      &
                     nfound, search%qbuf(ip_dist:ip_dist+n_send-1), n_send, &
                     nb_extra, ierror)
#endif
      endif
!
      Deallocate (nfound)
!
!===> All done
!
#ifdef VERBOSE
      print 9980, trim(ch_id), grid_id, search%sender, ierror

      call psmile_flushstd
#endif /* VERBOSE */
!
      return
!
!  Formats:
!
#ifdef VERBOSE
9990 format (1x, a, ': psmile_search_donor_extra_nn: comp_id =', i3, &
                    '; sender =', i4)
9980 format (1x, a, ': psmile_search_donor_extra_nn: grid id =', i3, &
                    '; eof sender =', i3, ', ierror =', i4)

9970 format (1x, a, ': psmile_search_donor_extra_nn:', &
             1x, 'offset local  ', 3i7, &
            /1x, 'extent        ', 3i7, &
            /1x, 'offset remote ', 3i7)
#endif /* VERBOSE */
8900 format (1x, 3i6, 5(';', i6) )

      end subroutine PSMILe_Search_donor_extra_nn