psmile_search_donor_nnx_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_Search_donor_nnx_dble
!
! !INTERFACE:

      subroutine psmile_search_donor_nnx_dble (comp_info, search, var_id, &
                        coords1, coords2, coords3, distance,              &
                        nfound, locations, n_send, nb_extra,              &
                        tol, ierror)
!
! !USES:
!
      use PRISM
!
      use PSMILe, dummy_interface => PSMILe_Search_donor_nnx_dble

      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

      Integer,                     Intent (In)    :: n_send

!     Number of points to be searched

      Double Precision, Intent (In)   :: coords1 (n_send)
      Double Precision, Intent (In)   :: coords2 (n_send)
      Double Precision, Intent (In)   :: coords3 (n_send)

!     Coordinates to be searched

      Integer,                     Intent (In)    :: nb_extra

!     Number of nearest neighbours per point to be searched

      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

      Double Precision, Intent (InOut)            :: distance (n_send)

!     Nearest neighbour distance already found
!
      Integer,                     Intent (InOut) :: nfound (n_send)
!
!     Number of nearest neighbours found per point
!
! !OUTPUT PARAMETERS:
!
      Integer,                     Intent (Out)   :: locations (ndim_3d, n_send)
!
!     Locations of nearest neigbour found
!
      Integer,                     Intent (Out)   :: ierror

!     Returns the error code of PSMILe_Search_donor_nnx_dble;
!             ierror = 0 : No error
!             ierror > 0 : Severe error
!
! !DEFINED PARAMETERS:
!
!  lon   = Index of Longitudes in arrays "sin_values" and "cos_values"
!  lat   = Index of Latitudes  in arrays "sin_values" and "cos_values"

      Integer, Parameter              :: lon = 1
      Integer, Parameter              :: lat = 2
!
! !LOCAL VARIABLES
!
!     ... loop variables
!
!
!     ... field pointer
!
      Type (Gridfunction), Pointer  :: field
!
!     ... Method pointer
!
      Integer                       :: method_id
      Type (Method),        Pointer :: mp
      Type (Coords_Block),  Pointer :: coords_pointer
!
!     ... Grid pointer
!
      Type (Grid), Pointer          :: grid_info
      Integer                       :: grid_id
      Type (dble_vector)            :: cosvec, sinvec
      Type (dble_vector)            :: sinvec_reg (ndim_2d)
      Type (dble_vector)            :: cosvec_reg (ndim_2d)
!
!     ... for points to be searched
!
! len_item = Length of a data item per point in search%ibuf
!
      Integer                       :: len_item, len_rtem
      Integer                       :: irreg2_shape (2, ndim_3d)
!
      Type (dble_vector)            :: cos_search, sin_search
!
!     ... 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 error parameters
!
      Integer, Parameter            :: nerrp = 1
      Integer                       :: ierrp (nerrp)
!
! !DESCRIPTION:
!
! Subroutine "PSMILe_Search_donor_nnx_dble" 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_nnx_dble.F90 3112 2011-04-07 15:03:18Z hanke $
! $Author: hanke $
!
   Character(len=len_cvs_string), save :: mycvs = 
       '$Id: psmile_search_donor_nnx_dble.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
!
      mp        => Methods(method_id)
      grid_id   = mp%grid_id
      coords_pointer => mp%coords_pointer
!
      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
!
#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 (grid_info%corner_pointer%corner_datatype /= MPI_DOUBLE_PRECISION) then
          call psmile_assert ( __FILE__, __LINE__, &
                  'Incorrect datatype for this routine')
      endif
!
      if (n_send /= search%msg_extra%num_volumes) then
          call psmile_assert ( __FILE__, __LINE__, &
                  'Inconsistent number of points')
      endif
!
#endif
!
!  len_item = Number of pieces of information in integer buffer "ibuf".
!             #1  : Index in indices/dist_dble/send_mask of sending process
!
!  len_rtem = Number of pieces of information per point in
!             floating point buffer "rbuf".
!             #1-3: Coordinates of the point to be searched.
!                   ndim_3d data items
!             #4  : Maximal distance already determined
!                   1 item
!
!     n_send   = search%msg_extra%num_volumes
      len_item = search%msg_extra%num_int_per_vol
      len_rtem = search%msg_extra%num_items_per_coord
