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_surfex_omp, ONLY : nindx2sfx, nwork, nwork2, xwork, xwork2, xwork3, &
                            nwork_full, nwork2_full, xwork_full, xwork2_full
!
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,             &
                          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)
!
!$OMP BARRIER
!
IF (nrank==npio) lopen=.false.
!
IF (haction=='GTMSK') THEN
  IF (nrank==npio) THEN
!$OMP SINGLE          
    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
!$OMP END SINGLE    
    lopen=.true.
  ENDIF
  cmask = hmask
  IF (lhook) CALL dr_hook('INIT_IO_SURF_FA_N',1,zhook_handle)
  RETURN
ENDIF
!
IF (haction == 'READ ') THEN
  IF (nrank==npio) THEN
!$OMP SINGLE        
    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.)
!$OMP END SINGLE    
    lopen=.true.
  ENDIF
  !
  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, &
                      nfull)
ENDIF
!
IF (hmask == 'EXTZON') THEN
  IF (nrank==npio) THEN
!$OMP SINGLE           
    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
!$OMP END SINGLE    
  ENDIF 
ENDIF
!
IF (.NOT.ALLOCATED(nindex)) THEN
  ALLOCATE(nindex(nfull))
  nindex(:) = 0
ENDIF
!
!------------------------------------------------------------------------------
 cmask=hmask
!------------------------------------------------------------------------------
!
IF (hprogram=='AROME ') THEN
  nfull  = u%NDIM_FULL
  ilu    = nfull
  il     = nfull
  nsize  = nfull
  nindx2sfx = nfull
  IF(.NOT.ASSOCIATED(nwork )) ALLOCATE(nwork(nfull))
  IF(.NOT.ASSOCIATED(xwork )) ALLOCATE(xwork(nfull))
  IF(.NOT.ASSOCIATED(nwork2)) ALLOCATE(nwork2(nfull,10))  
  IF(.NOT.ASSOCIATED(xwork2)) ALLOCATE(xwork2(nfull,10))
  IF(.NOT.ASSOCIATED(xwork3)) ALLOCATE(xwork3(nfull,10,10))
  IF (nrank==npio) THEN
    IF(.NOT.ASSOCIATED(nwork_full )) ALLOCATE(nwork_full(nfull))
    IF(.NOT.ASSOCIATED(xwork_full )) ALLOCATE(xwork_full(nfull))
    IF(.NOT.ASSOCIATED(nwork2_full)) ALLOCATE(nwork2_full(nfull,10))    
    IF(.NOT.ASSOCIATED(xwork2_full)) ALLOCATE(xwork2_full(nfull,10))
  ELSE
    IF(.NOT.ASSOCIATED(nwork_full )) ALLOCATE(nwork_full(0))
    IF(.NOT.ASSOCIATED(xwork_full )) ALLOCATE(xwork_full(0))
    IF(.NOT.ASSOCIATED(nwork2_full)) ALLOCATE(nwork2_full(0,0))    
    IF(.NOT.ASSOCIATED(xwork2_full)) ALLOCATE(xwork2_full(0,0))
  ENDIF
ELSE
  CALL get_size_full_n(u, &
                       hprogram,nfull,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