psmile_is_mask_defined.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_is_mask_defined
!
! !INTERFACE:

      subroutine psmile_is_mask_defined (mask_array, mask_shape, &
                                         inter, nparts,    &
                                         defined, ierror)
!
! !USES:
!
      use PRISM_constants
!
      use PSMILe, dummy_interface => PSMILe_is_mask_defined

      implicit none
!
! !INPUT PARAMETERS:
!
      Integer, Intent (In)               :: mask_shape (2, ndim_3d)
!
!     Dimensions of mask array "mask_array"
!
      Logical, Intent (In)               :: mask_array (                     
                                            mask_shape(1,1):mask_shape(2,1), 
                                            mask_shape(1,2):mask_shape(2,2), 
                                            mask_shape(1,3):mask_shape(2,3))
!
!     Mask 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:
!
      Integer, Intent (Out)             :: defined

!     Returns the status of mask evaluation with
!     defined = 0 : all  mask values are false
!     defined = 1 : some mask values are false
!     defined = 2 : all  mask values are true
!
      Integer, Intent (Out)             :: ierror

!     Returns the error code of PSMILe_is_mask_defined;
!             ierror = 0 : No error
!             ierror > 0 : Severe error
!
! !LOCAL VARIABLES
!
      Integer                      :: ipart, n
!
      Integer                      :: num (nparts)

!  ... for error parameters

!     Integer, Parameter           :: nerrp = 3
!     Integer                      :: ierrp (nerrp)
!
! !DESCRIPTION:
!
! Subroutine "PSMILe_is_mask_defined" controls whether the status of
! the mask values of "mask_array" in the regions "inter (:, :, 1:nparts)"
! which are to be controlled.
!
! !REVISION HISTORY:
!
!   Date      Programmer   Description
! ----------  ----------   -----------
! 08.02.05    H. Ritzdorf  created
!
!EOP
!----------------------------------------------------------------------
!
! $Id: psmile_is_mask_defined.F90 2325 2010-04-21 15:00:07Z valcke $
! $Author: valcke $
!
   Character(len=len_cvs_string), save :: mycvs = 
       '$Id: psmile_is_mask_defined.F90 2325 2010-04-21 15:00:07Z valcke $'
!
!----------------------------------------------------------------------
!
#ifdef VERBOSE
      print 9990, trim(ch_id)

      call psmile_flushstd
#endif /* VERBOSE */
!
!  Initialization
!
      ierror = 0
!
         do ipart = 1, nparts
         num (ipart) = (inter(2,1,ipart)-inter(1,1,ipart)+1)* &
                       (inter(2,2,ipart)-inter(1,2,ipart)+1)* &
                       (inter(2,3,ipart)-inter(1,3,ipart)+1)
         end do
!
!  Control mask values
!
      defined = 0 ! all masks are false
!
         do ipart = 1, nparts
         n = count ( mask_array(inter(1,1,ipart):inter(2,1,ipart), &
                                inter(1,2,ipart):inter(2,2,ipart), &
                                inter(1,3,ipart):inter(2,3,ipart)) )
         if (n == 0) then
            if (defined /= 0) then
               defined = 1
               exit
            endif
!
         else if (n == num(ipart)) then
            if (defined /= 2) then
               if (ipart > 1) exit
               defined = 2
            endif
!
         else
            defined = 1
            exit
         endif
         end do
!
!===> All done
!
#ifdef VERBOSE
      print 9980, trim(ch_id), ierror, defined
      call psmile_flushstd
#endif /* VERBOSE */

!
!  Formats:
!

#ifdef VERBOSE

9990 format (1x, a, ': psmile_is_mask_defined:')
9980 format (1x, a, ': psmile_is_mask_defined: eof ierror =', i3, &
                    '; defined =', i2)

#endif /* VERBOSE */ 

      end subroutine PSMILe_is_mask_defined