prep_teb_grib.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 prep_teb_grib(HPROGRAM,HSURF,HFILE,KLUOUT,PFIELD)
!     #################################################################################
!
!!****  *PREP_TEB_GRIB* - prepares TEB field from operational GRIB
!!
!!    PURPOSE
!!    -------
!
!!**  METHOD
!!    ------
!!
!!    REFERENCE
!!    ---------
!!      
!!
!!    AUTHOR
!!    ------
!!     V. Masson 
!!
!!    MODIFICATIONS
!!    -------------
!!      Original    01/2004
!!------------------------------------------------------------------
!

!
USE modd_type_date_surf
!
USE modi_prep_grib_grid
USE mode_read_grib
USE modi_interp_grid
!
USE modd_prep,       ONLY : cingrid_type, cinterp_type
USE modd_grid_grib,  ONLY : cgrib_file, nni
USE modd_prep_teb,   ONLY : xgrid_road, xgrid_wall, xgrid_roof, xgrid_floor, &
                            xti_bld, xti_road, xhui_bld, xti_bld_def,        &
                            xhui_bld_def
USE modd_surf_par,   ONLY : xundef
!
!
!USE YOMHOOK ,ONLY : LHOOK, DR_HOOK
!USE PARKIND1 ,ONLY : JPRB
!
IMPLICIT NONE
!
!*      0.1    declarations of arguments
!
 CHARACTER(LEN=6),   INTENT(IN)  :: hprogram  ! program calling surf. schemes
 CHARACTER(LEN=7),   INTENT(IN)  :: hsurf     ! type of field
 CHARACTER(LEN=28),  INTENT(IN)  :: hfile     ! name of file
INTEGER,            INTENT(IN)  :: kluout    ! logical unit of output listing
REAL,DIMENSION(:,:), POINTER    :: pfield    ! field to interpolate horizontally
!
!*      0.2    declarations of local variables
!
TYPE (date_time)                :: tztime_grib    ! current date and time
 CHARACTER(LEN=6)                :: yinmodel ! model from which GRIB file originates
REAL, DIMENSION(:)  , POINTER   :: zmask => null()          ! Land mask
REAL, DIMENSION(:),   POINTER   :: zfield1d => null() ! 1D field read
REAL, DIMENSION(:,:), POINTER   :: zfield => null()   ! field read
REAL, DIMENSION(:,:), POINTER   :: zd => null()             ! depth of field in the soil
REAL                            :: zti_bld !indoor air temperature
!REAL(KIND=JPRB) :: ZHOOK_HANDLE
!
!-------------------------------------------------------------------------------------
!
!*      1.     Reading of grid
!              ---------------
!
!IF (LHOOK) CALL DR_HOOK('PREP_TEB_GRIB',0,ZHOOK_HANDLE)
!
IF (trim(hfile).NE.cgrib_file) cgrib_file=""
!
 CALL prep_grib_grid(hfile,kluout,yinmodel,cingrid_type,tztime_grib)
!
 CALL read_grib_land_mask(hfile,kluout,yinmodel,zmask)
!
IF (hsurf=='T_FLOOR' .OR. hsurf(1:6)=='T_WALL' .OR. hsurf=='T_ROOF' .OR.  &
    hsurf=='T_WIN2' .OR. hsurf=='TI_BLD' .OR. hsurf=='T_MASS') THEN
  zti_bld = xti_bld_def
  IF (xti_bld/=xundef) zti_bld=xti_bld
ENDIF
!
!---------------------------------------------------------------------------------------
SELECT CASE(hsurf)
!---------------------------------------------------------------------------------------
!
!*     2.      Orography
!              ---------
!
  CASE('ZS     ')
    SELECT CASE (yinmodel)
      CASE ('ECMWF ','ARPEGE','ALADIN','MOCAGE')
        CALL read_grib_zs_land(hfile,kluout,yinmodel,zmask,zfield1d)
        ALLOCATE(pfield(SIZE(zfield1d),1))
        pfield(:,1) = zfield1d(:)
        DEALLOCATE(zfield1d)
    END SELECT
!
!*      3.     Profile of temperatures in roads
!              --------------------------------
!
  CASE('T_ROAD')
     !* reading of the profile and its depth definition
     SELECT CASE(yinmodel)
       CASE('ECMWF ')
         CALL read_grib_tg_ecmwf(hfile,kluout,yinmodel,zmask,zfield,zd)
       CASE('ARPEGE','ALADIN','MOCAGE')
         CALL read_grib_tg_meteo_france(hfile,kluout,yinmodel,zmask,zfield,zd)
     END SELECT
     !* if deep road temperature is prescribed
     IF (xti_road/=xundef) THEN
       zfield(:,2:) = xti_road 
     END IF
     CALL teb_profile_grib(xgrid_road)
