init_io_surf_fan.F90

Go to the documentation of this file.

!SFX_LIC Copyright 1994-2014 CNRS, Meteo-France and Universite Paul Sabatier
!SFX_LIC This is part of the SURFEX software governed by the CeCILL-C licence
!SFX_LIC version 1. See LICENSE, CeCILL-C_V1-en.txt and CeCILL-C_V1-fr.txt  
!SFX_LIC for details. version 1.
!     ######################
      SUBROUTINE init_io_surf_fa_n (DTCO, U, &
                                    HPROGRAM,HMASK,HACTION)
!     ######################
!
!!****  *INIT_IO_SURF_FA* Keep in memory the output files
!!
!!    PURPOSE
!!    -------
!
!!
!!**  IMPLICIT ARGUMENTS
!!    ------------------
!!      None 
!!
!!    REFERENCE
!!    ---------
!!
!!    AUTHOR
!!    ------
!!      V. Masson   *Meteo France*
!!
!!    MODIFICATIONS
!!    -------------
!!
!!      P. Le Moigne 04/2004: distinguish in and out file name
!!      P. Le Moigne 04/2006: special HACTION='GTMSK' to initialize
!!                            a mask different of 'FULL ' in order 
!!                            to read dimensions only.
!!      B. Decharme   2008  : Change to switch between offline and online run
!!                            In online run, the mask must be always global
!!      B. Decharme   2013  : Allocate work variables to write in FA in AROME case
!
!*       0.   DECLARATIONS
!             ------------
!
!
!
!
USE modd_data_cover_n, ONLY : data_cover_t
USE modd_surf_atm_n, ONLY : surf_atm_t
!
USE modd_surfex_mpi, ONLY : nrank, nindex, npio, nsize
!
USE modd_csts, ONLY : xpi
!
USE modd_io_surf_fa,ONLY: nunit_fa, cfilein_fa,cfileout_fa,cdnomc,iverbfa,  &
                          nluout,nfull,nfull_ext, cmask, lopen, cfile_fa,   &
                          ndgl, ndlon, ndlux, ndgux, perpk, pebeta,         &
                          pelon0, pelat0, pedelx, pedely, pelon1, pelat1 
!
!
USE modi_abor1_sfx
USE modi_get_luout
USE modi_read_surf
USE modi_get_dim_full_n
USE modi_get_size_full_n
USE modi_get_type_dim_n
USE modi_get_surf_mask_n
USE modi_get_1d_mask
!
USE yomhook   ,ONLY : lhook,   dr_hook
USE parkind1  ,ONLY : jprb
!
IMPLICIT NONE
!
!
TYPE(data_cover_t), INTENT(INOUT) :: DTCO
TYPE(surf_atm_t), INTENT(INOUT) :: U
!
 CHARACTER(LEN=6),  INTENT(IN)  :: HPROGRAM
 CHARACTER(LEN=6),  INTENT(IN)  :: HMASK    
 CHARACTER(LEN=5),  INTENT(IN)  :: HACTION    
!
INTEGER                        :: ILU, IRET, IL
!
INTEGER                :: INB ! number of articles in the file
INTEGER                :: ITYPTR, ITRONC, INLATI, INXLON, INIVER
INTEGER, DIMENSION (1000) :: INLOPA, INOZPA
!
REAL, DIMENSION (1000)  :: ZSINLA
REAL, DIMENSION (200)   :: ZAHYBR, ZBHYBR
REAL                    :: ZSLAPO, ZCLOPO, ZSLOPO, ZCODIL, ZREFER
LOGICAL                 :: LOUTFAC
!
REAL(KIND=JPRB) :: ZHOOK_HANDLE
!
!------------------------------------------------------------------------------
!
IF (lhook) CALL dr_hook('INIT_IO_SURF_FA_N',0,zhook_handle)
!
IF(hprogram/='FA    '.AND.hprogram/='AROME ') THEN
  CALL abor1_sfx('INIT_IO_SURF_FA_N -- HPROGRAM should be FA or AROME')
ENDIF
!
 CALL get_luout(hprogram,nluout)
!
nunit_fa = 19
!
lopen=.false.
!
IF (haction=='GTMSK') THEN
  IF (nrank==npio) THEN
    CALL faitou(iret,nunit_fa,.true.,cfilein_fa,'OLD',.true.,.false.,iverbfa,0,inb,cdnomc)
    WRITE(nluout,*)'HPROGRAM ',hprogram,' IO_INIT HACTION==GTMSK',nunit_fa,cfilein_fa
    lopen=.true.
  ENDIF
  cmask = hmask
  cfile_fa = cfilein_fa
  IF (lhook) CALL dr_hook('INIT_IO_SURF_FA_N',1,zhook_handle)
  RETURN
