get_teb_depths.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 get_teb_depths (&
                                  dtco, &
                                 hfilepgd, hfilepgdtype, pd_roof, pd_road, pd_wall, pd_floor)
!     ##############################################################
!
!!**** *CONVERT_COVER* 
!!
!!    PURPOSE
!!    -------
!!
!!    METHOD
!!    ------
!!   
!!    EXTERNAL
!!    --------
!!
!!    IMPLICIT ARGUMENTS
!!    ------------------
!!
!!    REFERENCE
!!    ---------
!!
!!    AUTHOR
!!    ------
!!
!!    V. Masson        Meteo-France
!!
!!    MODIFICATION
!!    ------------
!!
!!    Original    01/2004
!     
!----------------------------------------------------------------------------
!
!*    0.     DECLARATION
!            -----------
!
!
!
!
!
!
USE modd_data_cover_n, ONLY : data_cover_t
!
USE modd_data_cover,     ONLY : xdata_d_roof, xdata_d_road, xdata_d_wall, xdata_d_floor
USE modd_data_cover_par, ONLY : jpcover, ndata_roof_layer, ndata_road_layer, &
                                ndata_wall_layer, ndata_floor_layer
!
USE mode_read_surf_cov, ONLY : read_surf_cov
!
USE modi_read_surf
USE modi_av_pgd
USE modi_old_name
USE modi_thermal_layers_conf
USE modi_open_aux_io_surf
USE modi_close_aux_io_surf
!
USE yomhook   ,ONLY : lhook,   dr_hook
USE parkind1  ,ONLY : jprb
!
USE modi_abor1_sfx
!
IMPLICIT NONE
!
!*    0.1    Declaration of arguments
!            ------------------------
!
!
!
!
TYPE(data_cover_t), INTENT(INOUT) :: dtco
!
 CHARACTER(LEN=28),  INTENT(IN)  :: hfilepgd     ! name of file
 CHARACTER(LEN=6),   INTENT(IN)  :: hfilepgdtype ! type of input file
!
REAL, DIMENSION(:,:), INTENT(OUT), OPTIONAL   :: pd_roof
REAL, DIMENSION(:,:), INTENT(OUT), OPTIONAL   :: pd_road
REAL, DIMENSION(:,:), INTENT(OUT), OPTIONAL   :: pd_wall
REAL, DIMENSION(:,:), INTENT(OUT), OPTIONAL   :: pd_floor
!
!*    0.2    Declaration of local variables
!            ------------------------------
!
LOGICAL, DIMENSION(JPCOVER)          :: gcover ! flag to read the covers
REAL,    DIMENSION(:,:), ALLOCATABLE :: zcover ! cover fractions
REAL,    DIMENSION(:,:), ALLOCATABLE :: zd     ! depth of surface layers
REAL,    DIMENSION(:,:), ALLOCATABLE :: zpar_d ! depth of data_surface layers
REAL,    DIMENSION(:,:), ALLOCATABLE :: zpar_hc, zpar_tc, zhc, ztc ! work arrays
!
INTEGER           :: iversion       ! surface version
INTEGER           :: ibugfix        ! surface bugfix version
 CHARACTER(LEN=5)  :: ysurf          ! Type of surface
 CHARACTER(LEN=12) :: yrecfm         ! Name of the article to be read
 CHARACTER(LEN=12) :: yrecfm0        ! Name of the article to be read
 CHARACTER(LEN=12) :: yrecfm1        ! Name of the article to be read
 CHARACTER(LEN=12) :: yrecfm2        ! Name of the article to be read
 CHARACTER(LEN=3)  :: yarea          ! Area where field is to be averaged
INTEGER           :: iresp          ! reading return code
LOGICAL           :: gdata          ! T if depth is to be read in the file
REAL, DIMENSION(SIZE(XDATA_D_ROOF,1),SIZE(XDATA_D_ROOF,2)) :: zdata
INTEGER :: ilayer                   ! number of surface layers
INTEGER :: jlayer                   ! loop counter on surface layers
INTEGER :: ipar_layer               ! number of data surface layers
INTEGER :: idata_layer              ! number of data surface layers from ecoclimap
INTEGER :: ilu                      ! number of points
REAL(KIND=JPRB) :: zhook_handle
!-------------------------------------------------------------------------------
!
!*    2.      SECONDARY VARIABLES
!             -------------------
!
!*    2.2     fields on artificial surfaces only
!             ----------------------------------
!
IF (lhook) CALL dr_hook('GET_TEB_DEPTHS',0,zhook_handle)
!
 CALL open_aux_io_surf(&
                      hfilepgd,hfilepgdtype,'FULL  ')
yrecfm='VERSION'
 CALL read_surf(&
               hfilepgdtype,yrecfm,iversion,iresp)
yrecfm='BUG'
 CALL read_surf(&
               hfilepgdtype,yrecfm,ibugfix,iresp)
 CALL close_aux_io_surf(hfilepgd,hfilepgdtype)
!
IF (present(pd_roof)) THEN
  ysurf='ROOF '
  zdata = xdata_d_roof
  yrecfm0 = 'PAR_RF_LAYER'
  yrecfm1 = 'L_D_ROOF'
  yrecfm2 = 'D_D_ROOF'
  idata_layer = ndata_roof_layer
  ilu     = SIZE(pd_roof,1)
  ilayer  = SIZE(pd_roof,2)
  yarea   = 'BLD'
