psmile_range_subgrid_2d_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_Range_Subgrid_2d_real
!
! !INTERFACE:

      subroutine psmile_range_subgrid_2d_real (           &
                    array1, array2,                       &
                            idlow, idhigh, jdlow, jdhigh, &
                            nbr_corners,                  &
                            ibeg, iend, jbeg, jend,       &
                    rinter, inter, ierror)
!
! !USES:
!
      use PRISM_constants
!
      use PSMILe, dummy_interface => PSMILe_Range_Subgrid_2d_real

      implicit none
!
! !INPUT PARAMETERS:
!
      integer, Intent (In)             :: idlow, idhigh
      integer, Intent (In)             :: jdlow, jdhigh
      integer, Intent (In)             :: nbr_corners

!     Dimensions of "array1" and "array2"

      real, Intent (In)                :: array1 (idlow:idhigh, 
                                                  jdlow:jdhigh, 
                                                  nbr_corners)
      real, Intent (In)                :: array2 (idlow:idhigh, 
                                                  jdlow:jdhigh, 
                                                  nbr_corners)

!     Fully dimensioned arrays for which the range of 2d-intersection
!     should be computed.

      integer, Intent (In)             :: ibeg, iend, jbeg, jend

!     Definintion of the subgrid

      Real, Intent (In)                :: rinter (2, 2)

!     Specifies the intersection for which the range should be found.
!
! !OUTPUT PARAMETERS:
!
      Integer, Intent (Out)            :: inter (2, 2)

!     Returns the range of the intersection

      integer, Intent (Out)            :: ierror

!     Returns the error code of PSMILe_Range_Subgrid_2d_real;
!             ierror = 0 : No error
!             ierror > 0 : Severe error
!
! !DEFINED PARAMETERS:
!
      logical, parameter :: all = .true. ! Brut force
!
! !LOCAL VARIABLES
!
      integer            :: i, j
!
      logical            :: same
!
! !DESCRIPTION:
!
! Subroutine "PSMILe_Range_Subgrid_2d_Real" computes the range of
! of grid contained in array~(ibeg:iend,~jbeg:jend,~nbr_corners) which contains
! the intersection "rinter"
!
!
! !REVISION HISTORY:
!   Date      Programmer   Description
! ----------  ----------   -----------
! 01.12.03    H. Ritzdorf  created
!
!EOP
!----------------------------------------------------------------------
!
! $Id: psmile_range_subgrid_2d_real.F90 2325 2010-04-21 15:00:07Z valcke $
! $Author: valcke $
!
   Character(len=len_cvs_string), save :: mycvs = 
       '$Id: psmile_range_subgrid_2d_real.F90 2325 2010-04-21 15:00:07Z valcke $'
!
!----------------------------------------------------------------------

#ifdef VERBOSE
      print *, trim(ch_id), ': PSMILe_Range_Subgrid_2d_real'

      call psmile_flushstd
#endif /* VERBOSE */
!
!  Initialization
!
      ierror = 0
!
      inter (1, 1) = iend + 1
      inter (2, 1) = ibeg - 1
      inter (1, 2) = jend + 1
      inter (2, 2) = jbeg - 1
!
      same = ibeg == idlow .and. iend == idhigh
!
      if (same .or. all) then
!
         do j = jbeg, jend
!cdir vector
            do i = idlow, idhigh
            if (maxval(array1(i,j,:)) >= rinter (1,1) .and. &
                minval(array1(i,j,:)) <= rinter (2,1) .and. &
                maxval(array2(i,j,:)) >= rinter (1,2) .and. &
                minval(array2(i,j,:)) <= rinter (2,2)) then
               inter (1, 1) = min (inter (1,1), i)
               inter (2, 1) = max (inter (2,1), i)
               inter (1, 2) = min (inter (1,2), j)
               inter (2, 2) = max (inter (2,2), j)
            endif
            end do
         end do
!
         if (all .and. .not. same) then
            inter (1, 1) = max (inter (1,1), ibeg)
            inter (2, 1) = min (inter (2,1), iend)
         endif
!
      else
!
         do j = jbeg, jend
!cdir vector
            do i = ibeg, iend
            if (maxval(array1(i,j,:)) >= rinter (1,1) .and. &
                minval(array1(i,j,:)) <= rinter (2,1) .and. &
                maxval(array2(i,j,:)) >= rinter (1,2) .and. &
                minval(array2(i,j,:)) <= rinter (2,2)) then
               inter (1, 1) = min (inter (1,1), i)
               inter (2, 1) = max (inter (2,1), i)
               inter (1, 2) = min (inter (1,2), j)
               inter (2, 2) = max (inter (2,2), j)
            endif
            end do
         end do
      endif
!
!===> All done
!
#ifdef VERBOSE
      print *, trim(ch_id), ': PSMILe_Range_Subgrid_2d_real eof', &
                            ': ierror =', ierror &
                          , '; inter  =', inter

      call psmile_flushstd
#endif /* VERBOSE */
!
      end subroutine PSMILe_Range_Subgrid_2d_real