psmile_search_donor_1d_dble.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_Search_donor_1d_dble
!
! !INTERFACE:

      subroutine psmile_search_donor_1d_dble (grid_id, idim, &
                        found, locations, coords, len, tol, ierror)
!
! !USES:
!
      use PRISM_constants
!
      use PSMILe, dummy_interface => PSMILe_Search_donor_1d_dble

      implicit none
!
! !INPUT PARAMETERS:
!
      Integer, Intent (In)            :: grid_id

!     Info on the component in which the donor
!     should be searched.

      Integer, Intent (In)            :: idim

!     Dimension in which should be searched

      Integer, Intent (In)            :: len

!     Number of coords to be searched

      Double Precision, Intent (In)   :: coords (len)

!     Coordinates to be searched

      Double Precision, Intent (In)   :: tol
!
!     Absolute tolerance for search of "identical" points
!     TOL >= 0.0
!
! !INPUT/OUTPUT PARAMETERS:
!
      Integer, Intent (InOut)         :: found (len)

!     Finest level number on which a grid cell was found for point I.
!     Level number < -1: Point was not found and
!                        and last level number was (-found(i,j,k))
!     Level number = (-nlev+1): Never found (input value)

      Integer, Intent (InOut)         :: locations (len)

!     Indices of the grid cell in which the point was found.
!     Assumed input value locations (:) = 0
!
! !OUTPUT PARAMETERS:
!
      integer, Intent (Out)               :: ierror

!     Returns the error code of PSMILe_Search_donor_1d_dble;
!             ierror = 0 : No error
!             ierror > 0 : Severe error
!
! !LOCAL VARIABLES
!
!     ... for locations searched
!
      Integer                      :: ibeg, iend
!     Integer                      :: shape   (2, ndim_3d)
!     Integer                      :: range   (2, ndim_3d)
!     Integer                      :: control (2, ndim_3d)
!
!     ... for levels
!
      Integer                      :: lev, levc, nlev
      Integer                      :: ijkinc (1), ijkcoa (1)
      Type(Grid), Pointer          :: grid_info
!
!     ... for error parameters
!
!     Integer, parameter           :: nerrp = 1
!     Integer                      :: ierrp (nerrp)
!
! !DESCRIPTION:
!
! Subroutine "PSMILe_Search_donor_1d_dble" searches the donor
! for the subgrid sent by the sending process.
!
!
! !REVISION HISTORY:
!
!   Date      Programmer   Description
! ----------  ----------   -----------
! 03.07.21    H. Ritzdorf  created
!
!EOP
!----------------------------------------------------------------------
!
! $Id: psmile_search_donor_1d_dble.F90 2820 2010-12-10 09:20:01Z hanke $
! $Author: hanke $
!
   Character(len=len_cvs_string), save :: mycvs = 
       '$Id: psmile_search_donor_1d_dble.F90 2820 2010-12-10 09:20:01Z hanke $'
!
!----------------------------------------------------------------------
!
!  Initialization
!
#ifdef VERBOSE
      print 9990, trim(ch_id), Grids(grid_id)%comp_id

      call psmile_flushstd
#endif /* VERBOSE */
!
      ierror = 0
      grid_info => Grids(grid_id)
!
!-----------------------------------------------------------------------
!     Define shapes and ranges of coordinates to be searched
!-----------------------------------------------------------------------
!
#ifdef NEW
das wird gebraucht, wenn das source und das destination gitter auf dem
gleichen prozess liegen und die search daten nicht gesendet werden,
weil man dann nicht einfach ueber die coords rueberloopen kann.
Trotzdem sollte man hier den Spezialfall haben,
dass die search%daten zusammenliegen !
Also zusaetzliche neue Routinen, die das machen und den NEW code 
verwenden.
!
      if (search%grid_type == PRISM_Reglonlatvrt .or. &
         (search%grid_type == PRISM_Irrlonlat_Regvrt .and idim == ndim_3d)) then
