garden.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 garden (DTCO, G, T, TOP, TIR, DTV, GB, DK, DEK, DMK, GDO, S, K, P, PEK,    &
                       HIMPLICIT_WIND, TPTIME, PTSUN, PPEW_A_COEF, PPEW_B_COEF, &
                       PPET_A_COEF, PPEQ_A_COEF, PPET_B_COEF, PPEQ_B_COEF,      &
                       PTSTEP, PZREF, PTA, PQA, PEXNS, PRHOA, PCO2, PPS, PRR,   &
                       PSR, PZENITH, PSW, PLW, PVMOD, PALBNIR_TVEG,             &
                       PALBVIS_TVEG, PALBNIR_TSOIL, PALBVIS_TSOIL,              &
                       PRN, PH, PLE, PGFLUX, PSFCO2, PEVAP, PUW, PRUNOFF,       &
                       PAC, PQSAT, PTSRAD, PAC_AGG, PHU_AGG, PIRRIG         )  
!   ##########################################################################
!
!!****  *GARDEN*  
!!
!!    PURPOSE
!!    -------
!
!!call the vegetation scheme (ISBA) inside TEB
!     
!!**  METHOD
!     ------
!
!
!!    EXTERNAL
!!    --------
!!
!!
!!    IMPLICIT ARGUMENTS
!!    ------------------
!!
!!      
!!    REFERENCE
!!    ---------
!!
!!      
!!    AUTHOR
!!    ------
!!
!!      A. Lemonsu          * Meteo-France *
!!
!!    MODIFICATIONS
!!    -------------
!!    Original    05/2009
!     B. decharme 04/2013 : variables for surf/atm coupling
!                           dummy for water table / surface coupling
!!    P. Samuelsson  10/2014  Introduced dummy variables in call to ISBA for MEB
!-------------------------------------------------------------------------------
!
!*       0.     DECLARATIONS
!               ------------
!
USE modd_data_cover_n, ONLY : data_cover_t
USE modd_data_isba_n, ONLY : data_isba_t
USE modd_sfx_grid_n, ONLY : grid_t
USE modd_sso_n, ONLY : sso_t, sso_init
USE modd_teb_n, ONLY : teb_t
USE modd_teb_option_n, ONLY : teb_options_t
!
USE modd_data_isba_n, ONLY : data_isba_t
USE modd_gr_biog_n, ONLY : gr_biog_t
!
USE modd_diag_n, ONLY : diag_t
USE modd_diag_evap_isba_n, ONLY : diag_evap_isba_t
USE modd_diag_misc_isba_n, ONLY : diag_misc_isba_t
!
USE modd_teb_irrig_n, ONLY : teb_irrig_t
!
USE modd_isba_options_n, ONLY : isba_options_t
USE modd_isba_n, ONLY : isba_s_t, isba_k_t, isba_p_t, isba_pe_t
!
USE modd_agri_n, ONLY : agri_t,agri_init
!
USE modd_type_date_surf,    ONLY: date_time
USE modd_surf_par,          ONLY: xundef
USE modd_csts,              ONLY: xcpd
!
!
USE modi_isba
USE modi_vegetation_update
USE mode_thermos
!
USE modi_flag_teb_veg_n
USE modi_carbon_evol
USE modi_vegetation_evol
USE modi_teb_irrig
!
USE yomhook   ,ONLY : lhook,   dr_hook
USE parkind1  ,ONLY : jprb
!
IMPLICIT NONE
!
!*      0.1    Declarations of arguments
!
!
!
TYPE(data_cover_t), INTENT(INOUT) :: DTCO
TYPE(grid_t), INTENT(INOUT) :: G
TYPE(teb_t), INTENT(INOUT) :: T
TYPE(teb_options_t), INTENT(INOUT) :: TOP
!
TYPE(data_isba_t), INTENT(INOUT) :: DTV
TYPE(gr_biog_t), INTENT(INOUT) :: GB
!
TYPE(diag_t), INTENT(INOUT) :: DK
TYPE(diag_evap_isba_t), INTENT(INOUT) :: DEK
TYPE(diag_misc_isba_t), INTENT(INOUT) :: DMK
!
TYPE(isba_options_t), INTENT(INOUT) :: GDO
TYPE(isba_s_t), INTENT(INOUT) :: S
TYPE(isba_k_t), INTENT(INOUT) :: K
TYPE(isba_p_t), INTENT(INOUT) :: P
TYPE(isba_pe_t), INTENT(INOUT) :: PEK
!
TYPE(teb_irrig_t), INTENT(INOUT) :: TIR
!
 CHARACTER(LEN=*),     INTENT(IN)  :: HIMPLICIT_WIND   ! wind implicitation option
