prep_teb_unif.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_unif(KLUOUT,HSURF,PFIELD)
!     #################################################################################
!
!!****  *PREP_TEB_UNIF* - prepares TEB field from prescribed values
!!
!!    PURPOSE
!!    -------
!
!!**  METHOD
!!    ------
!!
!!    REFERENCE
!!    ---------
!!      
!!
!!    AUTHOR
!!    ------
!!     V. Masson 
!!
!!    MODIFICATIONS
!!    -------------
!!      Original    01/2004
!!------------------------------------------------------------------
!
!
USE modd_surf_par,   ONLY : xundef
USE modd_prep,       ONLY : cinterp_type, xzs_ls
USE modd_prep_teb,   ONLY : xgrid_road, xgrid_wall, xgrid_roof, xgrid_floor,    &
                              xws_roof, xws_road, xts_road, xts_roof, xts_wall, &
                              xti_bld, xti_road, xt_can, xq_can, xhui_bld
USE modd_csts, ONLY : xg, xp00
!
!
USE yomhook   ,ONLY : lhook,   dr_hook
USE parkind1  ,ONLY : jprb
!
USE modi_abor1_sfx
USE mode_thermos
!
IMPLICIT NONE
!
!*      0.1    declarations of arguments
!
INTEGER,            INTENT(IN)  :: kluout    ! output listing logical unit
 CHARACTER(LEN=7),   INTENT(IN)  :: hsurf     ! type of field
REAL, POINTER, DIMENSION(:,:)   :: pfield    ! field to interpolate horizontally
!
!*      0.2    declarations of local variables
REAL, DIMENSION(:), ALLOCATABLE :: zps       ! surface pressure
REAL, DIMENSION(:), ALLOCATABLE :: zti_bld   ! indoor building temperature
REAL, PARAMETER                 :: zrhoa=1.19! air volumic mass at 20C and 1015hPa
!
REAL(KIND=JPRB) :: zhook_handle
!
!-------------------------------------------------------------------------------------
!
IF (lhook) CALL dr_hook('PREP_TEB_UNIF',0,zhook_handle)
SELECT CASE(hsurf)
!
!*      3.0    Orography
!
  CASE('ZS     ')
    ALLOCATE(pfield(1,1))
    pfield = 0.
!
!*      3.1    Profile of temperatures in roads
!
  CASE('T_ROAD ')
    ALLOCATE(pfield(1,SIZE(xgrid_road)))
    CALL put_unif_on_ref_grid('ROAD',xgrid_road)

!*      3.2    Profile of temperatures in walls

  CASE('T_WALLA','T_WALLB')
    ALLOCATE(pfield(1,SIZE(xgrid_wall)))
    CALL put_unif_on_ref_grid('WALL',xgrid_wall)

!*      3.3    Profile of temperatures in roofs

  CASE('T_ROOF ')
    ALLOCATE(pfield(1,SIZE(xgrid_roof)))
    CALL put_unif_on_ref_grid('ROOF',xgrid_roof)

!*      3.4bis Profile of temperatures in floors

  CASE('T_FLOOR')
    ALLOCATE(pfield(1,SIZE(xgrid_floor)))
    CALL put_unif_on_ref_grid('FLOO',xgrid_floor)

  CASE('T_MASS')
    ALLOCATE(pfield(1,SIZE(xgrid_floor)))
    CALL put_unif_on_ref_grid('MASS',xgrid_floor)

!*      3.4    Other quantities

  CASE('WS_ROOF')
    ALLOCATE(pfield(1,1))
    pfield = xws_roof

  CASE('WS_ROAD')
    ALLOCATE(pfield(1,1))
    pfield = xws_road

  CASE('TI_BLD  ')
    ALLOCATE(pfield(1,1))
    pfield = xti_bld

  CASE('QI_BLD  ')
    ALLOCATE(pfield(SIZE(xzs_ls),1))
    ALLOCATE(zps(SIZE(xzs_ls)))
    ALLOCATE(zti_bld(SIZE(xzs_ls)))
    zps = xp00 - zrhoa*xg*xzs_ls
    zti_bld = xti_bld
    pfield(:,1) = xhui_bld * qsat(zti_bld, zps)
    DEALLOCATE(zps)
    DEALLOCATE(zti_bld)

  CASE('T_WIN1  ')
    ALLOCATE(pfield(1,1))
    pfield = xts_wall

  CASE('T_WIN2  ')
    ALLOCATE(pfield(1,1))
    pfield = xti_bld

  CASE('TI_ROAD')
    ALLOCATE(pfield(1,1))
    pfield = xti_road

  CASE('T_CAN  ')
    ALLOCATE(pfield(1,1))
    pfield = xt_can

  CASE('Q_CAN  ')
    ALLOCATE(pfield(1,1))
    pfield = xq_can

END SELECT
!
!*      4.     Interpolation method
!              --------------------
!
 cinterp_type='UNIF  '
!
!-------------------------------------------------------------------------------------
!-------------------------------------------------------------------------------------
!
IF (lhook) CALL dr_hook('PREP_TEB_UNIF',1,zhook_handle)
 CONTAINS
!
!-------------------------------------------------------------------------------------
!-------------------------------------------------------------------------------------
SUBROUTINE put_unif_on_ref_grid(HSURFTYPE,PGRID)
!-------------------------------------------------------------------------------------
!
USE modd_surf_par,   ONLY : xundef
USE modi_interp_grid
!
 CHARACTER(LEN=4),   INTENT(IN) :: hsurftype ! surface type
REAL, DIMENSION(:), INTENT(IN) :: pgrid     ! reference grid
!
REAL               :: zts! surface temperature
REAL               :: zti! internal temperature
REAL, DIMENSION(1,2) :: zt ! temperature profile
REAL, DIMENSION(1,2) :: zd ! normalized depth profile
REAL(KIND=JPRB) :: zhook_handle
!
!-------------------------------------------------------------------------------------

!* get surface temperature

IF (lhook) CALL dr_hook('PUT_UNIF_ON_REF_GRID',0,zhook_handle)
SELECT CASE(hsurftype)
  CASE('ROOF')
    zts = xts_roof
  CASE('ROAD')
    zts = xts_road
  CASE('WALL')
    zts = xts_wall
  CASE('FLOO')
    zts = xti_bld
  CASE('MASS')
    zts = xti_bld
END SELECT

!* get deep road or building interior temperature

SELECT CASE(hsurftype)
  CASE('ROOF', 'WALL', 'MASS')
    zti = xti_bld
  CASE('ROAD', 'FLOO')
    IF (xti_road/= xundef) THEN
      zti = xti_road
    ELSE
      WRITE(kluout,*) 'Error in PREParation of TEB fields'
      WRITE(kluout,*) 'When Road Surface Temperature is prescribed,'
      WRITE(kluout,*) 'Deep Road Temperature XTI_ROAD must also be prescribed'
      CALL abor1_sfx('PREP_TEB_UNIF: XTI_ROAD MUST BE PRESCRIBED')
    END IF
END SELECT

!* group all this information in one profile

zt(1,1) = zts
zt(1,2) = zti

zd(1,1) = 0.
zd(1,2) = 1.

!* interpolate this field on the required grid
!
 CALL interp_grid(zd,zt,pgrid,pfield)
IF (lhook) CALL dr_hook('PUT_UNIF_ON_REF_GRID',1,zhook_handle)
!
!-------------------------------------------------------------------------------------
!
END SUBROUTINE put_unif_on_ref_grid
!
!-------------------------------------------------------------------------------------
END SUBROUTINE prep_teb_unif