prismtrs_get_epio_handle.F90

Go to the documentation of this file.

!-----------------------------------------------------------------------
! Copyright 2006-2010, CERFACS, Toulouse, France.
! Copyright 2006-2010, NEC High Performance Computing, Duesseldorf, Germany.
! All rights reserved. Use is subject to OASIS4 license terms.
!-----------------------------------------------------------------------
!BOP
!
! !ROUTINE: PRISMTrs_get_epio_handle
!
! !INTERFACE:

subroutine prismtrs_get_epio_handle (id_epio_id,               &
                                     id_err)
!
! !USES:
!
  USE PRISMDrv, dummy_interface => PRISMTrs_get_epio_handle

  IMPLICIT NONE
!
! !PARAMETERS:
!
! ! RETURN VALUE
!
!     Returns the handle to the grid information created.
  INTEGER, INTENT (Out)               :: id_epio_id

!     Returns the error code of Prismtrs_get_epio_handle;
!             id_err = 0 : No error
!             id_err > 0 : Severe error
  INTEGER, INTENT (Out)               :: id_err

!
! !LOCAL VARIABLES
!
  INTEGER             :: ib, il_new_dim

  INTEGER, PARAMETER  :: nerrp = 2
  INTEGER             :: ierrp (nerrp)

  TYPE (Drv_Epio), DIMENSION(:), POINTER :: NewDrv_Epios
!
!
! !DESCRIPTION:
!
! Subroutine "PRISMTrs_get_epio_handle" returns a epio handle.
!
!
! !REVISION HISTORY:
!
!   Date      Programmer    Description
! ----------  -----------   -----------
! 17/11/2003  D. Declat     created from psmile_get_grid_handle
!
!EOP
!----------------------------------------------------------------------
!
! $Id: prismtrs_get_epio_handle.F90 2325 2010-04-21 15:00:07Z valcke $
! $Author: valcke $
!
  Character(len=len_cvs_string), save :: mycvs = 
     '$Id: prismtrs_get_epio_handle.F90 2325 2010-04-21 15:00:07Z valcke $'
!
!----------------------------------------------------------------------
!
#ifdef VERBOSE
  PRINT *, '| Enter PRISMTrs_get_epio_handle'
  call psmile_flushstd
#endif
!   Initialization
!
  id_err = 0
!
!   If new Epio, Search for a free epio index
!
  DO ib = 1, Number_of_Epios_allocated
    IF (Drv_Epios(ib)%status == PSMILe_status_free) EXIT
  END DO
!
  IF (ib <= Number_of_Epios_allocated) THEN
      id_epio_id = ib
      Drv_Epios(id_epio_id)%status = PSMILe_status_defined
#ifdef VERBOSE
      PRINT *, '| Quit PRISMTrs_get_epio_handle - no reallocation'
      call psmile_flushstd
#endif      
      RETURN
  ENDIF
!
!   Allocate new Epios vector and copy old vector
!
  il_new_dim = Number_of_Epios_allocated + 8
!
  ALLOCATE (NewDrv_Epios (il_new_dim), STAT = id_err)
  IF (id_err > 0) THEN
      ierrp (1) = id_err
      ierrp (2) = il_new_dim
      id_err = PRISM_Error_Alloc

      call psmile_error_common ( id_err, 'NewEPIOs', &
         ierrp, 2, __FILE__, __LINE__ )
      RETURN
  ENDIF
!
  IF (Number_of_Epios_allocated > 0) &
     NewDrv_Epios (1:Number_of_Epios_allocated) = &
        Drv_Epios (1:Number_of_Epios_allocated)

  NewDrv_Epios(Number_of_Epios_allocated+1:il_new_dim)%status = &
     PSMILe_status_free
!
!   De-allocate Drv_Epios vector
!
  IF (Number_of_Epios_allocated > 0) THEN
      DEALLOCATE (Drv_Epios, STAT = id_err)
      IF (id_err > 0) THEN
          ierrp (1) = id_err
          id_err = PRISM_Error_Dealloc

          call psmile_error_common ( id_err, 'EPIOs', &
             ierrp, 1, __FILE__, __LINE__ )
          RETURN
      ENDIF
  END IF
!
!   Update Number of Drv_Epios
!
  Drv_Epios => NewDrv_Epios
!
  id_epio_id = Number_of_Epios_allocated + 1
  Number_of_Epios_allocated = il_new_dim
!
  Drv_Epios(id_epio_id)%status = PSMILe_status_defined
!
#ifdef VERBOSE
      PRINT *, '| Quit PRISMTrs_get_epio_handle - reallocation done'
      call psmile_flushstd
#endif      
END SUBROUTINE PRISMTrs_get_epio_handle