psmile_mg_next_level_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_next_level_1d_real
!
! !INTERFACE:

      subroutine psmile_mg_next_level_1d_real ( &
                           grid_id, idim, lev, nlev, &
                           chmin, chmax, midp, levdim,    &
                           found, loc, coords, ibeg, iend, &
                           ijkinc, ijkcoa, ierror)
!
! !USES:
!
      use PRISM_constants
!
      use PSMILe, dummy_interface => psmile_mg_next_level_1d_real

      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)            :: lev

!     Level number of the next grid

      Integer, Intent (In)            :: nlev

!     Total number of levels

      Integer, Intent (In)            :: levdim

!     Dimension of chmin, chmax and midp

      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

      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 (InOut)         :: found (iend)

!     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)         :: loc (iend)

!     Indices of the grid cell in which the point was found.

      Real, Intent (In)               :: coords (iend)

!     Coordinates to be searched

      Integer, Intent (In)            :: ijkinc

!     Increment

      Integer, Intent (In)            :: ijkcoa
!
!     Coarsening
!
! !OUTPUT PARAMETERS:
!
      integer, Intent (Out)           :: ierror

!     Returns the error code of PSMILe_MG_coars_level;
!             ierror = 0 : No error
!             ierror > 0 : Severe error
!
! !DEFINED PARAMETERS:
!
      Integer, parameter              :: ntry1 = 3
      Integer, parameter              :: ntry3 = 3
      Integer, parameter              :: ndtry = 5
      Real,    parameter              :: remax = 1.0e20
!
! !LOCAL VARIABLES

!     ... for levels

      Integer                         :: levc

!     ... for locations searched

      Integer                         :: i, ibegl, n, nprev
      Integer                         :: ifound, nmin(1)
      Integer                         :: ijkf, ijkold, newijk
      Integer                         :: ijkdst (ndtry)
      Real                            :: dist (ndtry)
!
#ifdef DEBUG
!     ... for locations searched
!
      Integer                      :: nfnd (0:4)
#endif /* DEBUG */
!
! !DESCRIPTION:
!
! Subroutine "psmile_mg_next_level_1d_real" searches the donor cells
! on the next MG grid for the subgrid coords by the sending process.
!
!
! !REVISION HISTORY:
!
!   Date      Programmer   Description
! ----------  ----------   -----------
! 03.07.21    H. Ritzdorf  created
!
!EOP
!----------------------------------------------------------------------
!
!  $Id: psmile_mg_next_level_1d_real.F90 2912 2011-01-25 09:21:26Z coquart $
!  $Author: coquart $
!
   Character(len=len_cvs_string), save :: mycvs = 
       '$Id: psmile_mg_next_level_1d_real.F90 2912 2011-01-25 09:21:26Z coquart $'
!
!----------------------------------------------------------------------
!
!  Initialization
!
#ifdef VERBOSE
      print 9990, trim(ch_id), lev, ibeg, iend

      call psmile_flushstd
#endif /* VERBOSE */
!
#ifdef PRISM_ASSERTION
#endif
!
      ierror = 0
      levc = lev + 1
!
#ifdef DEBUG
      nfnd (0) = 0
      nfnd (1) = 0
      nfnd (2) = 0
      nfnd (3) = 0
      nfnd (4) = 0

!     print *, 'chmin', chmin(0), chmin (levdim)
!     print *, 'chmax', chmax(0), chmax (levdim)
!     print *, 'midp ', midp (0), midp  (levdim)
#endif /* DEBUG */

#ifdef DEBUGX
      print *, 'begin ---'
      do i = ibeg, iend
         print *, 'i, coord, found', i, coords (i), loc(i), found (i)
      end do
#endif
!
!-----------------------------------------------------------------------
!     Look in the fine parts of the coarse grid cell loc(i)
!-----------------------------------------------------------------------
!
      nprev = 0
      ibegl = ibeg
!
!===> ... Look for the next cell to be controlled
!
      do while (ibegl <= iend)
