psmile_unfolded_check_real.F90

Go to the documentation of this file.

!-----------------------------------------------------------------------
! Copyright 2011, Max Planck Institute for Meteorology, Hamburg
! All rights reserved. Use is subject to OASIS4 license terms.
!-----------------------------------------------------------------------
!BOP
!
! !ROUTINE: PSMILe_unfolded_check_real
!
! !INTERFACE:
!
subroutine psmile_unfolded_check_real( tgt_cell_index,  &   !< (in)
                                       unfolded_check,  &   !< (in)
                                       grid_type,       &   !< (in)
                                       visited,         &   !< (inout) 
                                       nbr_tgt_corners, &   !< (in) 
                                       tgt_corners,     &   !< (in) 
                                       grid_shape,      &   !< (in) 
                                       corner_shape_3d, &   !< (in) 
                                       nbr_src_corners, &   !< (in) 
                                       src_corner_x,    &   !< (in) 
                                       src_corner_y,    &   !< (in)
                                       stacksize,       &   !< (in) 
                                       stack,           &   !< (inout)
                                       stack_index,     &   !< (inout)
                                       ierror )             !< (out) return error
!
! !USES:
!
   use PRISM_constants
!
   use PSMILe ! , dummy_interface => PSMILe_unfolded_check_real

   implicit none
!
! !INPUT PARAMETERS:
!
   Integer, Intent (In)            :: tgt_cell_index
!
!  Index of the target cell in the list of cells treated
!
   Integer, Intent (In)            :: unfolded_check
!
!  0 if nothing is to be done
!  1 if cells at grid_shape(1,2) have to be checked 
!  2 if cells at grid_shape(2,2) have to be checked 
!
   Integer, Intent (In)            :: grid_type
!
!     PRISM grid type
!
   Integer, Intent (In)            :: grid_shape(2,ndim_3d)
!
!     Source grid valid shape
!
   Integer, Intent (InOut)         :: visited(grid_shape(1,1):grid_shape(2,1), 
                                              grid_shape(1,2):grid_shape(2,2))
!
!     Marker for visited cells. If set to tgt_cell_index src cell was visited
!     for this particular target cell.
!
   Integer, Intent (In)            :: nbr_tgt_corners
!    
!     Does the block have cyclic coordinates in the corresponding direction ?
!
   Type(line_real), Intent (In)    :: tgt_corners(nbr_tgt_corners)
!
!     Shape of local corners -> corner_x, corner_y
!
   Integer, Intent (In)            :: nbr_src_corners
!
!     Number of corners of local corners corner_x, corner_y, corner_z
!
   Integer, Intent (In)            :: corner_shape_3d(2,ndim_3d,ndim_3d)
!
!     Source corner actual shape
!
    Real, Intent (In)              :: src_corner_x (corner_shape_3d (1,1,1):corner_shape_3d(2,1,1), 
                                                    corner_shape_3d (1,2,1):corner_shape_3d(2,2,1), 
                                                    corner_shape_3d (1,3,1):corner_shape_3d(2,3,1), 
                                                    nbr_src_corners )
!
!     Source corner longitudes
!
   Real, Intent (In)               :: src_corner_y (corner_shape_3d (1,1,2):corner_shape_3d(2,1,2), 
                                                    corner_shape_3d (1,2,2):corner_shape_3d(2,2,2), 
                                                    corner_shape_3d (1,3,2):corner_shape_3d(2,3,2), 
                                                    nbr_src_corners )
!
!     Source corner latiitudes
!
   Integer, Intent (In)            :: stacksize
!
!     size of stack pointer array
!
   Type(memo), Intent (InOut)      :: stack(stacksize)
!
!     Temorary storage for search results
!
   Integer, Intent (InOut)         :: stack_index
!
!     Current index of stack
!
!
! !OUTPUT PARAMETERS:
!
   Integer, Intent (Out)           :: ierror

