psmile_mg_coarse_2d_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_mg_coarse_2d_dble
!
! !INTERFACE:

      subroutine psmile_mg_coarse_2d_dble (lev, chmin, chmax, &
                                           found, locations, coords1, coords2, &
                                           ibeg, iend)
!
! !USES:
!
      use PRISM_constants
!
      use PSMILe, dummy_interface => PSMILe_mg_coarse_2d_dble

      implicit none
!
! !INPUT/OUTPUT PARAMETERS:
!
      Integer, Intent (InOut)         :: ibeg

!     Input  value: First index in "coords" to be searched
!     Output value: First index in "coords" for which a cell was found

      Integer, Intent (InOut)         :: iend

!     Input  value: Last  index in "coords" to be searched
!                   Dimension of "found" and "location".
!     Output value: Last  index in "coords" for which a cell was found

      Integer, Intent (InOut)         :: found (iend)

!     Finest level number on which a grid cell was found for point I.
!     Level number = -(nlev+1): Never found (input value)

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

!     Indices of the grid cell in which the point was found.
!     Assumed input value locations (:, :) = 0
!
!
! !INPUT PARAMETERS:
!
      Integer, Intent (In)            :: lev
!
!     Level number of the coarsest grid
!
      Type (dble_vector), Intent (In) :: chmin (ndim_2d)
!
!     Minimum of grid coordinates per grid cell
!
      Type (dble_vector), Intent (In) :: chmax (ndim_2d)

!     Maximum of grid coordinates per grid cell

      Double Precision, Intent (In)   :: coords1 (iend)
      Double Precision, Intent (In)   :: coords2 (iend)

!     Coordinates to be searched
!
! !LOCAL VARIABLES
!
!     ... for locations searched
!
      Integer                      :: i, i2
#ifdef VERBOSE
      Integer                      :: n
#endif
!
!
! !DESCRIPTION:
!
! Subroutine "PSMILe_mg_coarse_2d_dble" searches the donor cells
! on the coarsest MG grid (only 1 cell) for the subgrid sent by the
! sending process.
!
!
! !REVISION HISTORY:
!
!   Date      Programmer   Description
! ----------  ----------   -----------
! 03.07.21    H. Ritzdorf  created
!
!EOP
!----------------------------------------------------------------------
!
!  $Id: psmile_mg_coarse_2d_dble.F90 2325 2010-04-21 15:00:07Z valcke $
!  $Author: valcke $
!
   Character(len=len_cvs_string), save :: mycvs = 
       '$Id: psmile_mg_coarse_2d_dble.F90 2325 2010-04-21 15:00:07Z valcke $'
!
!----------------------------------------------------------------------
!
!  Initialization
!
#ifdef VERBOSE
      print 9990, trim(ch_id), lev, ibeg, iend

      call psmile_flushstd
#endif /* VERBOSE */
!
#ifdef PRISM_ASSERTION
      if (chmin(1)%vector(1) > chmax(1)%vector (1) .or. &
          chmin(2)%vector(1) > chmax(2)%vector (1)) then
         print *, 'chmin', chmin(1)%vector(1), chmin(2)%vector(1)
         print *, 'chmax', chmax(1)%vector(1), chmax(2)%vector(1)
         call psmile_assert ( __FILE__, __LINE__, &
                              'incorrect coarsest box')
      endif
#endif
!
!===> Is point I in the coarsest box ?
!
!cdir vector
         do i = ibeg, iend
         if (chmin(1)%vector(1) <= coords1(i) .and. &
             chmax(1)%vector(1) >= coords1(i) .and. &
             chmin(2)%vector(1) <= coords2(i) .and. &
             chmax(2)%vector(1) >= coords2(i)) then
            found (i) = lev
         endif
         end do
!
!===> Update ibeg, iend
!
!cdir vector
         do i = ibeg, iend
         if (found (i) == lev) exit
         enddo
!
      if (i > iend) then
         iend = ibeg - 1
!
      else
      ibeg = i
!
      if (found(iend) /= lev) then
!cdir vector
            do i = ibeg, iend
            if (found(i) == lev) then
               i2 = i
            endif
            enddo
!
         iend = i2

      endif
      endif
!
!===> All done
!
#ifdef VERBOSE
!
!===> Get number of points found
!
#ifdef DONT_USE_COUNT
      n = 0
!cdir vector
         do i = ibeg, iend
         if (found(i) == lev) n = n + 1
         end do
#else
      n = count (found(ibeg:iend) == lev)

#ifdef DEBUG
      print *, 'chmin', chmin(1)%vector(1), chmin(2)%vector(1)
      print *, 'chmax', chmax(1)%vector(1), chmax(2)%vector(1)

         do i = ibeg, iend
         if (found(i) /= lev) then
            print *, i
            print *, coords1(i)
            print *, coords2(i)
            exit
         endif 
         end do
#endif
#endif
!
      print 9980, trim(ch_id), lev, n

      call psmile_flushstd
#endif /* VERBOSE */
!
!  Formats:
!
9990 format (1x, a, ': PSMILe_mg_coarse_2d_dble: level', i3, &
                    ', ibeg, iend', 2i6)
9980 format (1x, a, ': PSMILe_mg_coarse_2d_dble: eof, level', i3, &
                    ', found =', i9)

      end subroutine PSMILe_mg_coarse_2d_dble