!        ... Dimension in 1st, 2nd and 3rd direction is only 1-dimensional

         shape = 1
         range = 1

         shape (:, idim) = search%shape(:, idim, ipart)
         range (:, idim) = search%range(:, idim, ipart)

      else if (search%grid_type == PRISM_Gaussreduced_Regvrt) then
!        ... Dimension of aux grid in 1st, 2nd and 3rd direction is only 1-dimensional

         shape = 1
         range = 1

         shape (:, idim) = search%shape(:, idim, ipart)
         range (:, idim) = search%range(:, idim, ipart)

      else if (search%grid_type == PRISM_Irrlonlat_Regvrt) then
!        ... Dimension in 1st and 2nd direction is 2-dimensional
!        ... Dimension in 3rd         direction is 1-dimensional

         shape (:, 1:ndim_2d) = search%shape(:, 1:ndim_2d, ipart)
         range (:, 1:ndim_2d) = search%range(:, 1:ndim_2d, ipart)

         shape (:, ndim_3d) = 1
         range (:, ndim_3d) = 1

      else
!        ... Dimension in all direction is 3-dimensional

         shape (:, :) = search%shape(:, :, ipart)
         range (:, :) = search%range(:, :, ipart)

      endif
!
      control = range
#endif
!
!-----------------------------------------------------------------------
!     Coarsest level nlev
!-----------------------------------------------------------------------
!
!   ??? Hier fragt sich, ob nicht das suchen in einer einfachen Liste Schneller
!   ??? ist. Das muss man mal alles genau austesten.
!
      nlev = grid_info%nlev
      lev = nlev
!
      ibeg = 1
      iend = len
!
#ifdef PRISM_ASSERTION
      if ( nlev <= 0 ) then
         call psmile_assert (__FILE__, __LINE__, "nlev <= 0")
      endif
#endif
!
      call psmile_mg_coarse_1d_dble (lev, &
                     grid_info%mg_infos(lev)%double_arrays%chmin(idim)%vector, &
                     grid_info%mg_infos(lev)%double_arrays%chmax(idim)%vector, &
                     found, locations, coords, &
                     ibeg, iend)
!
      if (ibeg > iend) then
#ifdef VERBOSE
         print 9980, trim(ch_id), grid_info%comp_id, ierror

         call psmile_flushstd
#endif /* VERBOSE */
         return
      endif
!
!===> Multiple grids
!
!     ijkinc(1) = max (1, (iend-ibeg)/2)
      ijkinc(1) = 1
!
         do lev = nlev-1, 1, -1
!
         levc = lev + 1
!
         ijkcoa (1) = 2
!
         if (grid_info%mg_infos(lev)%levdim(idim) == &
             grid_info%mg_infos(levc)%levdim(idim)) then
!           skippen ?!?!
            ijkcoa (1) = 1
         endif
!
         call psmile_mg_next_level_1d_dble ( grid_id, idim, lev, nlev,    &
                grid_info%mg_infos(lev)%double_arrays%chmin(idim)%vector, &
                grid_info%mg_infos(lev)%double_arrays%chmax(idim)%vector, &
                grid_info%mg_infos(lev)%double_arrays%midp(idim)%vector,  &
                grid_info%mg_infos(lev)%levdim(idim),                   &
                found,  locations, coords, ibeg, iend,                  &
                        ijkinc(1), ijkcoa(1), ierror)
         if (ierror > 0) return
!
!        ijkinc (1) = max (1, ijkinc(1)/ijkcoa(1))
         enddo ! lev
!
!   Compute locations
!
      locations (ibeg:iend) = locations (ibeg:iend) + grid_info%ijk0 (idim)
!
!===> All done
!
#ifdef VERBOSE
      print 9980, trim(ch_id), grid_info%comp_id, ierror

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

      end subroutine PSMILe_Search_donor_1d_dble