!
!-----------------------------------------------------------------------
!     Allocate and set temporary array which is used to transform
!     the coordinates of points.
!     (*) Longitudes and Latitudes are transformed
!         from degrees into radients.
!     (*) The z-values are currently not transformed
!         ??? Whats about PRISM_Irrlonlat_sigmavrt, ...
!-----------------------------------------------------------------------
!
! Note: PSMILE_Info_coords_irreg2_dble is used to compute the values
!       and generate arrays
!       cos_search (1:n_send, lat) and sin_search (1:n_send, lat)
!
      irreg2_shape (1,1) = 1
      irreg2_shape (2,1) = n_send
      irreg2_shape (1,2) = 1
      irreg2_shape (2,2) = 1
      irreg2_shape (1,3) = 1
      irreg2_shape (2,3) = 1 ! n_send, but z_coords are not used
!
      call psmile_info_coords_irreg2_dble (       &
              coords1, coords2, coords3,          &
              irreg2_shape, irreg2_shape,         &
              sin_search, cos_search, ierror)
      if (ierror > 0) return
!
!===> Look for nearest neighbour on block boundary
!
      select case ( Grids(grid_id)%grid_type )

! -----------------------------------------------------------------------
!      Regular in all directions
! -----------------------------------------------------------------------
!
      case (PRISM_Reglonlatvrt)
!
!===> ... Allocate and compute sin and cos values for the
!         source grid
!         TODO: Reuse values from standard search process
!
         call psmile_info_coords_3d_reg_dble (              &
                 coords_pointer%coords_dble(1)%vector,      &
                 coords_pointer%coords_dble(2)%vector,      &
                 coords_pointer%coords_dble(3)%vector,      &
                 coords_pointer%coords_shape,               &
                 grid_info%grid_shape,                      &
                 sinvec_reg, cosvec_reg, ierror)
         if (ierror > 0) return

         call psmile_search_nn_3d_reg_dble (                       &
                 sin_search%vector, cos_search%vector, coords3,    &
                 distance,                                         &
                 nfound, locations, n_send,                        &
                 coords_pointer%coords_dble(1)%vector,             &
                 coords_pointer%coords_dble(2)%vector,             &
                 coords_pointer%coords_dble(3)%vector,             &
                 coords_pointer%coords_shape,                      &
                 sinvec_reg(lon)%vector, cosvec_reg(lon)%vector,   &
                 sinvec_reg(lat)%vector, cosvec_reg(lat)%vector,   &
                 grid_info%grid_shape,                             &
                 mask_array, mask_shape, src_mask_available,       &
                 tol, ierror)
!
         Deallocate (sinvec_reg(1)%vector, sinvec_reg(2)%vector)
         Deallocate (cosvec_reg(1)%vector, cosvec_reg(2)%vector)
!
! -----------------------------------------------------------------------
!      Irregular in lonlat   direction
!        Regular in vertical direction
! -----------------------------------------------------------------------
!
      case (PRISM_Irrlonlat_regvrt)
!
!===> ... Allocate and compute sin and cos values for the
!         source grid
!         TODO: Reuse values from standard search process
!
         call psmile_info_coords_irreg2_dble (                     &
                 coords_pointer%coords_dble(1)%vector,             &
                 coords_pointer%coords_dble(2)%vector,             &
                 coords_pointer%coords_dble(3)%vector,             &
                 coords_pointer%coords_shape,                      &
                 grid_info%grid_shape,                             &
                 sinvec, cosvec, ierror)
         if (ierror > 0) return

         call psmile_search_nn_irreg2_dble (                       &
                 sin_search%vector, cos_search%vector, coords3,    &
                 distance,                                         &
                 nfound, locations, n_send,                        &
                 coords_pointer%coords_dble(1)%vector,             &
                 coords_pointer%coords_dble(2)%vector,             &
                 coords_pointer%coords_dble(3)%vector,             &
                 coords_pointer%coords_shape,                      &
                 sinvec%vector, cosvec%vector,                     &
                 grid_info%grid_shape,                             &
                 mask_array, mask_shape, src_mask_available,       &
                 tol, ierror)
