psmile_bbcells_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_bbcells_2d_real
!
! !INTERFACE:

      subroutine psmile_bbcells_2d_real (           &
                      coords, coords_shape, sub_range, &
                      corner_shape,                    &
                      chmin, chmax, midp, levdim,      &
                      period, ierror)
!
! !USES:
!
      use PRISM_constants
!
      use psmile_grid, only : psmile_transform_cell_cyclic
      use psmile, dummy_interface => psmile_bbcells_2d_real

      Implicit none
!
! !INPUT PARAMETERS:
!
      Integer,           Intent (In)  :: coords_shape (2, ndim_2d)

!     Dimension of (method/grid) coordinate "coords"

      Real,              Intent (In)  :: 
         coords(coords_shape(1,1):coords_shape(2,1), 
                coords_shape(1,2):coords_shape(2,2))

!     Coordinates of the method

      Integer,           Intent (In)  :: sub_range (2, ndim_2d)

!     Definintion of the subgrid for which the (bounding) cells should
!     be computed.

      Integer,           Intent (In)  :: corner_shape (2, ndim_2d)

!     Dimension of the array "corners" containing the corner points
!     of the control volume (for a single coordinate).

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

!     Dimension of output arrays "chmin", "chmax" and "midp".
!     For testing.
!
      Real,              Intent (In)  :: period
!
!     Type (Split_Information), Intent (InOut) :: split_info
!
! !OUTPUT PARAMETERS:
!
      Real,              Intent (Out) :: chmin (sub_range(1,1)-1:sub_range(2,1), 
                                                sub_range(1,2)-1:sub_range(2,2))
!
!     Minimum value of bounding box of method cell
!
      Real,              Intent (Out) :: chmax (sub_range(1,1)-1:sub_range(2,1), 
                                                sub_range(1,2)-1:sub_range(2,2))
!
!     Maximum value of bounding box of method cell
!
      Real,              Intent (Out) :: midp  (sub_range(1,1)-1:sub_range(2,1), 
                                                sub_range(1,2)-1:sub_range(2,2))
!
!     Mid point of bounding box of method cell
!
      Integer,           Intent (Out) :: ierror

!     Returns the error code of psmile_bbcells_2d_real
!             ierror = 0 : No error
!             ierror > 0 : Severe error
!
! !DEFINED PARAMETERS:
!
! r_nbr = 1 / Number of corners per grid cell.
!
      Integer,          Parameter  :: n_corners = 4
      Real,             Parameter  :: r_nbr = 0.25d0
!
! !LOCAL VARIABLES
!
      Integer                      :: i, ibeg, iend
      Integer                      :: j, jbeg, jend
!
!     Auxiliary fields for cyclic method cells
!
      Real                         :: cell (n_corners)
!
      Real                         :: period2
!
! Error parameters
!
      Integer, Parameter           :: nerrp = 2
      Integer                      :: ierrp (nerrp)
!
!
! !DESCRIPTION:
!
! Subroutine "psmile_bbcells_2d_real" computes the bounding box for
! each cell in (sub_range(1,1):sub_range(2,1)-1, sub_range(1,2):sub_range(2,2)-1)
! (i.e. witin the interior of the 2-dimensional block)
! of the 2-dimensional coordinate defined by "array".
!
! chmin (i, j) returns the minimal value of bounding box of
!              method cell ((i,j), (i+1,j), (i,j+1), (i+1,j+1))
! chmax (i, j) returns the maximal value of bounding box of
!              method cell ((i,j), (i+1,j), (i,j+1), (i+1,j+1))
! midp  (i, j) returns the mid point of
!              method cell ((i,j), (i+1,j), (i,j+1), (i+1,j+1))
!
! !REVISION HISTORY:
!
!   Date      Programmer   Description
! ----------  ----------   -----------
! 05.05.09    H. Ritzdorf  created
! 08.09.10    M. Hanke     simplified handling of cyclic coordinate ranges
!
!EOP
!----------------------------------------------------------------------
!
!  $Id: psmile_bbcells_2d_real.F90 2687 2010-10-28 15:15:52Z coquart $
!  $Author: coquart $
!
   Character(len=len_cvs_string), save :: mycvs = 
       '$Id: psmile_bbcells_2d_real.F90 2687 2010-10-28 15:15:52Z coquart $'
!
!----------------------------------------------------------------------
!
#ifdef VERBOSE
      print 9990, trim(ch_id)

      call psmile_flushstd
#endif /* VERBOSE */