END IF
IF (present(pd_wall)) THEN
  ysurf='WALL '
  zdata = xdata_d_wall
  yrecfm0 = 'PAR_WL_LAYER'
  yrecfm1 = 'L_D_WALL'
  yrecfm2 = 'D_D_WALL'
  idata_layer = ndata_wall_layer
  ilu     = SIZE(pd_wall,1)
  ilayer  = SIZE(pd_wall,2)
  yarea   = 'BLD'
END IF
IF (present(pd_road)) THEN
  ysurf='ROAD '
  zdata = xdata_d_road
  yrecfm0 = 'PAR_RD_LAYER'
  yrecfm1 = 'L_D_ROAD'
  yrecfm2 = 'D_D_ROAD'
  idata_layer = ndata_road_layer
  ilu     = SIZE(pd_road,1)
  ilayer  = SIZE(pd_road,2)
  yarea   = 'STR'
END IF
IF (present(pd_floor)) THEN
  ysurf='FLOOR'
  zdata = xdata_d_floor
  yrecfm0 = 'PAR_FL_LAYER'
  yrecfm1 = 'L_D_FLOOR'
  yrecfm2 = 'D_D_FLOOR'
  idata_layer = ndata_floor_layer
  ilu     = SIZE(pd_floor,1)
  ilayer  = SIZE(pd_floor,2)
  yarea   = 'BLD'
END IF
!
ALLOCATE(zd(ilu,ilayer))
!
!* read if the depths description are written in the file
IF (iversion<7 .OR. (iversion==7 .AND. ibugfix<=2)) THEN
  gdata = .false.
ELSE
  CALL open_aux_io_surf(&
                      hfilepgd,hfilepgdtype,'TOWN  ')
  CALL read_surf(&
               hfilepgdtype,yrecfm1,gdata,iresp)
  CALL close_aux_io_surf(hfilepgd,hfilepgdtype)
END IF
!
!* depths are read in the file
IF (gdata) THEN
  !* gets number of data layers
  CALL open_aux_io_surf(&
                      hfilepgd,hfilepgdtype,'TOWN  ')
  CALL read_surf(&
               hfilepgdtype,yrecfm0,ipar_layer,iresp)
  !* gets the data layers depths
  ALLOCATE(zpar_d(ilu,ipar_layer))
  DO jlayer=1,ipar_layer
    WRITE(yrecfm,fmt='(A,I1)') trim(yrecfm2),jlayer
    CALL read_surf(&
               hfilepgdtype,yrecfm,zpar_d(:,jlayer),iresp,hdir='A')
  END DO
  CALL close_aux_io_surf(hfilepgd,hfilepgdtype)
!
ELSE
!* depths are deduced from the cover types
  CALL open_aux_io_surf(&
                      hfilepgd,hfilepgdtype,'FULL  ')
  ALLOCATE(zpar_d(ilu,idata_layer))
  !* reading of the cover to obtain the thickness of layers
  CALL old_name(&
                hfilepgdtype,'COVER_LIST      ',yrecfm)
  CALL read_surf(&
               hfilepgdtype,yrecfm,gcover(:),iresp,hdir='-')
  !* reading of the cover fractions
  ALLOCATE(zcover(ilu,count(gcover)))
  yrecfm='COVER'
  CALL read_surf_cov(&
                     hfilepgdtype,yrecfm,zcover(:,:),gcover,iresp,hdir='A')
  !
  !* deduces the depths of each layer
  DO jlayer=1,idata_layer
    CALL av_pgd(dtco, &
                 zpar_d(:,jlayer), zcover, zdata(:,jlayer),yarea,'ARI',gcover)
  END DO
  DEALLOCATE(zcover)
  CALL close_aux_io_surf(hfilepgd,hfilepgdtype)
ENDIF
!
!* recomputes the grid from the available data
!
IF (iversion<7 .OR. (iversion==7 .AND. ibugfix<=2)) THEN
  !* in old version of TEB, the computational grid was equal to the data grid
  zd(:,:) = zpar_d(:,:)
ELSE
  !* recomputes the grid from the available data
  ALLOCATE(zpar_hc(ilu,SIZE(zpar_d,2)))
  ALLOCATE(zpar_tc(ilu,SIZE(zpar_d,2)))
  ALLOCATE(ztc(ilu,ilayer))
  ALLOCATE(zhc(ilu,ilayer))
  zpar_hc = 1.e6  ! not physically used
  zpar_tc = 1.    ! not physically used
  CALL thermal_layers_conf(ysurf,zpar_hc,zpar_tc,zpar_d,zhc,ztc,zd)
  DEALLOCATE(zpar_hc)
  DEALLOCATE(zpar_tc)
  DEALLOCATE(zhc)
  DEALLOCATE(ztc)
END IF
!
IF (present(pd_roof )) pd_roof  = zd
IF (present(pd_wall )) pd_wall  = zd
IF (present(pd_road )) pd_road  = zd
IF (present(pd_floor)) pd_floor = zd
!
DEALLOCATE(zd)
!
IF (lhook) CALL dr_hook('GET_TEB_DEPTHS',1,zhook_handle)
!-------------------------------------------------------------------------------
!
END SUBROUTINE get_teb_depths