psmile_get_grid_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_grid_handle
!
! !INTERFACE:

      subroutine psmile_get_grid_handle (grid_id, ierror)
!
! !USES:
!
      use PRISM_constants
      use PSMILe, dummy_interface => PSMILe_Get_grid_handle

      implicit none
!
! !OUTPUT PARAMETERS:
!
      integer, Intent (Out)               :: grid_id

!     Returns the handle to the grid information created.

      integer, Intent (Out)               :: ierror

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

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

      type (Grid), Dimension(:), Pointer :: New_Grids
!
!
! !DESCRIPTION:
!
! Subroutine "PSMILe_Get_grid_handle" returns a grid handle.
!
!
! !REVISION HISTORY:
!
!   Date      Programmer    Description
! ----------  -----------   -----------
! 01.12.03    H. Ritzdorf   created
!
!EOP
!----------------------------------------------------------------------
!
! $Id: psmile_get_grid_handle.F90 3248 2011-06-23 13:03:19Z coquart $
! $Author: coquart $
!
   Character(len=len_cvs_string), save :: mycvs = 
       '$Id: psmile_get_grid_handle.F90 3248 2011-06-23 13:03:19Z coquart $'
!
!----------------------------------------------------------------------
!
!   Initialization
!
      ierror = 0
!
!   Search for a free grid index
!
         do i = 1, Number_of_Grids_allocated
         if (Grids(i)%status == PSMILe_status_free) exit
         end do
!
      if (i <= Number_of_Grids_allocated) then
         grid_id = i
         Grids(grid_id)%status = PSMILe_status_defined
         return
      endif
!
!   Allocate new Grids vector, initialize and copy old vector
!
      new_dim = Number_of_Grids_allocated + 8
!
      Allocate (New_Grids (new_dim), STAT = ierror)
      if (ierror > 0) then
         ierrp (1) = ierror
         ierrp (2) = new_dim
         ierror = PRISM_Error_Alloc

         call psmile_error ( ierror, 'New_Grids', &
                             ierrp, 2, __FILE__, __LINE__ )
         return
      endif
!
      New_Grids (1:Number_of_Grids_allocated) = &
          Grids (1:Number_of_Grids_allocated)

      New_Grids(Number_of_Grids_allocated+1:new_dim)%status = &
          PSMILe_status_free

      New_Grids(Number_of_Grids_allocated+1:new_dim)%nlev = 0

      do i = Number_of_Grids_allocated+1, new_dim
        New_Grids(i)%len_periodic (:) = 0
        New_Grids(i)%nbr_halo_segments = 0
      end do

      do i = Number_of_Grids_allocated+1, new_dim
         Nullify ( New_Grids(i)%corner_pointer )
         Nullify ( New_Grids(i)%partition )
         Nullify ( New_Grids(i)%extent )
         Nullify ( New_Grids(i)%mg_infos )
         Nullify ( New_Grids(i)%reduced_gauss_data%remote_index )
         Nullify ( New_Grids(i)%reduced_gauss_data%nbr_points_per_lat )
         Nullify ( New_Grids(i)%halo )
      enddo
!
!   De-allocate Grids vector
!
      Deallocate (Grids, STAT = ierror)
      if (ierror > 0) then
         ierrp (1) = ierror
         ierror = PRISM_Error_Dealloc

         call psmile_error ( ierror, 'Grids', &
                             ierrp, 1, __FILE__, __LINE__ )
         return
      endif
!
!   Update Number of Grids
!
      Grids => New_Grids
!
      grid_id = Number_of_Grids_allocated + 1
      Number_of_Grids_allocated = new_dim
!
      Grids(grid_id)%status = PSMILe_status_defined
!
      end subroutine PSMILe_Get_grid_handle