psmile_do_masks_match.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_do_masks_match
!
! !INTERFACE:

      subroutine psmile_do_masks_match (mask1_array, mask1_shape, &
                                        mask2_array, mask2_shape, &
                                        inter, nparts,            &
                                        match, ierror)
!
! !USES:
!
      use PRISM_constants
!
      use PSMILe, dummy_interface => PSMILe_do_masks_match

      implicit none
!
! !INPUT PARAMETERS:
!
      Integer, Intent (In)               :: mask1_shape (2, ndim_3d)
!
!     Dimensions of mask array "mask1_array"
!
      Logical, Intent (In)               :: mask1_array (                      
                                            mask1_shape(1,1):mask1_shape(2,1), 
                                            mask1_shape(1,2):mask1_shape(2,2), 
                                            mask1_shape(1,3):mask1_shape(2,3))
!
!     Mask array "mask1_array" to be controlled
!
      Integer, Intent (In)               :: mask2_shape (2, ndim_3d)
!
!     Dimensions of mask array "mask2_array"
!
      Logical, Intent (In)               :: mask2_array (                      
                                            mask2_shape(1,1):mask2_shape(2,1), 
                                            mask2_shape(1,2):mask2_shape(2,2), 
                                            mask2_shape(1,3):mask2_shape(2,3))
!
!     Mask array "mask2_array" to be controlled
!
      Integer, Intent (In)               :: nparts
!
!     Number of sub-regions to be controlled
!
      Integer, Intent (In)               :: inter (2, ndim_3d, nparts)

!     Sub-regions to be controlled
!
! !OUTPUT PARAMETERS:
!
      Logical, Intent (Out)             :: match

!     Returns the status of mask evaluation with
!     match = .true.:  Masks "mask1_array" and "mask2_array" have the same
!                      values in the controlled subregions "inter".
!     match = .false.: Masks "mask1_array" and "mask2_array" don't have the same
!                      values in the controlled subregions "inter".
!
      Integer, Intent (Out)             :: ierror

!     Returns the error code of PSMILe_do_masks_match;
!             ierror = 0 : No error
!             ierror > 0 : Severe error
!
! !LOCAL VARIABLES
!
      Integer                      :: i, ipart, j, k

!  ... for error parameters

!     Integer, Parameter           :: nerrp = 3
!     Integer                      :: ierrp (nerrp)
!
! !DESCRIPTION:
!
! Subroutine "PSMILe_do_masks_match" controls whether the masks
! "mask1_array" and "mask2_array" have the same values in the
! subregions "inter(:,:,1:nparts)" to be controlled.
!
! !REVISION HISTORY:
!
!   Date      Programmer   Description
! ----------  ----------   -----------
! 11.02.05    H. Ritzdorf  created
!
!EOP
!----------------------------------------------------------------------
!
! $Id: psmile_do_masks_match.F90 2325 2010-04-21 15:00:07Z valcke $
! $Author: valcke $
!
   Character(len=len_cvs_string), save :: mycvs = 
       '$Id: psmile_do_masks_match.F90 2325 2010-04-21 15:00:07Z valcke $'
!
!----------------------------------------------------------------------
!
#ifdef VERBOSE
      print 9990, trim(ch_id)

      call psmile_flushstd
#endif /* VERBOSE */
!
!  Initialization
!
      ierror = 0
!
!  Control mask values
!
parts:   do ipart = 1, nparts
!
         if (inter(2,1,ipart) > inter(1,1,ipart)) then
!
             do k = inter(1,3,ipart), inter(2,3,ipart)
                do j = inter(1,2,ipart), inter(2,2,ipart)
!cdir vector
                   do i = inter(1,1,ipart), inter(2,1,ipart)
                   if ( mask1_array (i,j,k) .neqv. mask2_array (i,j,k) ) exit parts
                   end do
                end do
             end do
!
         else if (inter(2,1,ipart) == inter(1,1,ipart)) then
!
!            Special case: only single point in I direction
!
             i = inter(1,1,ipart)
!
             do k = inter(1,3,ipart), inter(2,3,ipart)
                do j = inter(1,2,ipart), inter(2,2,ipart)
!cdir vector
                if ( mask1_array (i,j,k) .neqv. mask2_array (i,j,k) ) exit parts
                end do
             end do
         endif
!
         end do parts ! ipart
!
!     Does the mask arrays match in the regions to be controlled
!
      match = ipart > nparts
!
#ifdef VERBOSE
      if (.not. match) then
         print 9970, trim(ch_id), i,j,k, &
                     mask1_array(i,j,k), mask2_array (i,j,k)
      endif
#endif /* VERBOSE */
!
!===> All done
!
#ifdef VERBOSE
      print 9980, trim(ch_id), ierror, match
      call psmile_flushstd
#endif /* VERBOSE */

!
!  Formats:
!

#ifdef VERBOSE

9990  format (1x, a, ': psmile_do_masks_match:')
9980  format (1x, a, ': psmile_do_masks_match: eof ierror =', i3, &
                     '; match =', l2)

9970  format (1x, a, ": psmile_do_masks_match: mask values don't match ", &
                     "in index (", i4, ',', i4, ',', i4, ") !", &
             /1x, 'local value', l2, ', remote value', l2)

#endif /* VERBOSE */ 

      end subroutine PSMILe_do_masks_match