#ifdef PRISM_ASSERTION
      if (sub_range(1,1) < corner_shape(1,1) .or. &
          sub_range(2,1) > corner_shape(2,1) .or. &
          sub_range(1,2) < corner_shape(1,2) .or. &
          sub_range(2,2) > corner_shape(2,2)) then
         print *, trim(ch_id), "psmile_bbcells_2d_real: sub_range", sub_range
         print *, trim(ch_id), "psmile_bbcells_2d_real: corner_shape", &
                  corner_shape

         call psmile_assert (__FILE__, __LINE__, &
              "range must be in corner_shape")
      endif
!
      if (minval(levdim(:)-(sub_range(2,:)-sub_range(1,:)+2)) < 0) then
         print *, trim(ch_id), "psmile_bbcells_2d_real: levdim", levdim
         print *, trim(ch_id), "psmile_bbcells_2d_real: sub_range ", sub_range

         call psmile_assert (__FILE__, __LINE__, &
              "levdim < sub_range(2,:)-sub_range(1,:)+2")
      endif
#endif
!
!  Initialization
!
      ierror = 0
!
      ibeg = sub_range (1,1) - 1
      iend = sub_range (2,1) + 1
!
      jbeg = sub_range (1,2) - 1
      jend = sub_range (2,2) + 1
!
      period2 = period * 0.5d0
!
!=======================================================================
!     Special case: 1-dimensional
!=======================================================================
!
!     MoHa: does the 1d case require special handling of cyclic
!           coordinate ranges?
!
      if (sub_range(1,2) == sub_range (2,2)) then
!
         j = jbeg

!  ...... Set bounding box of method cells
!
!  ...... Compute values using the method coordinates
!
!cdir vector
         do i = ibeg, iend-1
            chmin (i, j) = min (coords(i,j), coords (i+1,j))
         enddo
!
!cdir vector
         do i = ibeg, iend-1
            chmax (i, j) = max (coords(i,j), coords (i+1,j))
         enddo
!
!cdir vector
         do i = ibeg, iend-1
            midp (i, j) = (coords(i,j) + coords (i+1,j)) * 0.5
         enddo
!
      else if (sub_range(1,1) == sub_range(2,1)) then
!
         i = ibeg

!  ...... Set bounding box of method cells
!
!cdir vector
         do j = jbeg, jend-1
            chmin (i, j) = min (coords(i,j), coords (i,j+1))
         enddo
!
!cdir vector
         do j = jbeg, jend-1
            chmax (i, j) = max (coords(i,j), coords (i,j+1))
         enddo
!
!cdir vector
         do j = jbeg, jend-1
            midp (i, j) = (coords(i,j) + coords (i,j+1)) * 0.5
         enddo
      else
!
!=======================================================================
!     Regular 2d array
!=======================================================================
!
!     Compute minimum extension of method cell
!

         do j = jbeg, jend-1
!cdir vector
            do i = ibeg, iend-1
               chmin (i, j) = min (coords(i,j  ), coords (i+1,j  ), &
                                 coords(i,j+1), coords (i+1,j+1))
            enddo
!
!     Compute maximum extension of method cell
!
!cdir vector
            do i = ibeg, iend-1
               chmax (i, j) = max (coords(i,j  ), coords (i+1,j  ), &
                                 coords(i,j+1), coords (i+1,j+1))
            enddo
!
!     Compute mid point of method cell
!
!cdir vector
            do i = ibeg, iend-1
               midp (i, j)  = (coords(i,j  ) + coords (i+1,j  ) + &
                              coords(i,j+1) + coords (i+1,j+1)) * r_nbr
            enddo
         enddo
!
!     Apply handling for cyclic coordinate ranges
!
         do j = jbeg, jend-1
!cdir vector
            do i = ibeg, iend-1
               ! if the current cell might require special handling
               if (chmax(i,j)-chmin(i,j) > period2) then

                  ! get the cell
                  cell(1) = coords(i  ,j  ); cell(2) = coords(i+1,j)
                  cell(3) = coords(i+1,j+1); cell(4) = coords(i,j+1)

                  ! apply handling for cyclic coordinate ranges
                  ! (in case this handling was not required this
                  ! routine does nothing)
                  call psmile_transform_cell_cyclic (cell, period, ierror)


                  ! compute new min max and mid point values
                  chmin (i, j) = minval(cell)
                  chmax (i, j) = maxval(cell)
                  midp  (i, j) = sum(cell)  * r_nbr
               end if
            end do
         end do
      endif
!
!===> All done
!
#ifdef VERBOSE
      print 9980, trim(ch_id), ierror

      call psmile_flushstd
#endif /* VERBOSE */
!
!  Formats:
!
9990 format (1x, a, ': psmile_bbcells_2d_real')
9980 format (1x, a, ': psmile_bbcells_2d_real: eof ierror =', i3)
!
      end subroutine psmile_bbcells_2d_real