psmile_set_mask.F90

Go to the documentation of this file.

!-----------------------------------------------------------------------
! Copyright 2007-2010, CERFACS, Toulouse, France.
! Copyright 2007-2010, SGI Germany, Munich, Germany.
! Copyright 2007-2010, NEC Europe Ltd., London, UK.
! All rights reserved. Use is subject to OASIS4 license terms.
!-----------------------------------------------------------------------
!BOP
!
! !ROUTINE: psmile_set_mask
!
! !INTERFACE:

      subroutine psmile_set_mask ( mask_id, grid_id, mask_actual_shape, &
                                           mask_array, new_mask, ierror )
!
! !USES:
!
      use PRISM
      use PSMILe, dummy => psmile_set_mask

      implicit none
!
! !INPUT PARAMETERS:
!
      integer, Intent (In)                :: grid_id

!     Returned handle from prism_def_grid to the grid information

      logical, Intent (In)                :: mask_array (*)

!     Array containg the mask data

      integer, Intent (In)                :: mask_actual_shape (1:2, *)

!     Specifies the shape for the "n_dim"-dimensional mask
!     (including halo/overlap regions) with

!     mask_actual_shape (1,     1) = Lowest  first   dimension of mask
!     mask_actual_shape (2,     1) = Highest first   dimension of mask
!     mask_actual_shape (1,     2) = Lowest  second  dimension of mask
!     mask_actual_shape (2,     2) = Highest second  dimension of mask
!        ...
!     mask_actual_shape (1,     i) = Lowest  i-th    dimension of mask
!     mask_actual_shape (2,     i) = Highest i-th    dimension of mask
!     mask_actual_shape (1, n_dim) = Lowest  n_dim-th dimension of mask
!     mask_actual_shape (2, n_dim) = Highest n_dim-th dimension of mask

!     where n_dim corresponds to value of input parameter of n_dim
!     of corresponding subroutine call prism_def_grid.

      logical, Intent (In)                :: new_mask

!     indicator whether a new mask_id was requested (.true.) or whether an
!     old mask is going to be redefined (.false.)
!
! !INPUT/OUTPUT PARAMETERS:
!
      integer, Intent (InOut)             :: mask_id

!     Returns the handle to the mask information if "new_mask = .true."
!     is passed, otherwise, "mask_id" specifies the handle to the mask data
!     to be changed.
!
! !OUTPUT PARAMETERS:
!
      integer, Intent (Out)               :: ierror

!     Returns the error code of psmile_set_mask;
!             ierror = 0 : No error
!             ierror > 0 : Severe error
!
! !LOCAL VARIABLES
!
      integer                      :: mask_shape (1:2, ndim_3d)

      integer(kind=int64)          :: len_alloc
      integer                      :: i, n_dim
!
      integer, parameter           :: nerrp = 2
      integer                      :: ierrp (nerrp)
!
! !DESCRIPTION:
!
!  This routine defines a mask. The indivudual masks will be attached
!  to a variable and a particular set of points in the call to
!  prism_def_var via by using the mask_id.
!
!
! !REVISION HISTORY:
!   Date      Programmer   Description
! ----------  ----------   -----------
! 01.12.03    H. Ritzdorf  created
!
!EOP
!----------------------------------------------------------------------
!
! $Id: psmile_set_mask.F90 2981 2011-02-24 09:44:15Z hanke $
! $Author: hanke $
!
  Character(len=len_cvs_string), save :: mycvs = 
      '$Id: psmile_set_mask.F90 2981 2011-02-24 09:44:15Z hanke $'
!
!----------------------------------------------------------------------

#ifdef VERBOSE
      print *, trim(ch_id), ': psmile_set_mask: mask_id', ' new_mask ', new_mask

      call psmile_flushstd
#endif /* VERBOSE */

!
!  Initialization
!
      ierror = 0
!
!  Control input arguments
!
      if ( .not. new_mask ) then
!
         if (mask_id < 1 .or. &
             mask_id > Number_of_Masks_allocated ) then
            ierrp (1) = mask_id
            ierrp (2) = Number_of_Masks_allocated

            ierror = PRISM_Error_Arg

            call psmile_error ( ierror, 'mask_id', &
                                ierrp, 2, __FILE__, __LINE__ )
            return
         endif
