psmile_mg_prev_levels_1d_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_Prev_levels_1d_dble
!
! !INTERFACE:

      subroutine psmile_mg_prev_levels_1d_dble (grid_id, idim, lev, nlev, &
                           lstijk, xyz, found, newijk)
!
! !USES:
!
      use PRISM_constants
!
      use PSMILe, dummy_interface => PSMILe_mg_prev_levels_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)            :: lev

!     Level number of the next grid

      Integer, Intent (In)            :: nlev

!     Total number of levels

      Integer, Intent (In)            :: lstijk

!     Last indices of cell on coarse level LEV+1

      Double Precision, Intent (In)   :: xyz

!     Coordinates of the point which is searched
!
! !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:
!
      Logical, parameter              :: wide = .true.
      Logical, parameter              :: small = .false.
!
! !LOCAL VARIABLES
!
!     ... for levels

      Integer                         :: levc, levd, levdbg, levu, levubg
      Integer                         :: nold (nlev), ijk (nlev)
      Logical                         :: all (nlev)
      Type (Grid), Pointer            :: grid_info
!
! !DESCRIPTION:
!
! Subroutine "PSMILe_mg_prev_levels_1d_dble" searches for the donor cell
! of point "sent".  The point was last found on level LEVC in donor cell (IC).
!
!
! !REVISION HISTORY:
!
!   Date      Programmer   Description
! ----------  ----------   -----------
! 03.07.21    H. Ritzdorf  created
!
!EOP
!----------------------------------------------------------------------
!
!  $Id: psmile_mg_prev_levels_1d_dble.F90 2325 2010-04-21 15:00:07Z valcke $
!  $Author: valcke $
!
   Character(len=len_cvs_string), save :: mycvs = 
       '$Id: psmile_mg_prev_levels_1d_dble.F90 2325 2010-04-21 15:00:07Z valcke $'
!
!----------------------------------------------------------------------
!
!  Initialization
!
#ifdef VERBOSE
      print 9990, trim(ch_id), lev

      call psmile_flushstd
#endif /* VERBOSE */
!
      grid_info => Grids(grid_id)

      levc = lev + 1

#ifdef PRISM_ASSERTION
      if (levc >= nlev) then
         call psmile_assert (__FILE__, __LINE__, 'incorrect level')
      endif
!
      if (lstijk < 0 .or. &
          lstijk > grid_info%mg_infos(levc)%levdim(idim)) then
         print *, lstijk, grid_info%mg_infos(levc)%levdim(idim)
         call psmile_assert (__FILE__, __LINE__, 'wrong lstijk')
      endif
#endif
!
      ijk (levc) = lstijk
!
         do levd = levc, nlev-1
         all  (levd) = .false.
         nold (levd) = 1
         end do
!
!===> ... Compute indices on the coarser levels
!
         do levd = levc+1, nlev-1
         if (grid_info%mg_infos(levd)%levdim(idim) /= &
             grid_info%mg_infos(levd-1)%levdim(idim) ) then
            ijk (levd) = ijk (levd-1) / 2
         else
            ijk (levd) = ijk (levd-1)
         endif
         end do
!
!---------------------------------------------------------------------
!     Go down in the level hierarchie
!---------------------------------------------------------------------
!
      levdbg = levc
!
100   continue
!
         do levd = levdbg, nlev-1
!
#ifdef PRISM_ASSERTION
         if (ijk(levd) < 0 .or. &
             ijk(levd) > grid_info%mg_infos(levd)%levdim(idim)) then
            print *, levd, ijk(levd), grid_info%mg_infos(levd)%levdim(idim)
            print *, lstijk, levc
            call psmile_assert (__FILE__, __LINE__, 'wrong ijk(levd)')
         endif
#endif /* PRISM_ASSERTION */
!
         call psmile_mg_control_cell_1d_dble ( &
             grid_info%mg_infos(levd)%double_arrays%chmin(idim)%vector, &
             grid_info%mg_infos(levd)%double_arrays%chmax(idim)%vector, &
             grid_info%mg_infos(levd)%double_arrays%midp (idim)%vector, &
             grid_info%mg_infos(levd)%levdim(idim), &
             ijk(levd), xyz, nold(levd), all(levd), wide, found, newijk)
!
         if (found > 0) go to 1990
!
         end do
!
!===> Not found
!

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

      call psmile_flushstd
#endif /* VERBOSE */

      return
!
!---------------------------------------------------------------------
!     Up again; startpoint is newijk on level levd
!---------------------------------------------------------------------
!
1990  nold (levd) = found
      all (levd) = .true.
!
      levdbg = levd
      levubg = levd - 1
!
      nold (levubg) = 0
      all  (levubg) = .true.
!
      if (grid_info%mg_infos(levubg)%levdim(idim) > &
          grid_info%mg_infos(levubg+1)%levdim(idim)) then
         ijk (levubg) = min (newijk*2, grid_info%mg_infos(levubg)%levdim(idim))
      else
         ijk (levubg) = newijk
      endif
!
1995  continue
!
         do levu = levubg, lev, -1
         if (levu .ne. levubg) then
            if (grid_info%mg_infos(levu)%levdim(idim) > &
                grid_info%mg_infos(levu+1)%levdim(idim)) then
               ijk (levu) = min (newijk*2, grid_info%mg_infos(levu)%levdim(idim))
            else
               ijk (levu) = newijk
            endif
         endif
!
#ifdef PRISM_ASSERTION
         if (ijk(levu) < 0 .or. &
             ijk(levu) > grid_info%mg_infos(levu)%levdim(idim)) then
            print *, levu, ijk(levu), grid_info%mg_infos(levu)%levdim(idim)
            call psmile_assert (__FILE__, __LINE__, 'wrong ijk(levu)')
         endif
#endif /* PRISM_ASSERTION */
!
         call psmile_mg_control_cell_1d_dble ( &
             grid_info%mg_infos(levu)%double_arrays%chmin(idim)%vector, &
             grid_info%mg_infos(levu)%double_arrays%chmax(idim)%vector, &
             grid_info%mg_infos(levu)%double_arrays%midp (idim)%vector, &
             grid_info%mg_infos(levu)%levdim(idim),                   &
             ijk(levu), xyz, nold(levu), all(levu), small, found, newijk)
!
         if (found .eq. 0) then
            if (levu .lt. levd-1) then
!
!===> ... go back to the previous level; and try again
!
               levubg = levu + 1
               go to 1995
            else
!
!===> ... go down
!
               go to 100
            endif
!
         else if (levu > lev) then
            all (levu) = .true.
            nold (levu) = found
!
            nold (levu-1) = 0
            all (levu-1) = .true.
         endif
         end do ! levu
!
!===> All done
!
#ifdef VERBOSE
      print 9980, trim(ch_id), lev

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

      end subroutine PSMILe_mg_prev_levels_1d_dble