psmile_mg_ctrl_subgrid_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_ctrl_subgrid_1d_real
!
! !INTERFACE:

      subroutine psmile_mg_ctrl_subgrid_1d_real (     &
                    array, corner_shape, nbr_corners, &
                           range,                     &
                    chmin, chmax, levdim, period,     &
                    grid_id, ind, ierror)
!
! !USES:
!
      use PRISM_constants
!
      use PSMILe, dummy_interface => PSMILe_MG_ctrl_subgrid_1d_real

      implicit none
!
! !INPUT PARAMETERS:
!
      Integer, Intent (In)             :: corner_shape(2), nbr_corners

!     Dimensions of "array"
!
      Real, Intent (In)                :: array (corner_shape(1):
                                                 corner_shape(2),
                                                 nbr_corners)

!     Fully dimensioned array "array" for which the first MG level
!     was be computed.

      Integer, Intent (In)             :: range (2)

!     Definintion of the subgrid

      Integer, Intent (In)             :: levdim

!     Dimension of the first MG level

      Real, Intent (In)                :: chmin (0:levdim)
!
!     Minimum value of bounding box of coordinate array "array".
!
      Real, Intent (In)                :: chmax (0:levdim)
!
!     Maximum value of bounding box of coordinate array "array".
!
      Real, Intent (In)                :: period
!
!     Period of cyclic coordinate

      Integer, Intent (In)             :: grid_id

!     Grid id

      Integer, Intent (In)             :: ind

!     Index of the grid
!
! !OUTPUT PARAMETERS:
!
      Integer, Intent (Out)            :: ierror

!     Returns the error code of PSMILe_MG_ctrl_subgrid_1d_real
!             ierror = 0 : No error
!             ierror > 0 : Severe error
!
! !LOCAL VARIABLES
!
      Integer                          :: i, ibeg, iend
      Real                             :: dist_cyclic
!
! !DESCRIPTION:
!
! Subroutine "PSMILe_MG_ctrl_subgrid_1d_real" controls whether
! the "control volumes" defined by the corner arrays "array" fulfill the
! internal requirements of the MG search.
!
! !REVISION HISTORY:
!
!   Date      Programmer   Description
! ----------  ----------   -----------
! 03.06.25    H. Ritzdorf  created
!
!EOP
!----------------------------------------------------------------------
!
!  $Id: psmile_mg_ctrl_subgrid_1d_real.F90 2325 2010-04-21 15:00:07Z valcke $
!  $Author: valcke $
!
   Character(len=len_cvs_string), save :: mycvs = 
       '$Id: psmile_mg_ctrl_subgrid_1d_real.F90 2325 2010-04-21 15:00:07Z valcke $'
!
!----------------------------------------------------------------------
!
#ifdef VERBOSE
      print 9990, trim(ch_id)

      call psmile_flushstd
#endif /* VERBOSE */
!
!  Initialization
!
      ierror = 0
!
      ibeg = 0
      iend = min (range(1)+levdim, range (2)) - range (1)
!
!     Control cells and warn user
!
      dist_cyclic = period * 0.5

!cdir vector
         do i = ibeg, iend
         if (chmax(i) - chmin(i) > dist_cyclic) exit
         end do
!
      if (i <= iend) then
!
!     ... A cell violating the internal requirements was probably found
!         Warn user !
!
         ibeg = i
         print 9970, trim(ch_id), grid_id, trim(Grids(grid_id)%grid_name), &
                     name_coord(ind)
!
            do i = ibeg, iend
            if (chmax(i) - chmin(i) > dist_cyclic) then
               ierror = ierror - 1
               print 9960, i+range(1), array (i+range(1), :)
            end if
            end do
!
         print *
      endif
!
!===> All done
!
#ifdef VERBOSE
      if ( ierror == 0 ) then
         print 9980, trim(ch_id), ierror
      else
         print 9981, trim(ch_id), abs(ierror)     
      endif

      call psmile_flushstd
#endif /* VERBOSE */
!
!  Formats:
!
9990  format (1x, a, ': psmile_mg_ctrl_subgrid_1d_real')
9980  format (1x, a, ': psmile_mg_ctrl_subgrid_1d_real eof: ierror =', i4)
9981  format (1x, a, ': psmile_mg_ctrl_subgrid_1d_real eof: issue warning for', i8, ' cells.')

9970  format (/1x, a, ': #### WARNING in psmile_mg_ctrl_subgrid_1d_real:', &
              /10x, 'Cells with incorrect (periodic) corner coordinates ', &
                    'probably found !' &
              /10x, 'Grid id ', i4, '; name:', 1x, a, &
              /10x, 'Cell indices of ', a, ' coordinate direction:')
9960  format (1x, 'Index', i7, '; coordinates', (1x, 4f16.9))
!
      end subroutine PSMILe_MG_ctrl_subgrid_1d_real