!
!*      3.bis  Profile of temperatures in floors
!              --------------------------------

  CASE('T_FLOOR')    
     !* reading of the profile and its depth definition
     SELECT CASE(yinmodel)
       CASE('ECMWF ','ARPEGE','ALADIN','MOCAGE')
         CALL read_grib_tf_teb(hfile,kluout,yinmodel,zti_bld,zmask,zfield,zd)
     END SELECT
     !* if deep road temperature is prescribed
     IF (xti_road/=xundef) THEN
       zfield(:,2:) = xti_road 
     END IF
     CALL teb_profile_grib(xgrid_floor)
!
!*      4.     Profile of temperatures in walls
!              --------------------------------

  CASE('T_WALLA','T_WALLB')
     CALL read_grib_t_teb(hfile,kluout,yinmodel,zti_bld,zmask,zfield,zd)
     CALL teb_profile_grib(xgrid_wall)

  CASE('T_WIN1')
    SELECT CASE (yinmodel)
      CASE ('ECMWF ','ARPEGE','ALADIN','MOCAGE')
        CALL read_grib_ts(hfile,kluout,yinmodel,zmask,zfield1d)
        ALLOCATE(pfield(nni,1))
        pfield(:,1) = zfield1d(:)
        DEALLOCATE(zfield1d)
    END SELECT
!
!*      5.     Profile of temperatures in roofs
!              --------------------------------
!
  CASE('T_ROOF')    
     CALL read_grib_t_teb(hfile,kluout,yinmodel,zti_bld,zmask,zfield,zd)
     CALL teb_profile_grib(xgrid_roof)
!
!*      5.bis    Profile of temperatures in thermal mass
!              -----------------------------------------
!
  CASE('T_MASS')    
     ALLOCATE(pfield(nni,3))
     pfield(:,:) = zti_bld
!
!*      6.     Canyon air temperature
!              ----------------------
!
  CASE('T_CAN  ')
    SELECT CASE (yinmodel)
      CASE ('ECMWF ','ARPEGE','ALADIN','MOCAGE')
        CALL read_grib_t2(hfile,kluout,yinmodel,zmask,zfield1d)
        ALLOCATE(pfield(SIZE(zfield1d),1))
        pfield(:,1) = zfield1d(:)
        DEALLOCATE(zfield1d)
    END SELECT
!
!*      7.      Canyon air humidity
!               -------------------
!
  CASE('Q_CAN  ')
    SELECT CASE (yinmodel)
      CASE ('ECMWF ','ARPEGE','ALADIN','MOCAGE')
        ALLOCATE(pfield(nni,1))
        pfield(:,1) = 0.01
    END SELECT

!
!*      9.     Deep road temperature
!              ---------------------

  CASE('TI_ROAD')    
     IF (xti_road==xundef) THEN
       CALL read_grib_t2(hfile,kluout,yinmodel,zmask,zfield1d)
       ALLOCATE(pfield(SIZE(zfield1d),1))
       pfield(:,1) = zfield1d(:)
       DEALLOCATE(zfield1d)
     ELSE
       ALLOCATE(pfield(nni,1))
       pfield = xti_road
     END IF


!*      9.     Building temperatures/moisture
!              --------------------

  CASE('TI_BLD ')    
     ALLOCATE(pfield(nni,1))
     pfield = zti_bld

  CASE('T_WIN2')
     ALLOCATE(pfield(nni,1))
     pfield = zti_bld

  CASE('QI_BLD ')
     ALLOCATE(pfield(nni,1))
     pfield(:,1) = xundef

!*     10.     Other quantities (water reservoirs)
!              ----------------

  CASE default
    ALLOCATE(pfield(nni,1))
    pfield = 0.

END SELECT
!
DEALLOCATE(zmask)
!
!*      4.     Interpolation method
!              --------------------
!
 cinterp_type='HORIBL'
!
!-------------------------------------------------------------------------------------
!-------------------------------------------------------------------------------------
!
!IF (LHOOK) CALL DR_HOOK('PREP_TEB_GRIB',1,ZHOOK_HANDLE)
 CONTAINS
!
!-------------------------------------------------------------------------------------
!-------------------------------------------------------------------------------------
SUBROUTINE teb_profile_grib(PGRID)
!-------------------------------------------------------------------------------------
!
REAL, DIMENSION(:),   INTENT(IN)  :: pgrid  ! destination grid
!REAL(KIND=JPRB) :: ZHOOK_HANDLE
!
!
!-------------------------------------------------------------------------------------
!
!* interpolation on fine vertical grid
!IF (LHOOK) CALL DR_HOOK('TEB_PROFILE_GRIB',0,ZHOOK_HANDLE)
ALLOCATE(pfield(SIZE(zfield,1),SIZE(pgrid)))
 CALL interp_grid(zd,zfield,pgrid,pfield)
!
!* end
DEALLOCATE(zfield)
DEALLOCATE(zd)
!IF (LHOOK) CALL DR_HOOK('TEB_PROFILE_GRIB',1,ZHOOK_HANDLE)

END SUBROUTINE teb_profile_grib
!
!-------------------------------------------------------------------------------------
END SUBROUTINE prep_teb_grib