!                                                     ! 'OLD' = direct
!                                                     ! 'NEW' = Taylor serie, order 1
TYPE(date_time)     , INTENT(IN)    :: TPTIME             ! current date and time from teb
REAL, DIMENSION(:)  , INTENT(IN)    :: PTSUN              ! solar time      (s from midnight)
REAL, DIMENSION(:)  , INTENT(IN)    :: PPEW_A_COEF        ! implicit coefficients
REAL, DIMENSION(:)  , INTENT(IN)    :: PPEW_B_COEF        ! for wind coupling
REAL, DIMENSION(:)  , INTENT(IN)    :: PPEQ_A_COEF        ! implicit coefficients
REAL, DIMENSION(:)  , INTENT(IN)    :: PPEQ_B_COEF        ! for humidity
REAL, DIMENSION(:)  , INTENT(IN)    :: PPET_A_COEF        ! implicit coefficients
REAL, DIMENSION(:)  , INTENT(IN)    :: PPET_B_COEF        ! for temperature
REAL                , INTENT(IN)    :: PTSTEP             ! time step
REAL, DIMENSION(:)  , INTENT(IN)    :: PZREF              ! height of atm. var. near the road
REAL, DIMENSION(:)  , INTENT(IN)    :: PTA                ! temp. near the road
REAL, DIMENSION(:)  , INTENT(IN)    :: PQA                ! hum. near the road
REAL, DIMENSION(:)  , INTENT(IN)    :: PPS                ! pressure at the surface
REAL, DIMENSION(:)  , INTENT(IN)    :: PEXNS              ! surface exner function
REAL, DIMENSION(:)  , INTENT(IN)    :: PRHOA              ! air density at the lowest level
REAL, DIMENSION(:)  , INTENT(IN)    :: PCO2               ! CO2 concentration in the air    (kg/m3)
REAL, DIMENSION(:)  , INTENT(IN)    :: PRR                ! rain rate
REAL, DIMENSION(:)  , INTENT(IN)    :: PSR                ! snow rate
REAL, DIMENSION(:)  , INTENT(IN)    :: PZENITH            ! solar zenithal angle
REAL, DIMENSION(:)  , INTENT(IN)    :: PSW                ! incoming total solar rad on an horizontal surface
REAL, DIMENSION(:)  , INTENT(IN)    :: PLW                ! atmospheric infrared radiation
REAL, DIMENSION(:)  , INTENT(IN)    :: PVMOD              ! wind near the road
REAL, DIMENSION(:)  , INTENT(IN)    :: PALBNIR_TVEG       ! nearIR  veg tot albedo
REAL, DIMENSION(:)  , INTENT(IN)    :: PALBVIS_TVEG       ! visible veg tot albedo
REAL, DIMENSION(:)  , INTENT(IN)    :: PALBNIR_TSOIL      ! nearIR  soil tot albedo
REAL, DIMENSION(:)  , INTENT(IN)    :: PALBVIS_TSOIL      ! visible soil tot albedo
!
REAL, DIMENSION(:)  , INTENT(OUT)   :: PRN         ! net radiation over green areas
REAL, DIMENSION(:)  , INTENT(OUT)   :: PH          ! sensible heat flux over green areas
REAL, DIMENSION(:)  , INTENT(OUT)   :: PLE         ! latent heat flux over green areas
REAL, DIMENSION(:)  , INTENT(OUT)   :: PGFLUX      ! flux through the green areas
REAL, DIMENSION(:)  , INTENT(OUT)   :: PSFCO2      ! flux of CO2 positive toward the atmosphere (m/s*kg_CO2/kg_air)
REAL, DIMENSION(:)  , INTENT(OUT)   :: PEVAP       ! total evaporation over gardens (kg/m2/s)
REAL, DIMENSION(:)  , INTENT(OUT)   :: PUW         ! friction flux (m2/s2)
REAL, DIMENSION(:)  , INTENT(OUT)   :: PRUNOFF     ! runoff over garden (kg/m2/s)
REAL, DIMENSION(:)  , INTENT(OUT)   :: PAC         ! aerodynamical conductance
REAL, DIMENSION(:)  , INTENT(OUT)   :: PQSAT       ! saturation humidity
REAL, DIMENSION(:)  , INTENT(OUT)   :: PTSRAD      ! garden radiative surface temp. (snow free)
REAL, DIMENSION(:)  , INTENT(OUT)   :: PAC_AGG     ! aggreg. aeodynamic resistance for green areas for latent heat flux
REAL, DIMENSION(:)  , INTENT(OUT)   :: PHU_AGG     ! aggreg. relative humidity for green areas for latent heat flux
REAL, DIMENSION(:)  , INTENT(OUT)   :: PIRRIG      ! garden summer irrigation rate
!
!
!*      0.2    Declarations of local variables
!
TYPE(sso_t) :: YSS
TYPE(agri_t) :: YAG
!
REAL, DIMENSION(SIZE(PPS)) :: ZDIRCOSZW           ! orography slope cosine (=1 in TEB)
REAL, DIMENSION(SIZE(PPS),GDO%NNBIOMASS) :: ZRESP_BIOMASS_INST       ! instantaneous biomass respiration (kgCO2/kgair m/s)
REAL, DIMENSION(SIZE(PPS)) :: ZUSTAR
!
!  temperatures
!
REAL, DIMENSION(SIZE(PPS)) :: ZTA ! estimate of air temperature at future time
!                                 ! step as if modified by ISBA flux alone.
REAL, DIMENSION(SIZE(PPS)) :: ZDEEP_FLUX ! heat flux at base of the deep soil
!
!  surfaces relative fractions
!  for flood
REAL, DIMENSION(SIZE(PPS)) :: ZEMISF
!
!  variables for deep soil temperature
REAL, DIMENSION(SIZE(PPS)) :: ZTDEEP_A
!
! Dummy variables for MEB:
REAL, DIMENSION(SIZE(PPS)) :: ZP_MEB_SCA_SW, ZPALPHAN, ZZ0G_WITHOUT_SNOW, &
                              ZZ0_MEBV, ZZ0H_MEBV, ZZ0EFF_MEBV, ZZ0_MEBN, &
                              ZZ0H_MEBN, ZZ0EFF_MEBN
