psmile_get_mask_handle.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_Get_Mask_Handle
!
! !INTERFACE:

      subroutine psmile_get_mask_handle (maskId, ierror)

!
! !USES:
!
      use PRISM_constants
      use PSMILe, dummy_interface => PSMILe_Get_mask_handle
      implicit none
!
! !OUTPUT PARAMETERS:
!
      integer,Intent(Out) :: maskId

!     Handle to the mask information created.

      integer, Intent (Out)               :: ierror

!     Returns the error code of PSMILe_Get_Mask_Handle;
!             ierror = 0 : No error
!             ierror > 0 : Severe error
!
!
! !LOCAL VARIABLES
!
      integer             :: i, new_dim

      integer, parameter  :: nerrp = 2
      integer             :: ierrp (nerrp)

      type (Mask), Dimension(:), Pointer :: New_Masks
!
!
! !DESCRIPTION:
!
!  Subroutine "PSMILe_Get_mask_handle" returns a mask handle.
!
!
! !REVISION HISTORY:
!
!   Date      Programmer   Description
! ----------  ----------   -----------
! 01.12.03    R. Redler    created
!
!EOP
!----------------------------------------------------------------------
!
!  $Id: psmile_get_mask_handle.F90 2325 2010-04-21 15:00:07Z valcke $
!  $Autor$
!
   Character(len=len_cvs_string), save :: mycvs = 
       '$Id: psmile_get_mask_handle.F90 2325 2010-04-21 15:00:07Z valcke $'
!
!----------------------------------------------------------------------
!
!   Initialization
!
      ierror = 0
!
!   Search for a free mask index
!
      do i = 1, Number_of_Masks_allocated
         if (Masks(i)%status == PSMILe_status_free) exit
      end do
!
      if (i <= Number_of_Masks_allocated) then
         maskId = i
         Masks(maskId)%status = PSMILe_status_defined
         return
      endif
!
!   Allocate new Masks vector and copy old vector
!
      new_dim = Number_of_Masks_allocated + 8
!
      Allocate (New_Masks (new_dim), STAT = ierror)
      if (ierror > 0) then
         ierrp (1) = ierror
         ierrp (2) = new_dim
         call psmile_error ( PRISM_Error_Alloc, 'New_Masks', &
                             ierrp, 2, __FILE__, __LINE__ )
         return
      endif

      New_Masks(Number_of_Masks_allocated+1:new_dim)%status = &
         PSMILe_status_free
!
      do i = Number_of_Masks_allocated+1, new_dim
        Nullify ( New_Masks(i)%mask_array )
      enddo
!
      if (Number_of_Masks_allocated > 0) then
         New_Masks (1:Number_of_Masks_allocated) = &
             Masks (1:Number_of_Masks_allocated)
!
!   De-allocate Masks vector
!
         Deallocate (Masks, STAT = ierror)
         if (ierror > 0) then
            ierrp (1) = ierror
            call psmile_error ( PRISM_Error_Dealloc, 'Masks', &
                                ierrp, 1, __FILE__, __LINE__ )
            return
         endif
      endif
!
!   Update Number of Masks
!
      Masks => New_Masks
!
      maskId = Number_of_Masks_allocated + 1
      Number_of_Masks_allocated = new_dim
!
      Masks(maskId)%status = PSMILe_status_defined
!
      end subroutine PSMILe_Get_Mask_handle