psmile_mg_first_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_First_subgrid_2d_dble
!
! !INTERFACE:

      subroutine psmile_mg_first_subgrid_2d_dble (array, &
                    idlow, idhigh, jdlow, jdhigh, nbr_corners,   &
                           range,                        &
                    chmin, chmax, midp,                  &
                    levdim1, levdim2, ierror)
!
! !USES:
!
      use PRISM_constants
!
      use PSMILe, dummy_interface => PSMILe_MG_First_subgrid_2d_dble

      implicit none
!
! !INPUT PARAMETERS:
!
      Integer, Intent (In)             :: idlow, idhigh, jdlow, jdhigh
      Integer, Intent (In)             :: nbr_corners
!
!     Dimensions of "array"
!
      Double Precision, Intent (In)    :: array (idlow:idhigh, jdlow:jdhigh, 
                                                 nbr_corners)
!
!     Fully dimensioned arrays for which the first level
!     should be computed.
!
      Integer, Intent (In)             :: range (2, 2)
!
!     Definintion of the subgrid
!
      Integer, Intent (In)             :: levdim1, levdim2
!
!     Dimension of the first MG level
!
! !OUTPUT PARAMETERS:
!
      Double Precision, Intent (Out)   :: chmin (0:levdim1, 0:levdim2)
!
!     Minimum extension of bounding box of each coordinate cell.
!

      Double Precision, Intent (Out)   :: chmax (0:levdim1, 0:levdim2)
!
!     Maximum extension of bounding box of each coordinate cell.
!
      Double Precision, Intent (Out)   :: midp  (0:levdim1, 0:levdim2)
!
!     Mid point of bounding box of each coordinate cell.
!
      Integer, Intent (Out)            :: ierror
!
!     Returns the error code of PSMILe_MG_First_subgrid_2d_dble
!             ierror = 0 : No error
!             ierror > 0 : Severe error
!
! !DEFINED PARAMETERS:
!
      Double Precision, Parameter      :: epsp1 = 1.0d0 + 5d-6
!
! !LOCAL VARIABLES
!
      integer                          :: i, ibeg, iend
      integer                          :: j, jbeg, jend
!
      Double Precision                 :: r_nbr
!
! !DESCRIPTION:
!
! Subroutine "PSMILe_MG_First_subgrid_2d_dble" computes the bounding
! boxes and the mid point for the corner coordinates ("control volumes")
! for a 2-dimensional subgrid. The bounding boxes and mid points are
! used in the Multigrid search.
!
!
! !REVISION HISTORY:
!
!   Date      Programmer   Description
! ----------  ----------   -----------
! 03.06.25    H. Ritzdorf  created
!
!EOP
!----------------------------------------------------------------------
!
!  $Id: psmile_mg_first_subgrid_2d_dble.F90 2325 2010-04-21 15:00:07Z valcke $
!  $Author: valcke $
!
   Character(len=len_cvs_string), save :: mycvs = 
       '$Id: psmile_mg_first_subgrid_2d_dble.F90 2325 2010-04-21 15:00:07Z valcke $'
!
!----------------------------------------------------------------------
!
#ifdef VERBOSE
      print *, trim(ch_id), ': PSMILe_MG_First_subgrid_2d_dble'

      call psmile_flushstd
#endif /* VERBOSE */

#ifdef PRISM_ASSERTION
      if (range(2,1)-range(1,1) > levdim1 .or. &
          range(2,2)-range(1,2) > levdim2) then
         call psmile_assert ( __FILE__, __LINE__, &
                             'invalid range specified')

      endif
#endif
!
!  Initialization
!
      ierror = 0
!
      ibeg = range (1, 1)
      iend = min (range(1, 1)+levdim1, range (2, 1))
!
      jbeg = range (1, 2)
      jend = min (range(1, 2)+levdim2, range (2, 2))
!
      r_nbr = 1.0 / nbr_corners
!
!     ... Compute minimum extension of grid cell
!
         do j = jbeg, jend
!cdir vector
            do i = ibeg, iend
            chmin (i-range(1,1), j-range(1,2)) = MINVAL (array (i, j, :))
            enddo
         enddo
!
!     ... Compute maximum extension of grid cell
!
         do j = jbeg, jend
!cdir vector
            do i = ibeg, iend
            chmax (i-range(1,1), j-range(1,2)) = MAXVAL (array (i, j, :))
            enddo
         enddo
!
!     ... Compute mid point of grid cell
!
         do j = jbeg, jend
!cdir vector
            do i = ibeg, iend
            midp (i-range(1,1), j-range(1,2))  = SUM (array (i, j, :)) * r_nbr
            enddo
         enddo
!
!     ... Create dummy cells if necessary
!
         ibeg = ibeg - range(1,1)
         iend = iend - range(1,1)
         jbeg = jbeg - range(1,2)
         jend = jend - range(1,2)

         if (iend < levdim1) then
!cdir vector
            do j = jbeg, jend
               chmin (iend+1:levdim1, j) = chmax (iend, j) * epsp1
               chmax (iend+1:levdim1, j) = chmax (iend, j)
               midp  (iend+1:levdim1, j) = midp  (iend, j)
            enddo
         endif
!
         if (jend < levdim2) then
!cdir vector
            do j = jend+1, levdim2
               chmin (ibeg:levdim1, j) = chmax (ibeg:levdim1, jend) * epsp1
               chmax (ibeg:levdim1, j) = chmax (ibeg:levdim1, jend)
               midp  (ibeg:levdim1, j) = midp  (ibeg:levdim1, jend)
            enddo
         endif
!
!===> All done
!
#ifdef DEBUG
      print *, 'dim', levdim1, levdim2
      print *, 'range', range
      print *, 'chmin', chmin (0,0),       chmin (levdim1, 0), &
                        chmin (0,levdim2), chmin (levdim1, levdim2)
      print *, 'chmax', chmax (0,0),       chmax (levdim1, 0), &
                        chmax (0,levdim2), chmax (levdim1, levdim2)
      print *, 'midp ', midp  (0,0),       midp  (levdim1, 0), &
                        midp  (0,levdim2), midp  (levdim1, levdim2)
#endif

#ifdef VERBOSE
      print *, trim(ch_id), ': PSMILe_MG_First_subgrid_2d_dble eof', &
                            ': ierror =', ierror

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