read_prep_teb_conf.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 read_prep_teb_conf(HPROGRAM,HVAR,HFILE,HFILETYPE,HFILEPGD,HFILEPGDTYPE,   &
                                    hatmfile,hatmfiletype,hpgdfile,hpgdfiletype,kluout,ounif)
!     #######################################################
!
!!****  *READ_PREP_TEB_CONF* - routine to read the configuration for TEB
!!                             fields preparation
!!
!!    PURPOSE
!!    -------
!!
!!**  METHOD
!!    ------
!!
!!    EXTERNAL
!!    --------
!!
!!
!!    IMPLICIT ARGUMENTS
!!    ------------------
!!
!!    REFERENCE
!!    ---------
!!
!!
!!    AUTHOR
!!    ------
!!      V. Masson   *Meteo France*
!!
!!    MODIFICATIONS
!!    -------------
!!      Original    01/2004 
!!      P. Le Moigne 10/2005, Phasage Arome
!-------------------------------------------------------------------------------
!
!*       0.    DECLARATIONS
!              ------------
!
USE modi_read_prep_surf_atm_conf
!
USE modn_prep_teb, ONLY : cfile_ts, ctype_ts
USE modd_prep_teb, ONLY : cfile_teb, ctype, cfilepgd_teb, ctypepgd,                 &
                          cfile_ws, ctype_ws, xws_roof, xws_road,                   &
                          xts_roof, xts_road, xts_wall, xti_bld, xti_road,          &
                          xt_can, xq_can, xws_roof_def, xws_road_def, xti_bld_def,  &
                          xhui_bld_def, xhui_bld  
!
USE modd_surf_par,   ONLY : xundef
!
USE mode_thermos
!
USE yomhook   ,ONLY : lhook,   dr_hook
USE parkind1  ,ONLY : jprb
!
USE modi_abor1_sfx
!
IMPLICIT NONE
!
!*       0.1   Declarations of arguments
!              -------------------------
!
 CHARACTER(LEN=6),  INTENT(IN)  :: hprogram ! program calling ISBA
 CHARACTER(LEN=7),  INTENT(IN)  :: hvar     ! variable treated
 CHARACTER(LEN=28), INTENT(OUT) :: hfile    ! file name
 CHARACTER(LEN=6),  INTENT(OUT) :: hfiletype! file type
 CHARACTER(LEN=28), INTENT(OUT) :: hfilepgd    ! file name
 CHARACTER(LEN=6),  INTENT(OUT) :: hfilepgdtype! file type
 CHARACTER(LEN=28), INTENT(IN)  :: hatmfile    ! atmospheric file name
 CHARACTER(LEN=6),  INTENT(IN)  :: hatmfiletype! atmospheric file type
 CHARACTER(LEN=28), INTENT(IN)  :: hpgdfile    ! atmospheric file name
 CHARACTER(LEN=6),  INTENT(IN)  :: hpgdfiletype! atmospheric file type
INTEGER,           INTENT(IN)  :: kluout   ! logical unit of output listing
LOGICAL,           INTENT(OUT) :: ounif    ! flag for prescribed uniform field

!
!*       0.2   Declarations of local variables
!              -------------------------------
!
INTEGER           :: iresp          ! IRESP  : return-code if a problem appears 
                                    ! at the open of the file in LFI  routines 
INTEGER           :: ilunam         ! Logical unit of namelist file
!
 CHARACTER(LEN=28) :: ynamelist      ! namelist file
!
LOGICAL           :: gfound         ! Return code when searching namelist
REAL(KIND=JPRB) :: zhook_handle
!-------------------------------------------------------------------------------
!
!
IF (lhook) CALL dr_hook('READ_PREP_TEB_CONF',0,zhook_handle)
hfile = '                            '
hfiletype = '      '
!
hfilepgd = '                         '
hfilepgdtype = '      '
!
ounif     = .false.
!
!-------------------------------------------------------------------------------
!
!* choice of input file
!  --------------------
!
SELECT CASE (hvar)
  CASE ('WS_ROOF','WS_ROAD')
    IF (len_trim(cfile_ws)>0 .AND. len_trim(ctype_ws)>0 ) THEN
      hfile     = cfile_ws
      hfiletype = ctype_ws
    END IF
  CASE ('T_ROOF ','T_ROAD ','T_WALL ','T_WALLA','T_WALLB','T_FLOOR','T_MASS','T_WIN1 ','T_CAN  ','Q_CAN')
    IF (len_trim(cfile_ts)>0 .AND. len_trim(ctype_ts)>0 ) THEN
      hfile     = cfile_ts
      hfiletype = ctype_ts
    END IF
END SELECT
!
IF (len_trim(hfile)==0 .AND. len_trim(cfile_teb)>0 .AND. len_trim(ctype)>0) THEN
  hfile     = cfile_teb
  hfiletype = ctype
END IF
!
IF (len_trim(hfilepgd)==0 .AND. len_trim(cfilepgd_teb)>0 .AND. len_trim(ctypepgd)>0) THEN
  hfilepgd     = cfilepgd_teb
  hfilepgdtype = ctypepgd