!cdir vector
         do i = ibegl, iend, ijkinc
            if (found (i) == levc) go to 11
         end do
!
         if (i .lt. iend+ijkinc) then
            i = iend
            if (found (i) == levc) go to 11
         endif
!
         exit
!
!===> ... Look in the fine parts of cell loc(i)
!
11       continue
!
         ijkf = min (loc(i) * ijkcoa, levdim)
!
         ijkdst (1) = max(ijkf - 1, 0)
         ijkdst (2) = ijkf
         ijkdst (3) = min(ijkf + 1, levdim)
!
         do n = 1, ntry1
            if (coords(i) >= chmin(ijkdst(n)) .and. &
                coords(i) <= chmax(ijkdst(n))) then
               dist (n) = abs (coords(i) - midp (ijkdst(n)))
            else
               dist (n) = remax
            endif
         end do
!
!===> ... Look for the minimum distance
!
         nmin = MINLOC (dist(1:ntry1))
#ifdef MINLOCFIX
         if (nmin(1).eq.0) nmin=1
#endif /* MINLOCFIX */
!
         if (dist(nmin(1)) .ne. remax) then
            found (i)  = lev
            loc (i) = ijkdst (nmin(1))
!
#ifdef DEBUG
            nfnd (1) = nfnd (1) + 1
#endif /* DEBUG */
            go to 95
!
         else
!
            if (levc == nlev) then
               found (i) = - found(i)
#ifdef DEBUG
               nfnd (0) = nfnd (0) + 1
#endif /* DEBUG */
               go to 95
            endif
         endif
!
!-----------------------------------------------------------------------
!          Look in the neigbourhood of the coarse grid cell
!          loc(i)
!-----------------------------------------------------------------------
!
         ijkdst (ntry1+1) = max(ijkf-2, 0)
         ijkdst (ntry1+2) = min(ijkf+2, levdim)
!
         do n = ntry1+1, ndtry
            if (coords(i) >= chmin(ijkdst(n)) .and. &
                coords(i) <= chmax(ijkdst(n))) then
               dist (n) = abs (coords(i) - midp (ijkdst(n)))
            else
               dist (n) = remax
            endif
         end do
!
!===> ... Look for the minimum distance
!
         nmin = MINLOC (dist(ntry1+1:ndtry)) + ntry1
#ifdef MINLOCFIX
         if (nmin(1).eq.ntry1) nmin=ntry1 + 1
#endif /* MINLOCFIX */
!
         if (dist(nmin(1)) .ne. remax) then
            found (i)  = lev
            loc (i) = ijkdst (nmin(1))
!
#ifdef DEBUG
            nfnd (2) = nfnd (2) + 1
#endif /* DEBUG */
!
         else
!
            nprev = nprev + 1
         endif
!
!===> ... Start index of the next search
!
95       if (i == iend) exit
         ibegl = min (iend, i+ijkinc)

      end do ! while (ibegl <= iend)
!
!===> ... Have points to be controlled o a coarser level ?
!
      if (nprev == 0) go to 20
!
!-----------------------------------------------------------------------
!          Some points were not found.
!          Try to interpolate the fine point a from neighbouring points
!-----------------------------------------------------------------------
!
      ibegl = ibeg+ijkinc
!
      do while (ibegl <= iend)
!cdir vector
         do i = ibegl, iend-ijkinc, ijkinc
            if (found (i)        == levc .and. &
                found (i-ijkinc) == lev  .and. &
               found (i+ijkinc) == lev) go to 211
         end do
!
         if (i .lt. iend) then
            i = iend - ijkinc
            if (found (i)        == levc .and. &
                found (i-ijkinc) == lev  .and. &
               found (i+ijkinc) == lev) go to 211
         endif
!
         exit
!
!===> ... Interpolate cell IJKF and
!         look in the neighbourhood of cell IJKF
!
211      continue
         ijkf   = min ((loc (i-ijkinc) + loc (i+ijkinc)) / 2, levdim)
