prismdrv_finalize_smioc_struct.F90

Go to the documentation of this file.

!------------------------------------------------------------------------
! Copyright 2006-2010, CERFACS, Toulouse, France.
! All rights reserved. Use is subject to OASIS4 license terms.
!-----------------------------------------------------------------------
!BOP
!
! !ROUTINE: PRISMDrv_Finalize_smioc_struct
!
! !INTERFACE
subroutine prismdrv_finalize_smioc_struct(id_error)

!
! !USES:
!
  USE PSMILe_smioc
  USE PRISMDrv, dummy_interface => PRISMDrv_Finalize_smioc_struct
!
  IMPLICIT NONE

!
! !PARAMETERS:
!

!
! ! RETURN VALUE
!
  INTEGER, INTENT (Out)               :: id_error   ! error value

! !DESCRIPTION
! Subroutine "PRISMDrv_finalize_smioc_struct" finalizeialize and set the driver
! smioc structures using the smioc api.
!
! !REVISED HISTORY
!   Date      Programmer   Description
! ----------  ----------   -----------
! 13/10/2003  S. Valcke     Creation
! 30/12/2003  D. Declat     Included in the driver
!
! EOP
!----------------------------------------------------------------------
! $Id: prismdrv_finalize_smioc_struct.F90 2399 2010-06-21 08:09:39Z coquart $
! $Author: coquart $
!----------------------------------------------------------------------
!
! 0. Local declarations
!
  CHARACTER(LEN=80), SAVE  :: mycvs = 
     '$Id'
!
  INTEGER, PARAMETER :: nerrp = 1
  INTEGER :: ierrp(nerrp)
  INTEGER :: id_err
  INTEGER :: ib_ntt
!
!----------------------------------------------------------------------
!----------------------------------------------------------------------
!
!
#ifdef VERBOSE
  PRINT *, '| | Enter PRISMDrv_finalize_smioc_struct'
  call psmile_flushstd
#endif
  id_error = 0
  id_err   = 0
!
! 1. Deallocation of global arrays
!
  DEALLOCATE(iga_comp_id_doc_XML, stat = id_err)
  DEALLOCATE(iga_comp_nb_grids, stat = id_err)
  DEALLOCATE(iga_comp_nb_transi, stat = id_err)
  DEALLOCATE(iga_comp_nb_persis, stat = id_err)
  DEALLOCATE(iga_comp_nb_unitsets, stat = id_err)
  DEALLOCATE(iga_smioc_unitsets, stat = id_err)
  DEALLOCATE(sga_smioc_grids, stat = id_err)
  DEALLOCATE(sga_smioc_transi, stat = id_err)
  DEALLOCATE(sga_smioc_persis, stat = id_err)
  DEALLOCATE(iga_comp_nb_stand_name, stat = id_err)
  DEALLOCATE(iga_comp_nb_transi_in, stat = id_err)
  DEALLOCATE(iga_comp_nb_transi_out, stat = id_err)
!
  DO ib_ntt = 1, ig_nb_tot_xml_transi
    DEALLOCATE (sga_xml_smioc_transi(ib_ntt)%sg_transi_in%sga_in_orig, stat=id_err)
    IF (id_err > 0) THEN
        ierrp (1) = id_err
        id_err = 14
        CALL Psmile_Error_Common ( id_err, 'sga_in_orig', &
           ierrp, 2, __FILE__, __LINE__ )
        RETURN
    ENDIF
    DEALLOCATE (sga_xml_smioc_transi(ib_ntt)%sga_transi_out, stat=id_err)
    IF (id_err > 0) THEN
        ierrp (1) = id_err
        id_err = 14
        CALL Psmile_Error_Common ( id_err, 'sga_transi_out', &
           ierrp, 2, __FILE__, __LINE__ )
        RETURN
    ENDIF
    DEALLOCATE (sga_xml_smioc_transi(ib_ntt)%cga_stand_name, stat=id_err)
    IF (id_err > 0) THEN
        ierrp (1) = id_err
        id_err = 14
        CALL Psmile_Error_Common ( id_err, 'cga_stand_name', &
           ierrp, 2, __FILE__, __LINE__ )
        RETURN
    ENDIF
  ENDDO
!  9.2.   Deallocate global structure for transients, used for this first pass
  DEALLOCATE ( sga_xml_smioc_transi, stat=id_err)
    IF (id_err > 0) THEN
        ierrp (1) = id_err
        id_err = 14
        CALL Psmile_Error_Common ( id_err, 'sga_xml_smioc_transi', &
           ierrp, 2, __FILE__, __LINE__ )
        RETURN
    ENDIF
!  9.3.   Deallocate counters (per component)
    DEALLOCATE ( iga_xml_comp_nb_transi, stat=id_err)
    IF (id_err > 0) THEN
        ierrp (1) = id_err
        id_err = 14
        CALL Psmile_Error_Common ( id_err, 'iga_xml_comp_nb_transi', &
           ierrp, 2, __FILE__, __LINE__ )
        RETURN
     ENDIF

  IF (id_err > 0) THEN
      ierrp (1) = id_err

      call psmile_error_common ( 14 , 'Global arrays', &
         ierrp, 1, __FILE__, __LINE__ )
  ENDIF

  id_error = id_err

!
#ifdef VERBOSE
  PRINT *, '| | Quit PRISMDrv_finalize_smioc_struct'
  PRINT *, '| |'
  call psmile_flushstd
#endif
end subroutine prismdrv_finalize_smioc_struct