END IF
!
!! If no file name in the scheme namelist,
!! try to find a name in NAM_SURF_ATM
!
IF (len_trim(hfile)==0) THEN
!
 CALL read_prep_surf_atm_conf(hprogram,hfile,hfiletype,hfilepgd,hfilepgdtype,&
                             hatmfile,hatmfiletype,hpgdfile,hpgdfiletype,kluout)
!
END IF
!-------------------------------------------------------------------------------
!
!* Is an uniform field prescribed?
!  ------------------------------
!
SELECT CASE (hvar)
  CASE ('WS_ROOF')
    ounif = (xws_roof/=xundef) 
  CASE ('WS_ROAD')
    ounif = (xws_road/=xundef) 
  CASE ('TI_BLD ')
    ounif = (xti_bld/=xundef)  
  CASE ('TI_ROAD')
    ounif = (xti_road/=xundef)    
  CASE ('T_ROAD ')
    ounif = (xts_road/=xundef) 
  CASE ('T_WALL ','T_WALLA','T_WALLB')
    ounif = (xts_wall/=xundef)     
  CASE ('T_ROOF ')
    ounif = (xts_roof/=xundef) 
  CASE ('T_FLOOR')
    ounif = (xti_road/=xundef)     
  CASE ('T_MASS') 
    ounif = (xti_bld/=xundef)
  CASE ('T_WIN1') 
    ounif = (xts_wall/=xundef)
  CASE ('T_WIN2') 
    ounif = (xti_bld/=xundef)
  CASE ('QI_BLD ')
    ounif = (xhui_bld/=xundef .AND. xti_bld/=xundef)     
END SELECT
!
!-------------------------------------------------------------------------------
!
!* building temperature available for temperature profiles when file is present
!  ----------------------------------------------------------------------------
!
!IF (LEN_TRIM(HFILETYPE)>0 .AND. .NOT. OUNIF) THEN
!  IF (HVAR=='T_ROOF ' .OR. HVAR=='T_WALL' .OR. HVAR=='TI_BLD' .AND. XTI_BLD==XUNDEF) XTI_BLD=XTI_BLD_DEF
!END IF
!
!-------------------------------------------------------------------------------
!
!* If no file and no uniform field is prescribed: default values used
!  ---------------------------------------------
!
IF (len_trim(hfiletype)==0 .AND. .NOT. ounif) THEN
  SELECT CASE (hvar)
    CASE ('ZS     ')
      ounif = .true.
    CASE ('WS_ROOF')
      xws_roof = xws_roof_def
      ounif = .true.
    CASE ('WS_ROAD')
      xws_road = xws_road_def
      ounif = .true.
    CASE ('TI_BLD ')
      xti_bld  = xti_bld_def
      ounif = .true.
    CASE ('Q_CAN  ')
      IF (xt_can/=xundef) THEN
         xq_can = xhui_bld_def * qsat(xt_can, 100000.)
         ounif = .true.
      ELSE 
         CALL abor1_sfx("READ_PREP_TEB_CONF: DON'T KNOW HOW TO INITIALIZE Q_CAN ")
      END IF            
    CASE ('T_CAN  ')  
      IF (xts_road/=xundef) THEN
        xt_can = xts_road
      ELSE IF (xts_wall/=xundef) THEN
        xt_can = xts_wall
      ELSE IF (xts_roof/=xundef) THEN
        xt_can = xts_roof
      ELSE
        CALL abor1_sfx('READ_PREP_TEB_CONF: AN INPUT VALUE IS REQUIRED FOR '//hvar)
      END IF 
    CASE ('T_WIN1  ')
      IF (xts_wall==xundef) THEN
         CALL abor1_sfx('READ_PREP_TEB_CONF: AN INPUT VALUE IS REQUIRED FOR TS_WALL TO INITIALIZE T_WIN1')
      ELSE 
         ounif = .true.
      ENDIF
    CASE ('T_WIN2  ') 
      xti_bld  = xti_bld_def
      ounif = .true.
    CASE ('QI_BLD  ') 
      xhui_bld  = xhui_bld_def
      ounif = .true.
    CASE ('DATE   ')
      IF (lhook) CALL dr_hook('READ_PREP_TEB_CONF',1,zhook_handle)
      RETURN
    CASE ('SN_ROOF','SN_ROAD')
      ounif = .true.
    CASE default
      CALL abor1_sfx('READ_PREP_TEB_CONF: AN INPUT FILE OR A UNIFORM VALUE IS REQUIRED FOR '//hvar)
   END SELECT
END IF
!
!-------------------------------------------------------------------------------
!
!* no file given ? nor specific value in namelist? One takes the default value.
!
IF (hfiletype=='      ' .AND. .NOT. ounif) THEN
  IF (hvar(1:2)/='ZS') WRITE(kluout,*) 'NO FILE FOR FIELD ',hvar, &
                                        ': UNIFORM DEFAULT FIELD IS PRESCRIBED'
  ounif = .true.
END IF
IF (lhook) CALL dr_hook('READ_PREP_TEB_CONF',1,zhook_handle)
!
!-------------------------------------------------------------------------------
!
END SUBROUTINE read_prep_teb_conf