zoom_pgd_teb.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 zoom_pgd_teb (B, DGCT, DGMT, T, TGD, TGDPE, TGR, TGRPE, &
                               bop, bdd, dtb, dtco, dtt, ug, u, tgdo, tgdp, tg, &
                               top, tvg, &
                               hprogram,hinifile,hinifiletype,oecoclimap,ogarden)
!     ###########################################################

!!
!!    PURPOSE
!!    -------
!!   This program prepares the physiographic data fields.
!!
!!    METHOD
!!    ------
!!   
!!    EXTERNAL
!!    --------
!!
!!
!!    IMPLICIT ARGUMENTS
!!    ------------------
!!
!!
!!    REFERENCE
!!    ---------
!!
!!    AUTHOR
!!    ------
!!
!!    V. Masson                   Meteo-France
!!
!!    MODIFICATION
!!    ------------
!!
!!    Original     13/10/03
!----------------------------------------------------------------------------
!
!*    0.     DECLARATION
!            -----------
!
!
USE modd_bem_n, ONLY : bem_t
USE modd_diag_cumul_teb_n, ONLY : diag_cumul_teb_t
USE modd_diag_misc_teb_n, ONLY : diag_misc_teb_t
USE modd_teb_n, ONLY : teb_t
USE modd_teb_garden_n, ONLY : teb_garden_t
USE modd_teb_garden_pgd_evol_n, ONLY : teb_garden_pgd_evol_t
USE modd_teb_greenroof_n, ONLY : teb_greenroof_t
USE modd_teb_greenroof_pgd_evol_n, ONLY : teb_greenroof_pgd_evol_t
USE modd_bem_option_n, ONLY : bem_options_t
USE modd_bld_description_n, ONLY : bld_desc_t
USE modd_data_bem_n, ONLY : data_bem_t
USE modd_data_cover_n, ONLY : data_cover_t
USE modd_data_teb_n, ONLY : data_teb_t
USE modd_surf_atm_grid_n, ONLY : surf_atm_grid_t
USE modd_surf_atm_n, ONLY : surf_atm_t
USE modd_teb_garden_option_n, ONLY : teb_garden_options_t
USE modd_teb_garden_pgd_n, ONLY : teb_garden_pgd_t
USE modd_teb_grid_n, ONLY : teb_grid_t
USE modd_teb_option_n, ONLY : teb_options_t
USE modd_teb_veg_n, ONLY : teb_veg_options_t
!
USE modd_data_cover_par,  ONLY : jpcover
!
USE modd_prep,            ONLY : cingrid_type, cinterp_type, linterp
!
USE modi_get_luout
USE modi_abor1_sfx
USE modi_open_aux_io_surf
USE modi_get_surf_size_n
USE modi_pack_pgd
USE modi_prep_grid_extern
USE modi_prep_output_grid
USE modi_read_surf
USE modi_read_pgd_teb_par_n
USE modi_close_aux_io_surf
USE modi_clean_prep_output_grid
USE modi_goto_wrapper_teb_patch
!
USE yomhook   ,ONLY : lhook,   dr_hook
USE parkind1  ,ONLY : jprb
!
!
IMPLICIT NONE
!
!*    0.1    Declaration of dummy arguments
!            ------------------------------
!
!
TYPE(bem_t), INTENT(INOUT) :: b
TYPE(diag_cumul_teb_t), INTENT(INOUT) :: dgct
TYPE(diag_misc_teb_t), INTENT(INOUT) :: dgmt
TYPE(teb_t), INTENT(INOUT) :: t
TYPE(teb_garden_pgd_evol_t), INTENT(INOUT) :: tgdpe
TYPE(teb_garden_t), INTENT(INOUT) :: tgd
TYPE(teb_greenroof_t), INTENT(INOUT) :: tgr
TYPE(teb_greenroof_pgd_evol_t), INTENT(INOUT) :: tgrpe
TYPE(bem_options_t), INTENT(INOUT) :: bop
TYPE(bld_desc_t), INTENT(INOUT) :: bdd
TYPE(data_bem_t), INTENT(INOUT) :: dtb
TYPE(data_cover_t), INTENT(INOUT) :: dtco
TYPE(data_teb_t), INTENT(INOUT) :: dtt
TYPE(surf_atm_grid_t), INTENT(INOUT) :: ug
TYPE(surf_atm_t), INTENT(INOUT) :: u
TYPE(teb_garden_options_t), INTENT(INOUT) :: tgdo
TYPE(teb_garden_pgd_t), INTENT(INOUT) :: tgdp
TYPE(teb_grid_t), INTENT(INOUT) :: tg
TYPE(teb_options_t), INTENT(INOUT) :: top
TYPE(teb_veg_options_t), INTENT(INOUT) :: tvg
!
 CHARACTER(LEN=6),     INTENT(IN)  :: hprogram    ! program calling
 CHARACTER(LEN=28),    INTENT(IN)  :: hinifile    ! file to read
 CHARACTER(LEN=6),     INTENT(IN)  :: hinifiletype! file type
