psmile_mg_first_subgrid_1d_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_1d_dble
!
! !INTERFACE:

      subroutine psmile_mg_first_subgrid_1d_dble (       &
                    array, idlow, idhigh, nbr_corners,   &
                           range,                        &
                    chmin, chmax, midp,                  &
                    levdim, ierror)
!
! !USES:
!
      use PRISM_constants
!
      use PSMILe, dummy_interface => PSMILe_MG_First_subgrid_1d_dble

      implicit none
!
! !INPUT PARAMETERS:
!
      Integer, Intent (In)             :: idlow, idhigh, nbr_corners

!     Dimensions of "array"
!
      Double Precision, Intent (In)    :: array (idlow:idhigh, nbr_corners)

!     Fully dimensioned Array for which the first level
!     should be computed.

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

!     Definintion of the subgrid

      Integer, Intent (In)             :: levdim

!     Dimension of the first MG level
!
! !OUTPUT PARAMETERS:
!
      Double Precision, Intent (Out)   :: chmin (0:levdim)
!
!     Minimum extension of bounding box of each coordinate cell.
!
      Double Precision, Intent (Out)   :: chmax (0:levdim)
!
!     Maximum extension of bounding box of each coordinate cell.
!
      Double Precision, Intent (Out)   :: midp  (0:levdim)
!
!     Mid point of bounding box of each coordinate cell.
!
      Integer, Intent (Out)            :: ierror

!     Returns the error code of PSMILe_MG_First_subgrid_1d_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
!
! !DESCRIPTION:
!
! Subroutine "PSMILe_MG_First_subgrid_1d_dble" computes the bounding
! boxes and the mid point for the corner coordinates ("control volumes")
! for a 1-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_1d_dble.F90 2959 2011-02-16 13:28:28Z hanke $
!  $Author: hanke $
!
   Character(len=len_cvs_string), save :: mycvs = 
       '$Id: psmile_mg_first_subgrid_1d_dble.F90 2959 2011-02-16 13:28:28Z hanke $'
!
!----------------------------------------------------------------------
!
#ifdef VERBOSE
      print 9990, trim(ch_id)

      call psmile_flushstd
#endif /* VERBOSE */
!
!  Initialization
!
      ierror = 0

!
      ibeg = range (1)
      iend = min (range(1)+levdim, range (2))
!
!     ... Compute minimum extension of grid cell
!
!cdir vector
      do i = ibeg, iend
         chmin (i-range(1)) = min (array (i, 1), array (i, 2))
      enddo
!
!     ... Compute maximum extension of grid cell
!
!cdir vector
      do i = ibeg, iend
         chmax (i-range(1)) = max (array (i, 1), array (i, 2))
      enddo
!
!     TODO: Attaching grid cells which interfere at the cyclic 
!           boundary should be stored and searched in order to
!           improve the MG search.
!           Type (Cyclic_cell_information) cyclic_info
!           wieder hochholen !
!
!     ... Compute mid point of grid cell
!
!cdir vector
      do i = ibeg, iend
         midp (i-range(1))  = (array (i, 1) + array (i, 2)) * 0.5
      enddo
!
!     ... Create dummy cells if necessary
!
      if (iend < range(1)+levdim) then
         ibeg = ibeg - range(1)
         iend = iend - range(1)

         chmin (iend+1:levdim) = chmax (iend) * epsp1
         chmax (iend+1:levdim) = chmax (iend)
         midp  (iend+1:levdim) = midp  (iend)
      endif
!
!===> All done
!
#ifdef DEBUGX
      do i = range(1), range(2)
         print *, 'i, array', i, array(i,1), array(i,2)
      end do
!
      do i = 0, levdim
         print *, 'i, chmin, chmax', i, chmin(i), chmax(i)
      end do
#endif

#ifdef VERBOSE
!     print *, 'chmin', chmin(0), chmin (levdim)
!     print *, 'chmax', chmax(0), chmax (levdim)
!     print *, 'midp ', midp (0), midp  (levdim)

      print 9980, trim(ch_id), ierror

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