psmile_mg_ctrl_subgrid_3d_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_3d_real
!
! !INTERFACE:

      subroutine psmile_mg_ctrl_subgrid_3d_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_3d_real

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

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

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

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

!     Definintion of the subgrid

      Integer, Intent (In)             :: levdim (ndim_3d)

!     Dimensions of the first MG level

      Real, Intent (In)                :: chmin (0:levdim(1), 0:levdim(2), 
                                                 0:levdim(3))
!
!     Minimum value of bounding box of coordinate array "array".
!
      Real, Intent (In)                :: chmax (0:levdim(1), 0:levdim(2), 
                                                 0:levdim(3))
!
!     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

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

!     Returns the error code of PSMILe_MG_ctrl_subgrid_3d_real
!             ierror = 0 : No error
!             ierror > 0 : Severe error
!
! !LOCAL VARIABLES
!
      Integer                          :: i, j, k, kbeg
      Integer                          :: ijkend (ndim_3d)
      Real                             :: dist_cyclic
!
! !DESCRIPTION:
!
! Subroutine "PSMILe_MG_ctrl_subgrid_3d_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_3d_real.F90 2325 2010-04-21 15:00:07Z valcke $
!  $Author: valcke $
!
   Character(len=len_cvs_string), save :: mycvs = 
       '$Id: psmile_mg_ctrl_subgrid_3d_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
!
      ijkend(:) = min (range(1,:)+levdim(:), range (2,:)) - range (1,:)
!
!     Control cells and warn user
!
      dist_cyclic = period * 0.5

loopk:   do k = 0, ijkend (3)
            do j = 0, ijkend (2)
!cdir vector
               do i = 0, ijkend (1)
               if (chmax(i,j,k) - chmin (i,j,k) > dist_cyclic) exit loopk
               enddo
            enddo
         enddo loopk
!
      if (k <= ijkend (3)) then
!
!     ... A cell violating the internal requirements was probably found
!         Warn user !
!
         print 9970, trim(ch_id), grid_id, trim(Grids(grid_id)%grid_name), &
                     name_coord(ind)
!
         kbeg = k
            do k = kbeg, ijkend (3)
               do j = 0, ijkend (2)
                  do i = 0, ijkend (1)
                  if (chmax(i,j,k) - chmin (i,j,k) > dist_cyclic) then
                     ierror = ierror - 1
                     print 9960, i+range(1,1), j+range(1,2), k+range(1,3), &
                          array (i+range(1,1), j+range(1,2), k+range(1,3), :)
                  end if
                  end do
               end do
            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_3d_real')
9980  format (1x, a, ': psmile_mg_ctrl_subgrid_3d_real eof: ierror =', i4)
9981  format (1x, a, ': psmile_mg_ctrl_subgrid_3d_real eof: issue warning for', i8, ' cells.')

9970  format (/1x, a, ': #### WARNING in psmile_mg_ctrl_subgrid_3d_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, 'Indices(', i7, ',', i7, ',', i7, '); coordinates', &
              (1x, 4f16.9))
!
      end subroutine PSMILe_MG_ctrl_subgrid_3d_real