psmile_range_subgrid_3d_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_Range_Subgrid_3d_dble
!
! !INTERFACE:

      subroutine psmile_range_subgrid_3d_dble (           &
                    array1, array2, array3,               &
                            idlow, idhigh, jdlow, jdhigh, &
                            kdlow, kdhigh,                &
                            nbr_corners,                  &
                    shape, rinter, inter, ierror)
!
! !USES:
!
      use PRISM_constants
!
      use PSMILe, dummy_interface => PSMILe_Range_Subgrid_3d_dble

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

!     Dimensions of "array1" and "array2"

      double precision, Intent (In)    :: array1 (idlow:idhigh, 
                                                  jdlow:jdhigh, 
                                                  kdlow:kdhigh, 
                                                  nbr_corners)
      double precision, Intent (In)    :: array2 (idlow:idhigh, 
                                                  jdlow:jdhigh, 
                                                  kdlow:kdhigh, 
                                                  nbr_corners)
      double precision, Intent (In)    :: array3 (idlow:idhigh, 
                                                  jdlow:jdhigh, 
                                                  kdlow:kdhigh, 
                                                  nbr_corners)

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

      integer, Intent (In)             :: shape (2, ndim_3d)

!     Definintion of the subgrid

      double precision, Intent (In)    :: rinter (2, ndim_3d)

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

!     Returns the range of the intersection

      integer, Intent (Out)            :: ierror

!     Returns the error code of PSMILe_Range_Subgrid_3d_dble;
!             ierror = 0 : No error
!             ierror > 0 : Severe error
!
! !DEFINED PARAMETERS:
!
      logical, parameter :: all = .true. ! Brut force
!
! !LOCAL VARIABLES
!
      integer            :: i, j, k
!
      logical            :: same_i, same_ij
!
! !DESCRIPTION:
!
! Subroutine "PSMILe_Range_Subgrid_3d_dble" 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_3d_dble.F90 2325 2010-04-21 15:00:07Z valcke $
! $Author: valcke $
!
   Character(len=len_cvs_string), save :: mycvs = 
       '$Id: psmile_range_subgrid_3d_dble.F90 2325 2010-04-21 15:00:07Z valcke $'
!
!----------------------------------------------------------------------

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

      call psmile_flushstd
#endif /* VERBOSE */
!
!  Initialization
!
      ierror = 0
!
      inter (1, :) = shape (2, :) + 1
      inter (2, :) = shape (1, :) - 1
!
      same_i  = shape(1,1) == idlow .and. shape(2,1) == idhigh
      same_ij = shape(1,2) == jdlow .and. shape(2,2) == jdhigh .and. same_i
!
      if (same_ij .or. all) then
!
         do k = shape (1,3), shape (2,3)
            do j = jdlow, jdhigh
!cdir vector
               do i = idlow, idhigh
               if (maxval(array1(i,j,k,:)) >= rinter (1,1) .and. &
                   minval(array1(i,j,k,:)) <= rinter (2,1) .and. &
                   maxval(array2(i,j,k,:)) >= rinter (1,2) .and. &
                   minval(array2(i,j,k,:)) <= rinter (2,2) .and. &
                   maxval(array3(i,j,k,:)) >= rinter (1,3) .and. &
                   minval(array3(i,j,k,:)) <= rinter (2,3)) 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)
                  inter (1, 3) = min (inter (1,3), k)
                  inter (2, 3) = max (inter (2,3), k)
               endif
               end do
            end do
         end do
!
         if (all .and. .not. same_ij) then
            inter (1, :) = max (inter (1,:), shape (1, :))
            inter (2, :) = min (inter (2,:), shape (2, :))
         endif
!
      else if (same_i) then
!
         do k = shape (1,3), shape (2,3)
            do j = shape (1,2), shape (2,2)
!cdir vector
               do i = idlow, idhigh
               if (maxval(array1(i,j,k,:)) >= rinter (1,1) .and. &
                   minval(array1(i,j,k,:)) <= rinter (2,1) .and. &
                   maxval(array2(i,j,k,:)) >= rinter (1,2) .and. &
                   minval(array2(i,j,k,:)) <= rinter (2,2) .and. &
                   maxval(array3(i,j,k,:)) >= rinter (1,3) .and. &
                   minval(array3(i,j,k,:)) <= rinter (2,3)) 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)
                  inter (1, 3) = min (inter (1,3), k)
                  inter (2, 3) = max (inter (2,3), k)
               endif
               end do
            end do
         end do
!
      else
!
         do k = shape (1,3), shape (2,3)
            do j = shape (1,2), shape (2,2)
!cdir vector
               do i = shape (1,1), shape (2,1)
               if (maxval(array1(i,j,k,:)) >= rinter (1,1) .and. &
                   minval(array1(i,j,k,:)) <= rinter (2,1) .and. &
                   maxval(array2(i,j,k,:)) >= rinter (1,2) .and. &
                   minval(array2(i,j,k,:)) <= rinter (2,2) .and. &
                   maxval(array3(i,j,k,:)) >= rinter (1,3) .and. &
                   minval(array3(i,j,k,:)) <= rinter (2,3)) 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)
                  inter (1, 3) = min (inter (1,3), k)
                  inter (2, 3) = max (inter (2,3), k)
               endif
               end do
            end do
         end do
      endif
!
!===> All done
!
#ifdef VERBOSE
      print *, trim(ch_id), ': PSMILe_Range_Subgrid_3d_dble eof', &
                            ': ierror =', ierror
!                         , '; inter  =', inter

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