!
         ijkold = min (loc(i) * ijkcoa, levdim)
!
         if (ijkold == ijkf) go to 260
!
         ijkdst (1) = max(ijkf - 1, 0)
         ijkdst (2) = ijkf
         ijkdst (3) = min(ijkf + 1, levdim)
!
!===> ... Compute distances to the cell midpoints
!
!cdir vector
         do n = 1, ntry3
            if (coords(i) >= chmin(ijkdst(n)) .and. &
                coords(i) <= chmax(ijkdst(n))) then
               dist (n) = abs (coords(i) - midp (ijkdst(n)))
            else
               dist (n) = remax
            endif
         end do
!
!===> ... Look for the minimum distance
!
         nmin = MINLOC (dist(1:ntry3))
#ifdef MINLOCFIX
         if (nmin(1).eq.0) nmin=1
#endif /* MINLOCFIX */
!
         if (dist(nmin(1)) .ne. remax) then
            found (i)  = lev
            loc (i) = ijkdst (nmin(1))
!
            nprev = nprev - 1
!
#ifdef DEBUG
            nfnd (3) = nfnd (3) + 1
#endif /* DEBUG */
         endif
!
!===> ... Start index of the next search
!
260      if (i >= iend-ijkinc) exit
         ibegl = min (iend-ijkinc, i+ijkinc)
!
      end do ! while (ibegl <= iend)
!
      if (nprev == 0) go to 20

!-----------------------------------------------------------------------
!     Some points were still not found.
!     Look again on the next coarser level whether the points
!     are located in other cells.
!-----------------------------------------------------------------------
!
      ibegl = ibeg

      do while (ibegl <= iend)
!
!===> ... Look for the next cell to be controlled
!
!cdir vector
         do i = ibegl, iend, ijkinc
            if (found (i) == levc) go to 311
         end do
!
         if (i < iend+ijkinc) then
            i = iend
            if (found (i) == levc) go to 311
         endif
!
         exit
!
!===> ... Look in the coarser parts of cell loc(i)
!
311      continue
#ifdef PRISM_ASSERTION
         if (loc(i) < 0) then
            print *, i, loc(i)
            call psmile_assert (__FILE__, __LINE__, 'incorrect loc(i)')
         endif
#endif /* PRISM_ASSERTION */
!
         if (lev+1 < nlev) then
            call psmile_mg_prev_levels_1d_real (grid_id, idim, lev, nlev, &
                              loc(i), coords(i), ifound, newijk)
!
            if (ifound .gt. 0) then
               loc (i) = newijk
!
               found (i) = lev
#ifdef DEBUG
               nfnd (4) = nfnd (4) + 1
#endif /* DEBUG */
            else
               found (i) = - found (i)
#ifdef DEBUG
               nfnd (0) = nfnd (0) + 1
#endif /* DEBUG */
            endif
         else
            found (i) = - found (i)
#ifdef DEBUG
            nfnd (0) = nfnd (0) + 1
#endif /* DEBUG */
         endif
!
!===> ...
!
         nprev = nprev - 1
         if (nprev == 0) go to 20
!
!===> ... Start index of the next search
!
         if (i == iend) exit

         ibegl = min (iend, i+ijkinc)
      end do ! while (ibegl <= iend)
!
!===> All done
!
20    continue

#ifdef DEBUGX
      print *, 'end ---'
      do i = ibeg, iend
         print *, 'i, coord, found', i, coords (i), loc(i), found (i), chmin(loc(i)), chmax(loc(i))
      end do
#endif
!
#ifdef DEBUG
      print 9970, trim(ch_id), lev, nfnd, ijkinc
9970  format (1x, a, ': psmile_mg_next_level_1d_real: lev =', i3, &
              ': fnd =', 5i8, ', ijkinc ', 3i4)
#endif /* DEBUG */

#ifdef VERBOSE
      print 9980, trim(ch_id), lev

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

      end subroutine psmile_mg_next_level_1d_real