LOGICAL,              INTENT(IN)  :: oecoclimap  ! flag to use ecoclimap
LOGICAL,              INTENT(IN)  :: ogarden     ! flag to use garden
!
!
!*    0.2    Declaration of local variables
!            ------------------------------
!
INTEGER :: iresp   ! error return code
INTEGER :: iluout  ! output listing logical unit
INTEGER :: ini     ! total 1D dimension (input grid)
INTEGER :: jlayer  ! loop counter
INTEGER :: ilu     ! total 1D dimension (output grid, TOWN points only)
INTEGER :: jpatch  ! TEB patch
REAL(KIND=JPRB) :: zhook_handle
INTEGER           :: iversion
INTEGER           :: ibugfix
!------------------------------------------------------------------------------
IF (lhook) CALL dr_hook('ZOOM_PGD_TEB',0,zhook_handle)
 CALL get_luout(hprogram,iluout)
!
top%LECOCLIMAP = oecoclimap
top%LGARDEN = ogarden
!
IF (.NOT. oecoclimap) THEN
  WRITE(iluout,*) 'ERROR'
  WRITE(iluout,*) 'Ecoclimap is not used'
  WRITE(iluout,*) 'Routine zoom_pgd_teb.f90 must be updated'
  WRITE(iluout,*) 'to interpolate all TEB physiographic fields'
  CALL abor1_sfx('ZOOM_PGD_TEB: ECOCLIMAP NOT USED, ROUTINE MUST BE UPDATED')
END IF
!
!
!*      1.     Preparation of IO for reading in the file
!              -----------------------------------------
!
!* Note that all points are read, even those without physical meaning.
!  These points will not be used during the horizontal interpolation step.
!  Their value must be defined as XUNDEF.
!
 CALL open_aux_io_surf(&
                       hinifile,hinifiletype,'FULL  ')
!
 CALL goto_wrapper_teb_patch(b, dgct, dgmt, t, tgd, tgdpe, tgr, tgrpe, 1)
!-------------------------------------------------------------------------------
!
!*    2.      Number of points and packing of general fields
!             ----------------------------------------------
!
!
 CALL get_surf_size_n(dtco, u, &
                      'TOWN  ',ilu)
!
ALLOCATE(top%LCOVER     (jpcover))
ALLOCATE(top%XZS        (ilu))
ALLOCATE(tg%XLAT       (ilu))
ALLOCATE(tg%XLON       (ilu))
ALLOCATE(tg%XMESH_SIZE (ilu))
!
 CALL pack_pgd(dtco, u, &
               hprogram, 'TOWN  ',                      &
                tg%CGRID,  tg%XGRID_PAR,                     &
                top%LCOVER, top%XCOVER, top%XZS,                   &
                tg%XLAT, tg%XLON, tg%XMESH_SIZE                 )  
!
tg%NDIM = ilu
!
!
 CALL read_surf(&
                hprogram,'VERSION',iversion,iresp)
 CALL read_surf(&
                hprogram,'BUG',ibugfix,iresp)
