psmile_mg_control_cell_1d_real.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_Control_cell_1d_real
!
! !INTERFACE:

      subroutine psmile_mg_control_cell_1d_real (     &
                           chmin, chmax, midp, levdim,     &
                           ijk, xyz, nold, all, wide, found, newijk)
!
! !USES:
!
      use PRISM_constants
!
      use PSMILe, dummy_interface => PSMILe_mg_control_cell_1d_real

      implicit none
!
! !INPUT PARAMETERS:
!
      Integer, Intent (In)            :: levdim
!
!     Dimension of chmin, chmax and midp
!
      Real, Intent (In)               :: chmin (0:levdim)
!
!     Minimum of grid coordinates per grid cell
!
      Real, Intent (In)               :: chmax (0:levdim)
!
!     Maximum of grid coordinates per grid cell
!
      Real, Intent (In)               :: midp (0:levdim)
!
!     Mid point of the cell
!
      Integer, Intent (In)            :: ijk
!
!     Index of the cell for which the cell parts should be
!     controlled.
!
      Real, Intent (In)               :: xyz
!
!     Corrdinates of the point for which is searched
!
      Integer, Intent (In)            :: nold
!
!     Old number of the cell part were the point XYZ was found
!
      logical, Intent (In)            :: all
!
!     Were all cells i with DIST(i) < DIST(NOLD) already controlled ?
!
      logical, Intent (In)            :: wide
!
!     Wide control ?
!
! !OUTPUT PARAMETERS:
!
      integer, Intent (Out)           :: found
!
!     Was the point xyz found ?
!     found = 0: Not found
!     found > 0: Part of the cell where point XYZ was found.
!
      integer, Intent (Out)           :: newijk
!
!     Indices on level LEV if found > 0 is returned.
!
! DEFINED PARAMETERS:

      Real, Parameter                :: remax = 1.0e20
!
      Integer, Parameter             :: ndtry = 4
!
! !LOCAL VARIABLES
!
      Real                           :: dist (ndtry)
      Integer                        :: i, ibeg, iend, n, ntry
      Integer                        :: nmin (1)
!
! !DESCRIPTION:
!
! Subroutine "PSMILe_mg_control_cell_1d_real" searches the point XYZ
! in the n the neihbourhood of a cell. The cell which is controlled
! starts in IJK. All cells with (i) in
!      (ijk-1:ijk+2) if wide is true.
!      (ijk-1:ijk+1) otherwise
! are controlled.
!
! ?!? Vielleicht koennte man alle Punkte zurueckgeben, die man
!     gefunden hat.
!
!
! !REVISION HISTORY:
!
!   Date      Programmer   Description
! ----------  ----------   -----------
! 03.07.21    H. Ritzdorf  created
!
!EOP
!----------------------------------------------------------------------
!
!  $Id: psmile_mg_control_cell_1d_real.F90 2325 2010-04-21 15:00:07Z valcke $
!  $Author: valcke $
!
   Character(len=len_cvs_string), save :: mycvs = 
       '$Id: psmile_mg_control_cell_1d_real.F90 2325 2010-04-21 15:00:07Z valcke $'
!
!----------------------------------------------------------------------
!
!  Initialization
!
#ifdef VERBOSE
      print 9990, trim(ch_id)

      call psmile_flushstd
#endif /* VERBOSE */
!
#ifdef PRISM_ASSERTION
      if (.not. all) then
         if (nold < 1 .or. nold > ndtry) then
            call psmile_assert (__FILE__, __LINE__, &
                                'wrong nold')
         endif
      endif
!
      if (min(ijk, levdim-ijk) < 0) then
         call psmile_assert (__FILE__, __LINE__, 'wrong ijk')
      endif
#endif
!
#ifdef HUHU
      if (all) then
         if (nold .gt. 1) then
            print *, 'cell', nold, ijk
         endif
      endif
#endif /* HUHU */
!
!===> Compute indices to be controlled
!
      if (wide) then
         ibeg = max (ijk - 1, 0)
         iend = min (ijk + 2, levdim)
      else
         ibeg = max (ijk - 1, 0)
         iend = min (ijk + 1, levdim)
      endif
!
!===> Control location of point XYZ in the boxes
!
        do i = ibeg, iend
        if (xyz >= chmin (i) .and.  xyz <= chmax(i)) then
           dist (i-ibeg+1) = abs (xyz - midp (i))
        else
           dist (i-ibeg+1) = remax
        endif
        end do
!
      dist (ijk-ibeg+1) = remax
      ntry = iend - ibeg + 1
!
!===> Set old values to remax
!
      if (nold .gt. 0) then
#ifdef CLIC_ASSERTION
         if (dist(nold) .eq. remax) then
            write (*, 9980) xyz
9980  format (1x, 1p, 3e18.9)
!
            call psmile_assert (__FILE__, __LINE__,
     &                          'incorrect nold')
         endif
#endif /* CLIC_ASSERT */
!
!===> Exclude all old distances
!
         if (all) then
               do n = 1, nold-1
               if (dist(n) <= dist(nold)) dist (n) = remax
               end do
!
               do n = nold+1, ntry
               if (dist(n) < dist(nold)) dist (n) = remax
               end do
!
         endif
!
         dist (nold) = remax
      endif
!
!===> Look for the minimum distance
!
      nmin = MINLOC (dist(1:ntry))
#ifdef MINLOCFIX
      if (nmin(1).eq.0) nmin=1
#endif /* MINLOCFIX */
!
!===> Was a valid cell found ?
!
      if (dist(nmin(1)) == remax) then
         found = 0
      else
         found = nmin (1)
!
         newijk = ibeg + nmin (1) - 1
      endif
!
!===> All done
!
#ifdef VERBOSE
      print 9980, trim(ch_id)

      call psmile_flushstd
#endif /* VERBOSE */
!
!  Formats:
!
9990 format (1x, a, ': psmile_mg_control_cell_1d_real:')
9980 format (1x, a, ': psmile_mg_control_cell_1d_real: eof')

      end subroutine PSMILe_mg_control_cell_1d_real