!
         Deallocate (sinvec%vector, cosvec%vector)
!
! -----------------------------------------------------------------------
!      Irregular in lonlat   and vertical direction
! -----------------------------------------------------------------------
!
      case (PRISM_Irrlonlatvrt)
!
!===> ... Allocate and compute sin and cos values for the
!         source grid
!         TODO: Reuse values from standard search process
!
         call psmile_info_trf_coords_3d_dble (                     &
                 coords_pointer%coords_dble(1)%vector,             &
                 coords_pointer%coords_dble(2)%vector,             &
                 coords_pointer%coords_dble(3)%vector,             &
                 coords_pointer%coords_shape,                      &
                 grid_info%grid_shape,                             &
                 sinvec, cosvec, ierror)
         if (ierror > 0) return

         call psmile_search_nn_3d_dble (                           &
                 sin_search%vector, cos_search%vector, coords3,    &
                 distance,                                         &
                 nfound, locations, n_send,                        &
                 coords_pointer%coords_dble(1)%vector,             &
                 coords_pointer%coords_dble(2)%vector,             &
                 coords_pointer%coords_dble(3)%vector,             &
                 coords_pointer%coords_shape,                      &
                 sinvec%vector, cosvec%vector,                     &
                 grid_info%grid_shape,                             &
                 mask_array, mask_shape, src_mask_available,       &
                 tol, ierror)
!
         Deallocate (sinvec%vector, cosvec%vector)
!
! -----------------------------------------------------------------------
!      Gauss reduced in lonlat direction
!        Regular in vertical direction
! -----------------------------------------------------------------------
!
      case (PRISM_Gaussreduced_regvrt)
!
!===> ... Allocate and compute sin and cos values for the
!         source grid
!         TODO: Reuse values from standard search process
!               Use search which is better adjusted to
!               the Gauss-grid.
!
         call psmile_info_coords_irreg2_dble (                     &
                 coords_pointer%coords_dble(1)%vector,             &
                 coords_pointer%coords_dble(2)%vector,             &
                 coords_pointer%coords_dble(3)%vector,             &
                 coords_pointer%coords_shape,                      &
                 grid_info%grid_shape,                             &
                 sinvec, cosvec, ierror)
         if (ierror > 0) return

         ! sinvec%vector(:,lon), sinvec%vector(:lat)
         ! cosvec%vector(:,lon), cosvec%vector(:lat)

         call psmile_search_nn_irreg2_dble (                       &
                 sin_search%vector, cos_search%vector, coords3,    &
                 distance,                                         &
                 nfound, locations, n_send,                        &
                 coords_pointer%coords_dble(1)%vector,             &
                 coords_pointer%coords_dble(2)%vector,             &
                 coords_pointer%coords_dble(3)%vector,             &
                 coords_pointer%coords_shape,                      &
                 sinvec%vector, cosvec%vector,                     &
                 grid_info%grid_shape,                             &
                 mask_array, mask_shape, src_mask_available,       &
                 tol, ierror)

         Deallocate (sinvec%vector, cosvec%vector)
!
! -----------------------------------------------------------------------
!      Error: unsupported grid type
! -----------------------------------------------------------------------
!
      case DEFAULT
!
          ierrp (1) = Grids(grid_id)%grid_type
          ierror = PRISM_Error_Internal

          call psmile_error ( ierror, 'unsupported grid generation type', &
                              ierrp, 1, __FILE__, __LINE__ )
      end select 
!
!===> All done
!
      Deallocate (cos_search%vector, sin_search%vector)
!
#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_nnx_dble: comp_id =', i3, &
                    '; sender =', i4)
9980 format (1x, a, ': psmile_search_donor_nnx_dble: grid id =', i3, &
                    '; eof sender =', i3, ', ierror =', i4)
#endif /* VERBOSE */

      end subroutine PSMILe_Search_donor_nnx_dble