INTEGER                    :: ILU
LOGICAL :: GMASK, GALB
LOGICAL :: GUPDATED
!
REAL(KIND=JPRB) :: ZHOOK_HANDLE
!
!-------------------------------------------------------------------------------
!
!*      1.     various initialisations
!              -----------------------
!
IF (lhook) CALL dr_hook('GARDEN',0,zhook_handle)
ilu = SIZE(pps)
!
zdircoszw = 1.
!
 CALL sso_init(yss)
!
 CALL agri_init(yag)
!
!-------------------------------------------------------------------------------
!
!*      2.     Treatment of green areas
!              ------------------------
!*      2.1    Automatic irrigation
!              --------------------
!
 CALL teb_irrig(tir%LPAR_GD_IRRIG, ptstep, tptime%TDATE%MONTH, ptsun,        &
               tir%XGD_START_MONTH, tir%XGD_END_MONTH, tir%XGD_START_HOUR,  &
               tir%XGD_END_HOUR, tir%XGD_24H_IRRIG, pirrig           ) 
!
! --------------------------------------------------------------------------------------
! Vegetation update (in case of non-interactive vegetation):
! --------------------------------------------------------------------------------------
!
s%TTIME = tptime
!
gupdated=.false.
galb = .false. 
IF (gdo%CPHOTO=='NIT'.OR.gdo%CPHOTO=='NCB') galb = .true.
!
  CALL vegetation_update(dtco, dtv, g%NDIM, gdo, k, p, pek, 1,              &
                         ptstep, s%TTIME, top%XCOVER, top%LCOVER,  .false., &
                         'GRD', galb, yss, gupdated, oabsent=(t%XGARDEN==0.)  )
!
!
dk%XZ0 (:) = pek%XZ0(:)
dk%XZ0H(:) = pek%XZ0(:) / p%XZ0_O_Z0H(:)
!
dk%XZ0EFF(:) =  pek%XZ0(:)
!
!*      2.2    Call ISBA for green areas
!              -------------------------
!
ALLOCATE(gb%XIACAN(SIZE(pps),SIZE(s%XABC)))
!
 CALL isba(gdo, k, p, pek, g, yag, dk, dek, dmk,                                  &
           tptime, s%XPOI, s%XABC, gb%XIACAN, .false., ptstep,                    &
           himplicit_wind, pzref, pzref, zdircoszw, pta, pqa, pexns, prhoa, pps,  &
           pexns, prr, psr, pzenith, zp_meb_sca_sw, psw, plw, pvmod, ppew_a_coef, &
           ppew_b_coef, ppet_a_coef, ppeq_a_coef, ppet_b_coef, ppeq_b_coef,       &
           palbnir_tveg, palbvis_tveg, palbnir_tsoil, palbvis_tsoil, zpalphan,    &
           zz0g_without_snow, zz0_mebv, zz0h_mebv, zz0eff_mebv, zz0_mebn,         &
           zz0h_mebn, zz0eff_mebn, ztdeep_a, pco2, k%XFFG(:), k%XFFV(:),          &
           zemisf, zustar, pac_agg, phu_agg, zresp_biomass_inst, zdeep_flux, pirrig )     