!     Returns the error code of PSMILE_unfolded_check_real;
!             ierror = 0 : No error
!             ierror > 0 : Severe error
!
! !DEFINED PARAMETERS:
!
!
! !LOCAL VARIABLES
!
!     ... for local cell search
!
   Type (line_real), Allocatable   :: src(:)

   Logical                         :: overlap
   Integer                         :: j1, j2
   Integer                         :: ii, jj
!
!     ... for error handling
!
   Integer, Parameter              :: nerrp = 2
   Integer                         :: ierrp (nerrp)
!
! !DESCRIPTION:
!
! Subroutine "PSMILe_unfolded_check_real" searches the cells on the donor
! grid along an unfolded boundary for additional source cell which are
! disconnected from the original start source location.
!
! !REVISION HISTORY:
!
!   Date      Programmer   Description
! ----------  ----------   -----------
! 11.03.11    R. Redler    created
!
!EOP
!----------------------------------------------------------------------
!
!  $Id$
!  $Author$
!
   Character(len=len_cvs_string), save :: mycvs = 
       '$Id$'
!
!----------------------------------------------------------------------
!
!===> Prologue
!
#ifdef VERBOSE
   print 9990, trim(ch_id)

   call psmile_flushstd
#endif /* VERBOSE */

   ierror = 0

   jj = grid_shape(unfolded_check,2)

   allocate(src(nbr_src_corners), STAT=ierror)

   if ( ierror > 0 ) then
      ierrp (1) = ierror
      ierrp (2) = 8
      ierror = PRISM_Error_Alloc
      call psmile_error ( ierror, 'src struct', &
           ierrp, 2, __FILE__, __LINE__ )
      return
   endif

   do ii = grid_shape(1,1), grid_shape(2,1)

      if ( visited(ii,jj) == tgt_cell_index ) cycle

      Select Case ( grid_type ) 

      Case ( PRISM_Irrlonlat_regvrt )

         do j1 = 1, nbr_src_corners
            j2 = mod(j1,nbr_tgt_corners)+1
            src(j1)%p1%x = src_corner_x(ii,jj,1,j1)
            src(j1)%p1%y = src_corner_y(ii,jj,1,j1)
            src(j1)%p2%x = src_corner_x(ii,jj,1,j2)
            src(j1)%p2%y = src_corner_y(ii,jj,1,j2)
         enddo

      Case ( PRISM_Reglonlatvrt )

         do j1 = 1, nbr_src_corners
            j2 = mod(j1,nbr_tgt_corners)+1
            src(j1)%p1%x = src_corner_x(ii, 1,1,j1)
            src(j1)%p1%y = src_corner_y( 1,jj,1,j1)
            src(j1)%p2%x = src_corner_x(ii, 1,1,j2)
            src(j1)%p2%y = src_corner_y( 1,jj,1,j2)
         enddo

      Case Default

         ierrp (1) = grid_type
         ierror = PRISM_Error_Internal

         call psmile_error ( ierror, 'unsupported grid generation type', &
             ierrp, 1, __FILE__, __LINE__ )

      End Select

      call psmile_overlap_real ( nbr_src_corners, nbr_tgt_corners, src, tgt_corners, overlap )

      visited(ii,jj) = tgt_cell_index

      stack_index            = 1
      stack(stack_index)%dir = 0

      stack(stack_index)%overlap = overlap

      if ( .not. overlap ) then

         cycle

      else

         stack(stack_index)%i = ii
         stack(stack_index)%j = jj

         exit

      endif

   enddo

   if ( ii > grid_shape(2,1) ) then
      ! nothing found
      stack_index = 0
   endif

   deallocate(src, STAT=ierror)

   if ( ierror > 0 ) then
      ierrp (1) = ierror
      ierrp (2) = 8
      ierror = PRISM_Error_Dealloc
      call psmile_error ( ierror, 'src struct', &
           ierrp, 2, __FILE__, __LINE__ )
      return
   endif

#ifdef VERBOSE
   print 9980, trim(ch_id)

   call psmile_flushstd
#endif /* VERBOSE */
   !
   !  Formats:
   !
9990 format (1x, a, ': psmile_unfolded_check_real')
9980 format (1x, a, ': psmile_unfolded_check_real: eof')

end subroutine psmile_unfolded_check_real