init_write_bin.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_write_bin (DGU, U, &
                                 hrec,kpatch,owfl)
!     ######################
!
!!****  *INIT_WRITE_BIN_n* Initialize array name to be written and associated
!!                         unit number
!!
!!    PURPOSE
!!    -------
!
!!
!!**  IMPLICIT ARGUMENTS
!!    ------------------
!!      None 
!!
!!    REFERENCE
!!    ---------
!!
!!    AUTHOR
!!    ------
!!      A. LEMONSU     *Meteo France*
!!
!!    MODIFICATIONS
!!    -------------
!!
!
!*       0.   DECLARATIONS
!             ------------
!
!
!
USE modd_diag_surf_atm_n, ONLY : diag_surf_atm_t
USE modd_surf_atm_n, ONLY : surf_atm_t
!
USE modd_io_surf_bin,ONLY:nmask, nfull, cmask
USE modd_write_bin,  ONLY:nunit0, nvar, cvar, jpvar, nind
!
USE modi_abor1_sfx
USE modi_test_record_len
!
USE yomhook   ,ONLY : lhook,   dr_hook
USE parkind1  ,ONLY : jprb
!
IMPLICIT NONE
!
!
TYPE(diag_surf_atm_t), INTENT(INOUT) :: dgu
TYPE(surf_atm_t), INTENT(INOUT) :: u
!
 CHARACTER(LEN=12),   INTENT(IN)     :: hrec    
INTEGER,             INTENT(IN)     :: kpatch    
LOGICAL,             INTENT(INOUT)  :: owfl
INTEGER                             :: ip, ivar, ifield, jfield
INTEGER                             :: ireclen
LOGICAL                             :: lmatch
REAL(KIND=JPRB) :: zhook_handle
!
!------------------------------------------------------------------------------
IF (lhook) CALL dr_hook('INIT_WRITE_BIN',0,zhook_handle)
ireclen=u%NDIM_FULL*kpatch*4
!
ivar=nunit0
DO ip=1, jpvar
  IF (hrec==cvar(ip)) THEN
    ivar=nvar(ip)
    EXIT
  ENDIF
ENDDO
!
!
IF (ivar.NE.nunit0) THEN
!
  owfl=.true.
!
ELSE
!
  IF (cvar(1).NE.'                ') ivar=maxval(nvar(:))
!
!
  IF (.NOT.dgu%LSELECT) THEN
!
    IF ( (hrec(1:2)/='D_'                          ) .AND.  &
          (hrec(1:2)/='DX'                           ) .AND.  &
          (hrec(1:2)/='DY'                           ) .AND.  &
          (hrec(1:4)/='CLAY'                         ) .AND.  &
          (hrec(1:4)/='SAND'                         ) .AND.  &
          (hrec(1:2)/='ZS'                           ) .AND.  &
          (hrec(1:4)/='SSO_'                         ) .AND.  &
          (hrec(1:4)/='Q2M_'                         ) .AND.  &
          (hrec(1:4)/='RESA'                         ) .AND.  &
          (hrec(1:3)/='RI_'                          ) .AND.  &
          (hrec(1:5)/='REG_L'                        ) .AND.  &
          (hrec(1:3)/='AOS'                          ) .AND.  &
          (hrec(1:3)/='HO2'                          ) .AND.  &
          (hrec(1:3)/='RGL'                          ) .AND.  &
          (hrec(1:3)/='SWD'                          ) .AND.  &
          (hrec(1:3)/='SWU'                          ) .AND.  &
          (hrec(1:3)/='LWD'                          ) .AND.  &
          (hrec(1:3)/='LWU'                          ) .AND.  &
          (hrec(1:3)/='ALB'                          ) .AND.  &
          (hrec(1:2)/='DG'                           ) .AND.  &
          (hrec(1:2)/='CV'                           ) .AND.  &
          (hrec(1:5)/='GAMMA'                        ) .AND.  &
          (hrec(1:5)/='RSMIN'                        ) .AND.  &
          (hrec(1:5)/='WRMAX'                        ) .AND.  &
          (hrec(1:5)/='Z0REL'                        ) .AND.  &
          (hrec(1:5)/='Z0SEA'                        ) .AND.  &
          (hrec(1:7)/='Z0WATER'                      ) .AND.  &
          (hrec(4:6)/='_ZS'                          ) .AND.  &
          (hrec(1:7)/='VEGTYPE'                      ) .AND.  &
          (hrec(1:5)/='COVER'                        ) .AND.  &
          (hrec(1:5)/='IRRIG'                        ) .AND.  &
          (hrec(1:4)/='TI_R'                         ) .AND.  &
          (hrec(1:3)/='CD_'                          ) .AND.  &
          (hrec(1:3)/='CE_'                          ) .AND.  &
          (hrec(1:3)/='CH_'                          ) .AND.  &
          (hrec(1:4)/='FMU_'                         ) .AND.  &
          (hrec(1:4)/='FMV_'                         ) .AND.  &
          (hrec(1:5)/='DRAIN'                        ) .AND.  &
          (hrec(1:4)/='EVAP'                         ) .AND.  &
          (hrec(1:6)/='GFLUXC'                       ) .AND.  &
          (hrec(1:6)/='GFLUX_'                       ) .AND.  &
          (hrec(1:6)/='HORTON'                       ) .AND.  &
          (hrec(1:6)/='RUNOFF'                       ) .AND.  &
          (hrec(1:6)/='SNMELT'                       ) .AND.  &
          (hrec(1:6)/='DRIVEG'                       ) .AND.  &
          (hrec(1:2)/='Z0'                           )        ) THEN  

      ivar = ivar+1
      IF (ivar-nunit0>jpvar) THEN
        CALL abor1_sfx('TOO MANY FIELDS TO BE WRITTEN IN THE "BINARY" TYPE TIMESERIES')
      END IF
      cvar(ivar-nunit0) = hrec
      nvar(ivar-nunit0) = ivar
      OPEN(unit=ivar,file=trim(hrec)//'.BIN',form='UNFORMATTED',access='DIRECT',recl=ireclen)
      owfl=.true.
   
    ELSE
      owfl=.false.
    ENDIF
!
  ELSE
!        
    ifield=0
    DO jfield=1,SIZE(dgu%CSELECT)
      IF (dgu%CSELECT(jfield)== '            ') EXIT
      ifield=ifield+1
    ENDDO
  
    CALL test_record_len(dgu, &
                         "ASCII ",hrec,lmatch)

    IF (.NOT. lmatch ) THEN

      ivar = ivar+1
      IF (ivar-nunit0>jpvar) THEN
        CALL abor1_sfx('TOO MANY FIELDS TO BE WRITTEN IN THE "BINARY" TYPE TIMESERIES')
      END IF
      cvar(ivar-nunit0) = hrec
      nvar(ivar-nunit0) = ivar
      OPEN(unit=ivar,file=trim(hrec)//'.BIN',form='UNFORMATTED',access='DIRECT',recl=ireclen)
      owfl=.true.

    ELSE
      owfl=.false.
    ENDIF

  ENDIF
ENDIF

nind=ivar
IF (lhook) CALL dr_hook('INIT_WRITE_BIN',1,zhook_handle)
!
!------------------------------------------------------------------------------
!
END SUBROUTINE init_write_bin