!
IF (pek%TSNOW%SCHEME=='3-L' .OR. pek%TSNOW%SCHEME=='CRO') pek%TSNOW%TS(:)= dmk%XSNOWTEMP(:,1)
!
IF (gdo%LTR_ML) THEN
  gmask = ( tptime%TIME - ptstep < 0. ) .AND. ( tptime%TIME >= 0. )
  IF (gmask) THEN
    ALLOCATE(dmk%XDFAPARC(ilu),dmk%XDFAPIRC(ilu),dmk%XDLAI_EFFC(ilu))
    dmk%XDFAPARC  (:) = pek%XFAPARC   (:) / pek%XMUS (:)
    dmk%XDFAPIRC  (:) = pek%XFAPIRC   (:) / pek%XMUS (:)
    dmk%XDLAI_EFFC(:) = pek%XLAI_EFFC (:) / pek%XMUS (:)
  ENDIF
ENDIF
!
! - - - - - - - - - - - - - - - - - - - - - - - - - - - - - - - - - - - - - - - - - - -
! Vegetation evolution for interactive LAI
! - - - - - - - - - - - - - - - - - - - - - - - - - - - - - - - - - - - - - - - - - - -
!
IF (gdo%CPHOTO=='NIT') THEN
  CALL vegetation_evol(gdo, dtv, p, pek, .false., ptstep, tptime%TDATE%MONTH, tptime%TDATE%DAY, &
                       tptime%TIME, g%XLAT, prhoa, pco2, yss, zresp_biomass_inst )         
END IF
!
! - - - - - - - - - - - - - - - - - - - - - - - - - - - - - - - - - - - - - - - - - - -
! Diagnostic of respiration carbon fluxes and soil carbon evolution
! - - - - - - - - - - - - - - - - - - - - - - - - - - - - - - - - - - - - - - - - - - -
!
psfco2(:) = 0.
dek%XRESP_ECO (:) = 0.
dek%XRESP_AUTO(:) = 0.
!
IF (gdo%CPHOTO/='NON' .AND. gdo%CRESPSL/='NON' .AND. any(pek%XLAI(:)/=xundef)) THEN
  CALL carbon_evol(gdo, k, p, pek, dek, ptstep, prhoa, zresp_biomass_inst  )
  ! calculation of vegetation CO2 flux
  psfco2(:) = - dek%XGPP(:) + dek%XRESP_ECO(:)
END IF
!
! - - - - - - - - - - - - - - - - - - - - - - - - - - - - - - - - - - - - - - - - - - -
!
!*      4.     Set undefined values for points where there is no garden
!              --------------------------------------------------------
!
! This way, these points are clearly flaged, and one will not try to interpret
! the values for those points
!
 CALL flag_teb_veg_n(pek, gdo, t%XGARDEN, 2)
!
! - - - - - - - - - - - - - - - - - - - - - - - - - - - - - - - - - - - - - - - - - - -
!
!*      9.     Fields required for TEB
!              -----------------------
!
WHERE (t%XGARDEN/=0.)
  !
  ! energy balance
  !
  dk%XLE(:) = pek%XLE(:)
  !
  ! Estimate of green area aerodynamic conductance recomputed from heat flux,
  ! surface (radiative) temp. and forcing air temperature (estimated at future time step)
  zta = ppet_b_coef + ppet_a_coef * dk%XH
  pac = 0.
  WHERE (dk%XTSRAD /= zta)
    pac(:)   = max(dk%XH(:) / xcpd / prhoa(:) / (dk%XTSRAD - zta) , 0.)
  ENDWHERE
  !
  ! Humidity of saturation for green areas
  pqsat(:) = qsat(pek%XTG(:,1),pps(:))
  !
  !* friction flux
  puw(:)    = -zustar(:)**2
  !
ELSEWHERE
  !
  dk%XRN     (:) = xundef
  dk%XH      (:) = xundef
  dk%XLE     (:) = xundef
  dk%XGFLUX  (:) = xundef
  dk%XEVAP   (:) = xundef  
  dek%XRUNOFF(:) = xundef
  !
  pac(:) = xundef
  pqsat(:) = xundef
  puw(:) = xundef
  !
END WHERE
!
!
ptsrad(:) = dk%XTSRAD(:)
!
prn(:) = dk%XRN    (:) 
ph(:) = dk%XH     (:) 
ple(:) = dk%XLE    (:) 
pgflux(:) = dk%XGFLUX (:) 
pevap(:) = dk%XEVAP  (:) 
prunoff(:) =dek%XRUNOFF(:)
!
IF (lhook) CALL dr_hook('GARDEN',1,zhook_handle)
!
!-------------------------------------------------------------------------------
!
!
END SUBROUTINE garden