!------------------------------------------------------------------------------
!
!*      3.     Reading of grid
!              ---------------
!
 CALL prep_grid_extern(&
                       hinifiletype,iluout,cingrid_type,cinterp_type,ini)
!
 CALL prep_output_grid(ug, u, &
                       iluout,tg%CGRID,tg%XGRID_PAR,tg%XLAT,tg%XLON)
!
!
!------------------------------------------------------------------------------
!
!*      4.     Reading & interpolation of fields
!              ---------------------------------
!
!
IF (iversion<7 .OR. iversion==7 .AND. ibugfix<=2) THEN
  top%NTEB_PATCH=1
ELSE
  CALL read_surf(&
                hprogram,'TEB_PATCH',top%NTEB_PATCH,iresp)
END IF

!
 CALL read_surf(&
                hprogram,'ROOF_LAYER',top%NROOF_LAYER,iresp)
 CALL read_surf(&
                hprogram,'ROAD_LAYER',top%NROAD_LAYER,iresp)
 CALL read_surf(&
                hprogram,'WALL_LAYER',top%NWALL_LAYER,iresp)
!
IF (iversion<7 .OR.( iversion==7 .AND. ibugfix<=2)) THEN
  top%CBLD_ATYPE='ARI'
  top%CBEM = 'DEF'
ELSE
  CALL read_surf(&
                hprogram,'BLD_ATYPE' ,top%CBLD_ATYPE,iresp)
  CALL read_surf(&
                hprogram,'BEM'       ,top%CBEM      ,iresp)
END IF
!
IF (top%CBEM/='DEF') THEN
  CALL read_surf(&
                hprogram,'FLOOR_LAYER',bop%NFLOOR_LAYER,iresp)
END IF
!
DO jpatch=1,top%NTEB_PATCH
  CALL goto_wrapper_teb_patch(b, dgct, dgmt, t, tgd, tgdpe, tgr, tgrpe, jpatch)
  CALL read_pgd_teb_par_n(dtco, u, &
                          bdd, dtb, dtt, tg, top, &
                          hprogram,ini,'A')
!
!------------------------------------------------------------------------------
!
!*      5.     Gardens
!              -------
!
  IF (top%LGARDEN) CALL zoom_pgd_teb_garden
END DO
!
 CALL close_aux_io_surf(hinifile,hinifiletype)
!
 CALL clean_prep_output_grid
!
!------------------------------------------------------------------------------
IF (lhook) CALL dr_hook('ZOOM_PGD_TEB',1,zhook_handle)
!------------------------------------------------------------------------------
!
 CONTAINS
!
SUBROUTINE zoom_pgd_teb_garden
!
USE modi_hor_interpol
!
!
IMPLICIT NONE
!
REAL, DIMENSION(:,:), POINTER     :: zin     ! field  on all surface points
!
REAL, DIMENSION(INI)              :: zfield  ! field read
REAL, DIMENSION(ILU,1)            :: zout    ! final field
REAL(KIND=JPRB) :: zhook_handle
 CHARACTER(LEN=12) :: yrecfm         ! Name of the article to be read
!
IF (lhook) CALL dr_hook('ZOOM_PGD_TEB:ZOOM_PGD_TEB_GARDEN',0,zhook_handle)
!
linterp(:) = .true.
!
IF (iversion>7 .OR. iversion==7 .AND. ibugfix>=3) THEN
  CALL read_surf(&
                hprogram,'GD_LAYER',tgdo%NGROUND_LAYER,iresp)
  CALL read_surf(&
                hprogram,'GD_ISBA',tvg%CISBA,iresp)
  CALL read_surf(&
                hprogram,'GD_PHOTO',tvg%CPHOTO,iresp)
  CALL read_surf(&
                hprogram,'GD_PEDOTF',tvg%CPEDOTF,iresp)
  tvg%NNBIOMASS=1
  IF (tvg%CPHOTO=='NIT') tvg%NNBIOMASS=3  