ENDIF
!
IF (haction == 'READ ') THEN
  CALL faitou(iret,nunit_fa,.true.,cfilein_fa,'OLD',.true.,.false.,iverbfa,0,inb,cdnomc)
  WRITE(nluout,*)'HPROGRAM ',hprogram,' IO_INIT HACTION==READ',nunit_fa,cfilein_fa
  CALL facage(cdnomc,.true.)
  lopen=.true.
  !
  cfile_fa = cfilein_fa
  !
  IF (hmask /= 'EXTZON') THEN
    cmask = 'FULL '
    CALL read_surf(&
                   hprogram,'DIM_FULL',nfull,iret,hdir='A')
    !  
    nfull_ext = nfull
    IF (hprogram=='AROME ') THEN
      u%NDIM_FULL = nfull
    ENDIF
  ENDIF
  !
ELSE
  ! NFULL must be known in every case. 
  CALL get_dim_full_n(u%NDIM_FULL, nfull)
  !
  cfile_fa = cfileout_fa
ENDIF
!
IF (hmask == 'EXTZON') THEN
  IF (nrank==npio) THEN
    CALL facies(cdnomc, ityptr, zslapo, zclopo, zslopo,       &
                      zcodil, itronc, inlati, inxlon, inlopa, &
                      inozpa, zsinla, iniver, zrefer, zahybr, &
                      zbhybr, loutfac)
    nfull_ext = inlati*inxlon
    ndgl   = inlati
    ndlon  = inxlon
    nfull  = inlopa(4)*inlopa(6)
    ndlux  = inlopa(4)
    ndgux  = inlopa(6)
    pebeta = zslapo
    perpk  = zsinla(2)
    pelon0 = zsinla(3)*180./xpi
    pelat0 = zsinla(4)*180./xpi
    pedelx = zsinla(7)
    pedely = zsinla(8)
    pelon1 = zsinla(13)*180./xpi 
    pelat1 = zsinla(14)*180./xpi
  ENDIF 
ENDIF
!
IF (.NOT.ALLOCATED(nindex).AND.nrank==npio) THEN
  ALLOCATE(nindex(nfull))
  nindex(:) = 0
ELSEIF (hmask /= 'EXTZON') THEN
  CALL get_dim_full_n(u%NDIM_FULL,nfull)  
ENDIF
!
!------------------------------------------------------------------------------
CMASK=HMASK
!------------------------------------------------------------------------------
!
IF (hprogram=='AROME ') THEN
  nfull  = u%NDIM_FULL
  ilu    = nfull
  il     = nfull
  nsize  = nfull
ELSE
  CALL get_size_full_n(hprogram,nfull,u%NSIZE_FULL,ilu)
  IF (ilu>nsize) nsize = ilu
  il = ilu
  CALL get_type_dim_n(dtco, u, &
                      hmask,il)
ENDIF
!
 CALL get_mask(ilu,il)
!
!------------------------------------------------------------------------------
IF (lhook) CALL dr_hook('INIT_IO_SURF_FA_N',1,zhook_handle)
!------------------------------------------------------------------------------
!
CONTAINS
!
SUBROUTINE get_mask(KLU,KL)
!
USE modd_mask,       ONLY: nmask_full
USE modd_io_surf_fa, ONLY: nmask
!
IMPLICIT NONE
!
INTEGER, INTENT(INOUT) :: KLU
INTEGER, INTENT(IN) :: KL
!
REAL, DIMENSION(KL) :: ZFULL
INTEGER, DIMENSION(KL) :: IMASK
REAL(KIND=JPRB) :: ZHOOK_HANDLE
!
IF (lhook) CALL dr_hook('INIT_IO_SURF_FA_N:GET_MASK',0,zhook_handle)
!
IF (hprogram=='AROME ') THEN
  zfull = 1.
  CALL get_1d_mask(klu,klu,zfull,imask)
  IF (ALLOCATED(nmask_full)) THEN
    IF (klu>SIZE(nmask_full)) DEALLOCATE(nmask_full)
  ENDIF  
ELSE
  CALL get_surf_mask_n(dtco, u, &
                       hmask,kl,imask,klu,nluout)
  IF (ALLOCATED(nmask_full)) THEN
    IF (kl>SIZE(nmask_full)) DEALLOCATE(nmask_full)
  ENDIF  
ENDIF
!
IF (.NOT.ALLOCATED(nmask_full)) ALLOCATE(nmask_full(klu))
!
nmask_full(1:kl) = imask(:)
!
nmask => nmask_full(1:kl)
!
IF (lhook) CALL dr_hook('INIT_IO_SURF_FA_N:GET_MASK',1,zhook_handle)
!
END SUBROUTINE get_mask
!
END SUBROUTINE init_io_surf_fa_n