psmile_mg_ctrl_subgrid_2d_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_ctrl_subgrid_2d_dble
!
! !INTERFACE:

      subroutine psmile_mg_ctrl_subgrid_2d_dble (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_2d_dble

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

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

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

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

!     Definintion of the subgrid

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

!     Dimensions of the first MG level

      Double Precision, Intent (In)    :: chmin (0:levdim(1), 0:levdim(2))
!
!     Minimum value of bounding box of coordinate array "array".
!
      Double Precision, Intent (In)    :: chmax (0:levdim(1), 0:levdim(2))
!
!     Maximum value of bounding box of coordinate array "array".
!
      Double Precision, 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_2d_dble
!             ierror = 0 : No error
!             ierror > 0 : Severe error
!
! !LOCAL VARIABLES
!
      Integer                          :: i, j, jbeg
      Integer                          :: ijend (2)
      Double Precision                 :: dist_cyclic
!
! !DESCRIPTION:
!
! Subroutine "PSMILe_MG_ctrl_subgrid_2d_dble" 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_2d_dble.F90 2325 2010-04-21 15:00:07Z valcke $
!  $Author: valcke $
!
   Character(len=len_cvs_string), save :: mycvs = 
       '$Id: psmile_mg_ctrl_subgrid_2d_dble.F90 2325 2010-04-21 15:00:07Z valcke $'
!
!----------------------------------------------------------------------
!
#ifdef VERBOSE
      print 9990, trim(ch_id)

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

loopj:   do j = 0, ijend(2)
!cdir vector
            do i = 0, ijend (1)
            if (chmax(i,j) - chmin (i,j) > dist_cyclic) exit loopj
            enddo
         enddo loopj
!
      if (j <= ijend(2)) 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)
!
         jbeg = j
            do j = jbeg, ijend(2)
               do i = 0, ijend (1)
               if (chmax(i,j) - chmin (i,j) > dist_cyclic) then
                  ierror = ierror - 1
                  print 9960, i+range(1,1), j+range(1,2), &
                       array (i+range(1,1), j+range(1,2), :)
               end if
               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_2d_dble')
9980  format (1x, a, ': psmile_mg_ctrl_subgrid_2d_dble eof: ierror =', i4)
9981  format (1x, a, ': psmile_mg_ctrl_subgrid_2d_dble eof: issue warning for', i8, ' cells.')

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