!
         if (Masks(mask_id)%mask_type == PSMILe_VectorMask) then
            ierrp (1) = mask_id

            ierror = PRISM_Error_Arg

            call psmile_error ( PRISM_Error_Arg, 'Use prism_set_vectormask for this mask_id', &
                                ierrp, 1, __FILE__, __LINE__ )
            return
         endif
!
         if (Masks(mask_id)%status == PSMILe_status_free) then
            ierrp (1) = mask_id

            ierror = PRISM_Error_Arg

            call psmile_error ( PRISM_Error_Arg, 'mask_id (not active)', &
                                ierrp, 1, __FILE__, __LINE__ )
            return
         endif

#ifdef VERBOSE
         print *, trim(ch_id), ': psmile_set_mask: overwriting old mask for mask_id ', &
                              mask_id
         call psmile_flushstd
#endif /* VERBOSE */

      endif
!
      if (Grids(grid_id)%grid_structure == PSMILe_Grid_Block) then

         n_dim = Grids(grid_id)%n_dim

         if ( Grids(grid_id)%grid_type == PRISM_Gaussreduced_regvrt ) then
           mask_shape(1:2,1) = mask_actual_shape(1:2,1)
           mask_shape(1:2,2) = 1
           mask_shape(1:2,3) = mask_actual_shape(1:2,2)
         else
           do i = 1, n_dim
              mask_shape(1:2,i) = mask_actual_shape(1:2,i)
           enddo
           do i = n_dim+1, ndim_3d
              mask_shape(1:2,i) = 1
           enddo
         endif
!
         do i = 1, n_dim

            if (mask_shape(1,i) .gt. Grids(grid_id)%grid_shape(1,i) .or. &
                mask_shape(2,i) .lt. Grids(grid_id)%grid_shape(2,i)) exit
         enddo

         if (i <= n_dim) then

             ierror = PRISM_Error_Arglist

             call psmile_error ( PRISM_Error_Arg, 'mask_actual_shape', &
                                 mask_actual_shape, n_dim*2, &
                                 __FILE__, __LINE__ )
             return
         endif

      else
!
!  3-dimensional mask for an invalid grid type
!
         ierrp (1) = grid_id

         ierror = PRISM_Error_Arg

         call psmile_error ( PRISM_Error_Arg, 'grid_id (not for a 3-dimensional mask)', &
                             ierrp, 1, __FILE__, __LINE__ )
         return
      endif
!
!  Store Mask data
!
      if (new_mask) then

#ifdef VERBOSE
         print *, trim(ch_id), ': psmile_set_mask: getting new mask_id'
         call psmile_flushstd
#endif /* VERBOSE */

         call psmile_get_mask_handle (mask_id, ierror)
         if (ierror > 0) return

      else if (Associated(Masks(mask_id)%mask_array)) then

         Deallocate (Masks(mask_id)%mask_array, STAT = ierror)

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

      endif
!
!  Get size of mask_array
!
      len_alloc = 1
      do i = 1, n_dim
         len_alloc = len_alloc * (mask_shape(2,i) - mask_shape(1,i)+1)
      enddo
!
!  Allocate
!
      Allocate (Masks(mask_id)%mask_array(1:len_alloc), STAT = ierror)

      if ( ierror > 0 ) then
         ierrp (1) = ierror
         ierrp (2) = len_alloc

         ierror = PRISM_Error_Alloc
         call psmile_error ( ierror, 'mask_array', &
                             ierrp, 2, __FILE__, __LINE__ )
         return
      endif
!
!     Copy data to internal mask_array
!
      Masks(mask_id)%mask_array(1:len_alloc) = mask_array (1:len_alloc)
!
!     Save or initialize Type elements
!
      Masks(mask_id)%mask_shape              = 1
      Masks(mask_id)%mask_shape(1:2,1:n_dim) = mask_shape(1:2,1:n_dim)
      Masks(mask_id)%grid_id                 = grid_id
      Masks(mask_id)%mask_type               = PSMILe_PointMask
!
!     Mark status of mask as changed
!
      Masks(mask_id)%status = PSMILe_status_defined

#ifdef VERBOSE
      print *, trim(ch_id), ': psmile_set_mask: eof ierror, mask_id =', ierror, mask_id

      call psmile_flushstd
#endif /* VERBOSE */
!
      end subroutine psmile_set_mask