ELSE
  CALL read_surf(&
                hprogram,'TWN_LAYER',tgdo%NGROUND_LAYER,iresp)
  CALL read_surf(&
                hprogram,'TWN_ISBA',tvg%CISBA,iresp)
  CALL read_surf(&
                hprogram,'TWN_PHOTO',tvg%CPHOTO,iresp)
  CALL read_surf(&
                hprogram,'TWN_PEDOTF',tvg%CPEDOTF,iresp)
  CALL read_surf(&
                hprogram,'TWN_NBIOMASS',tvg%NNBIOMASS,iresp)
ENDIF
!
!* sand
!
ALLOCATE(zin(ini,tgdo%NGROUND_LAYER))
yrecfm='TWN_SAND'
IF (iversion>7 .OR. iversion==7 .AND. ibugfix>=3) yrecfm='GD_SAND'
 CALL read_surf(&
                hprogram,yrecfm,zfield,iresp,hdir='A')
DO jlayer=1,tgdo%NGROUND_LAYER
  zin(:,jlayer) = zfield(:)
END DO
ALLOCATE(tgdp%XSAND(ilu,tgdo%NGROUND_LAYER))
 CALL hor_interpol(dtco, u, &
                   iluout,zin,tgdp%XSAND)
DEALLOCATE(zin)
!
!* clay
!
ALLOCATE(zin(ini,tgdo%NGROUND_LAYER))
yrecfm='TWN_CLAY'
IF (iversion>7 .OR. iversion==7 .AND. ibugfix>=3) yrecfm='GD_CLAY'
 CALL read_surf(&
                hprogram,yrecfm,zfield,iresp,hdir='A')
DO jlayer=1,tgdo%NGROUND_LAYER
  zin(:,jlayer) = zfield(:)
END DO
ALLOCATE(tgdp%XCLAY(ilu,tgdo%NGROUND_LAYER))
 CALL hor_interpol(dtco, u, &
                   iluout,zin,tgdp%XCLAY)
DEALLOCATE(zin)
!
!* runoff & drainage
!
ALLOCATE(zin(ini,1))
yrecfm='TWN_RUNOFFB'
IF (iversion>7 .OR. iversion==7 .AND. ibugfix>=3) yrecfm='GD_RUNOFFB'
 CALL read_surf(&
                hprogram,yrecfm,zfield,iresp,hdir='A')
zin(:,1) = zfield(:)
ALLOCATE(tgdp%XRUNOFFB(ilu))
 CALL hor_interpol(dtco, u, &
                   iluout,zin,zout)
tgdp%XRUNOFFB(:) = zout(:,1)
!
IF (iversion<=3) THEN
  tgdp%XWDRAIN = 0.
ELSE
 yrecfm='TWN_WDRAIN'
 IF (iversion>7 .OR. iversion==7 .AND. ibugfix>=3) yrecfm='GD_WDRAIN'
 CALL read_surf(&
                hprogram,yrecfm,zfield,iresp,hdir='A')
 zin(:,1) = zfield(:)
 ALLOCATE(tgdp%XWDRAIN(ilu))
 CALL hor_interpol(dtco, u, &
                   iluout,zin,zout)
 tgdp%XWDRAIN(:) = zout(:,1)
ENDIF
!
DEALLOCATE(zin)
!
!* other garden parameters
!
 CALL read_surf(&
                hprogram,'PAR_GARDEN',tgdo%LPAR_GARDEN,iresp)
!
!!
IF (tgdo%LPAR_GARDEN) THEN
  WRITE(iluout,*) 'ERROR'
  WRITE(iluout,*) 'Specific garden fields are prescribed'
  WRITE(iluout,*) 'Routine zoom_pgd_teb.f90 must be updated'
  WRITE(iluout,*) 'to interpolate all TEB physiographic garden fields'
  CALL abor1_sfx('ZOOM_PGD_TEB: GARDEN fields used, ROUTINE MUST BE UPDATED')
END IF
!
IF (lhook) CALL dr_hook('ZOOM_PGD_TEB:ZOOM_PGD_TEB_GARDEN',1,zhook_handle)
!
END SUBROUTINE zoom_pgd_teb_garden
!_______________________________________________________________________________
!
END SUBROUTINE zoom_pgd_teb