psmile_mg_get_cyclic.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_get_cyclic
!
! !INTERFACE:

      subroutine psmile_mg_get_cyclic ( grid_id, range, tol, ierror)
!
! !USES:
!
      use PRISM_constants
!
      use PSMILe, dummy_interface => PSMILe_MG_get_cyclic

      implicit none
!
! !INPUT PARAMETERS:
!
      integer, Intent (In)                :: grid_id
!
!     Specifies the handle to the grid information.
!
      Integer, Intent (In)                :: range (2, ndim_3d)
!
!     Range for which MG sequence should be setup
! 
      Double precision, Intent (In)       :: tol
!
!     Search tolerance
!
! !OUTPUT PARAMETERS:
!
      integer, Intent (Out)               :: ierror
!
!     Returns the error code of PSMILe_MG_get_cyclic;
!             ierror = 0 : No error
!             ierror > 0 : Severe error
!
! !LOCAL VARIABLES
!
      Integer                             :: i
!
      Type(Grid), Pointer                 :: grid_info
!
!     ... for Gaussreduced Grids
!
      Integer                             :: nbr_lats
#if 0
      Type (Corner_Block), Pointer        :: corner_pointer
!
!     ... for error parameters
!
      integer, parameter                  :: nerrp = 1
      integer                             :: ierrp (nerrp)
#endif
!
! !DESCRIPTION:
!
! Subroutine "PSMILe_MG_get_cyclic" determines whether the
! directions of the block/grid are cyclic.
!
! !REVISION HISTORY:
!
!   Date      Programmer   Description
! ----------  ----------   -----------
! 03.06.25    H. Ritzdorf  created
!
!EOP
!----------------------------------------------------------------------
!
!  $Id: psmile_mg_get_cyclic.F90 2325 2010-04-21 15:00:07Z valcke $
!  $Autor$
!
   Character(len=len_cvs_string), save :: mycvs = 
       '$Id: psmile_mg_get_cyclic.F90 2325 2010-04-21 15:00:07Z valcke $'
!
!----------------------------------------------------------------------

#ifdef VERBOSE
      print 9990, trim(ch_id), grid_id

      call psmile_flushstd
#endif /* VERBOSE */
!
!  Initialization
!
! TODO: Does SMIOC info give any hint whether the grid has cyclic directions ?
!       ? What's to do for unstructured grids ?
!       range mit Grids(grid_id)%shape vergliechen
!       Wenn nicht gleich, raus
!
#if 1
      ierror = 0
      grid_info => Grids(grid_id)
!
      grid_info%cyclic = grid_info%periodic == PSMILE_true
!
      if (grid_info%grid_type /= PRISM_Gaussreduced_regvrt) then
         if (Associated (grid_info%partition)) then

!           Periodic partitined grid; Is this block cyclic ?

            do i = 1, ndim_3d
            grid_info%cyclic (i) = grid_info%cyclic (i) .and. &
                grid_info%len_periodic(i) ==                       &
                grid_info%grid_shape(2,i)-grid_info%grid_shape(1,i)+1
            end do
         else
! sollte man nicht doch controllieren
         endif
      else
!
!        Gauss Reduced Grid
!
         nbr_lats = size (grid_info%extent(:,1))
!
         if (grid_info%cyclic (1)) then
!           Periodic grid in lon direction; Is this block cyclic ?
!           nbr_points_per_lat (j) = Global number of points
!           extent(j, 1)           = Local number of points 
!           l2g        = Transformation from local  lat index "j"
!                                       into global lat index "jg"
!           l2g(j,1)   = Global j index jg of j-th parition
!           l2g(j,2)   = Next local j partition index with same global index jg
!                        -1 : end of list reached
!
!cdir vector
                do i = 1, nbr_lats
! TODO: There is an additioal case that this block has cyclic boundaries.
!       One partition in the beginning; another one at the end of 
!       global domain.
!
                if (grid_info%extent(i, 1) ==         &
                    grid_info%nbr_points_per_lat(grid_info%l2g(i,1)) ) exit
                end do
!
            grid_info%cyclic (1) = i <= nbr_lats
         endif
!
         if (grid_info%cyclic (2)) then
!           Periodic grid in lat direction; Is this block cyclic ?
            grid_info%cyclic (2) = nbr_lats == grid_info%nbr_latitudes
         endif
!
         if (grid_info%cyclic (3)) then
!           Periodic grid in z direction; Is this block cyclic ?
            grid_info%cyclic (3) = grid_info%len_periodic(3) ==           &
               grid_info%grid_shape(2,3)-grid_info%grid_shape(1,3)+1
         endif
!
      endif
#else
!
      Grids(grid_id)%cyclic = .false.
!
!     if (Associated (Grids(grid_id)%partition)) return
!
      corner_pointer => Grids(grid_id)%corner_pointer
!
      if (corner_pointer%corner_datatype == MPI_REAL) then

!        ... Real datatype

         call psmile_mg_get_cyclic_real ( grid_id, range, &
                                         real(tol), ierror)

      else if (corner_pointer%corner_datatype == MPI_DOUBLE_PRECISION) then

!        ... Double datatype

         call psmile_mg_get_cyclic_dble ( grid_id, range, &
                                         tol, ierror)

#if defined ( PRISM_QUAD_TYPE )
      else if (corner_pointer%corner_datatype == MPI_REAL16) then

!        ... Quadruple  datatype

         call psmile_mg_get_cyclic_quad ( grid_id, range, &
                                         real(tol, 16), ierror)
#endif

      else
!
!        Unknown data type
!
         ierrp (1) = corner_pointer%corner_datatype
         ierror = PRISM_Error_Internal
         call psmile_error ( ierror, 'unsupported data type', &
                             ierrp, 1, __FILE__, __LINE__ )
      endif
#endif
!
!===> All done
!
#ifdef VERBOSE
      print 9980, trim(ch_id), ierror, Grids(grid_id)%cyclic

      call psmile_flushstd
#endif /* VERBOSE */

!
!  Formats:
!

#ifdef VERBOSE

9990 format (1x, a, ': psmile_mg_get_cyclic: grid_id', i3)
9980 format (1x, a, ': psmile_mg_get_cyclic: eof ierror =', i3, '; cyclic:', 3l3)

#endif /* VERBOSE */

!
      end subroutine PSMILe_MG_get_cyclic