coupling_isba_orographyn.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 coupling_isba_orography_n (DTCO, UG, U, USS, SB, NAG, CHI, NCHI, DTV, ID, NGB, GB, &
                                      ISS, NISS, IG, NIG, IO, S, K, NK, NP, NPE, NDST, SLT,   &
                                      HPROGRAM, HCOUPLING, PTSTEP,                            &
                                      KYEAR, KMONTH, KDAY, PTIME, KI, KSV, KSW, PTSUN,        &
                                      PZENITH, PZENITH2, PAZIM, PZREF, PUREF, PZS, PU, PV,    &
                                      PQA, PTA, PRHOA, PSV, PCO2, HSV, PRAIN, PSNOW, PLW,     &
                                      PDIR_SW, PSCA_SW, PSW_BANDS, PPS, PPA, PSFTQ, PSFTH,    &
                                      PSFTS, PSFCO2, PSFU, PSFV, PTRAD, PDIR_ALB, PSCA_ALB,   &
                                      PEMIS, PTSURF, PZ0, PZ0H, PQSURF, PPEW_A_COEF,          &
                                      PPEW_B_COEF, PPET_A_COEF, PPEQ_A_COEF, PPET_B_COEF,     &
                                      PPEQ_B_COEF, HTEST   )  
!     ###############################################################################
!
!!****  *COUPLING_ISBA_OROGRAPHY_n * - Parameterizes effects of subgrid 
!!     orography on radiative and energy fluxes
!!
!!    PURPOSE
!!    -------
!
!!**  METHOD
!!    ------
!!
!!    REFERENCE
!!    ---------
!!      
!!
!!    AUTHOR
!!    ------
!!     V. Masson 
!!
!!    MODIFICATIONS
!!    -------------
!!      Original    01/2004
!!      modified    05/2004 by P. LeMoigne: vertical shift of implicit
!!                          coefficients
!!      B. Decharme   2008   reset the subgrid topographic effect on the forcing
!!      B. Decharme  04/2013 new coupling variables and optimization
!!                           improve forcing vertical shift
!----------------------------------------------------------------
!
USE modd_agri_n, ONLY : agri_np_t
USE modd_ch_isba_n, ONLY : ch_isba_t, ch_isba_np_t
USE modd_data_isba_n, ONLY : data_isba_t
USE modd_surfex_n, ONLY : isba_diag_t
USE modd_gr_biog_n, ONLY : gr_biog_t, gr_biog_np_t
USE modd_sso_n, ONLY : sso_t, sso_np_t
USE modd_sfx_grid_n, ONLY : grid_t, grid_np_t
USE modd_isba_options_n, ONLY : isba_options_t
USE modd_isba_n, ONLY : isba_s_t, isba_k_t, isba_nk_t, isba_np_t, isba_npe_t
!
USE modd_dst_n, ONLY : dst_np_t
!
USE modd_canopy_n, ONLY : canopy_t
!
USE modd_data_cover_n, ONLY : data_cover_t
USE modd_surf_atm_grid_n, ONLY : surf_atm_grid_t
USE modd_surf_atm_n, ONLY : surf_atm_t
USE modd_sso_n, ONLY : sso_t, sso_np_t
USE modd_data_isba_n, ONLY : data_isba_t
USE modd_slt_n, ONLY : slt_t
!
USE modd_surf_par,ONLY : xundef
USE modd_csts,    ONLY : xstefan, xcpd, xrd, xp00
!
USE modd_surf_atm, ONLY : lnosof, lvertshift
!
USE modi_forcing_vert_shift
USE modi_coupling_isba_canopy_n
!
USE yomhook   ,ONLY : lhook,   dr_hook
USE parkind1  ,ONLY : jprb
!
IMPLICIT NONE
!
!*      0.1    declarations of arguments
!
TYPE(agri_np_t), INTENT(INOUT) :: NAG
TYPE(ch_isba_t), INTENT(INOUT) :: CHI
TYPE(ch_isba_np_t), INTENT(INOUT) :: NCHI
TYPE(data_isba_t), INTENT(INOUT) :: DTV
TYPE(isba_diag_t), INTENT(INOUT) :: ID
TYPE(gr_biog_np_t), INTENT(INOUT) :: NGB
TYPE(gr_biog_t), INTENT(INOUT) :: GB
TYPE(sso_t), INTENT(INOUT) :: ISS 
TYPE(sso_np_t), INTENT(INOUT) :: NISS
TYPE(grid_t), INTENT(INOUT) :: IG
TYPE(grid_np_t), INTENT(INOUT) :: NIG
TYPE(isba_options_t), INTENT(INOUT) :: IO
TYPE(isba_s_t), INTENT(INOUT) :: S
TYPE(isba_k_t), INTENT(INOUT) :: K
TYPE(isba_nk_t), INTENT(INOUT) :: NK
TYPE(isba_np_t), INTENT(INOUT) :: NP
TYPE(isba_npe_t), INTENT(INOUT) ::NPE
!
TYPE(dst_np_t), INTENT(INOUT) :: NDST
!
TYPE(canopy_t), INTENT(INOUT) :: SB
!
TYPE(data_cover_t), INTENT(INOUT) :: DTCO
TYPE(surf_atm_grid_t), INTENT(INOUT) :: UG
TYPE(surf_atm_t), INTENT(INOUT) :: U
TYPE(sso_t), INTENT(INOUT) :: USS
TYPE(slt_t), INTENT(INOUT) :: SLT
!
 CHARACTER(LEN=6),    INTENT(IN)  :: HPROGRAM  ! program calling surf. schemes
 CHARACTER(LEN=1),    INTENT(IN)  :: HCOUPLING ! type of coupling
                                              ! 'E' : explicit
                                              ! 'I' : implicit
INTEGER,             INTENT(IN)  :: KYEAR     ! current year (UTC)
INTEGER,             INTENT(IN)  :: KMONTH    ! current month (UTC)
INTEGER,             INTENT(IN)  :: KDAY      ! current day (UTC)
REAL,                INTENT(IN)  :: PTIME     ! current time since midnight (UTC, s)
INTEGER,             INTENT(IN)  :: KI        ! number of points
INTEGER,             INTENT(IN)  :: KSV       ! number of scalars
INTEGER,             INTENT(IN)  :: KSW       ! number of short-wave spectral bands
REAL, DIMENSION(KI), INTENT(IN)  :: PTSUN     ! solar time                    (s from midnight)
REAL,                INTENT(IN)  :: PTSTEP    ! atmospheric time-step                 (s)
REAL, DIMENSION(KI), INTENT(IN)  :: PZREF     ! height of T,q forcing                 (m)
REAL, DIMENSION(KI), INTENT(IN)  :: PUREF     ! height of wind forcing                (m)
!
REAL, DIMENSION(KI), INTENT(IN)  :: PTA       ! air temperature forcing               (K)
REAL, DIMENSION(KI), INTENT(IN)  :: PQA       ! air humidity forcing                  (kg/m3)
REAL, DIMENSION(KI), INTENT(IN)  :: PRHOA     ! air density                           (kg/m3)
REAL, DIMENSION(KI,KSV),INTENT(IN) :: PSV     ! scalar variables
!                                             ! chemistry:   first char. in HSV: '#'  (molecule/m3)
!                                             !
 CHARACTER(LEN=6), DIMENSION(KSV),INTENT(IN):: HSV  ! name of all scalar variables
REAL, DIMENSION(KI), INTENT(IN)  :: PU        ! zonal wind                            (m/s)
REAL, DIMENSION(KI), INTENT(IN)  :: PV        ! meridian wind                         (m/s)
REAL, DIMENSION(KI,KSW),INTENT(IN) :: PDIR_SW ! direct  solar radiation (on horizontal surf.)
!                                             !                                       (W/m2)
REAL, DIMENSION(KI,KSW),INTENT(IN) :: PSCA_SW ! diffuse solar radiation (on horizontal surf.)
!                                             !                                       (W/m2)
REAL, DIMENSION(KSW),INTENT(IN)  :: PSW_BANDS ! mean wavelength of each shortwave band (m)
REAL, DIMENSION(KI), INTENT(IN)  :: PZENITH   ! zenithal angle at t  (radian from the vertical)
REAL, DIMENSION(KI), INTENT(IN)  :: PZENITH2  ! zenithal angle at t+1(radian from the vertical)
REAL, DIMENSION(KI), INTENT(IN)  :: PAZIM     ! azimuthal angle      (radian from North, clockwise)
REAL, DIMENSION(KI), INTENT(IN)  :: PLW       ! longwave radiation (on horizontal surf.)
!                                             !                                       (W/m2)
REAL, DIMENSION(KI), INTENT(IN)  :: PPS       ! pressure at atmospheric model surface (Pa)
REAL, DIMENSION(KI), INTENT(IN)  :: PPA       ! pressure at forcing level             (Pa)
REAL, DIMENSION(KI), INTENT(IN)  :: PZS       ! atmospheric model orography           (m)
REAL, DIMENSION(KI), INTENT(IN)  :: PCO2      ! CO2 concentration in the air          (kg/m3)
REAL, DIMENSION(KI), INTENT(IN)  :: PSNOW     ! snow precipitation                    (kg/m2/s)
REAL, DIMENSION(KI), INTENT(IN)  :: PRAIN     ! liquid precipitation                  (kg/m2/s)
!
!
REAL, DIMENSION(KI), INTENT(OUT) :: PSFTH     ! flux of heat                          (W/m2)
REAL, DIMENSION(KI), INTENT(OUT) :: PSFTQ     ! flux of water vapor                   (kg/m2/s)
REAL, DIMENSION(KI), INTENT(OUT) :: PSFU      ! zonal momentum flux                   (Pa)
REAL, DIMENSION(KI), INTENT(OUT) :: PSFV      ! meridian momentum flux                (Pa)
REAL, DIMENSION(KI), INTENT(OUT) :: PSFCO2    ! flux of CO2                           (m/s*kg_CO2/kg_air)
REAL, DIMENSION(KI,KSV),INTENT(OUT):: PSFTS   ! flux of scalar var.                   (kg/m2/s)
!
REAL, DIMENSION(KI), INTENT(OUT) :: PTRAD     ! radiative temperature                 (K)
REAL, DIMENSION(KI,KSW),INTENT(OUT):: PDIR_ALB! direct albedo for each spectral band  (-)
REAL, DIMENSION(KI,KSW),INTENT(OUT):: PSCA_ALB! diffuse albedo for each spectral band (-)
REAL, DIMENSION(KI), INTENT(OUT) :: PEMIS     ! emissivity                            (-)
!
REAL, DIMENSION(KI), INTENT(OUT) :: PTSURF    ! surface effective temperature         (K)
REAL, DIMENSION(KI), INTENT(OUT) :: PZ0       ! roughness length for momentum         (m)
REAL, DIMENSION(KI), INTENT(OUT) :: PZ0H      ! roughness length for heat             (m)
REAL, DIMENSION(KI), INTENT(OUT) :: PQSURF    ! specific humidity at surface          (kg/kg)
!
REAL, DIMENSION(KI), INTENT(IN) :: PPEW_A_COEF! implicit coefficients
REAL, DIMENSION(KI), INTENT(IN) :: PPEW_B_COEF! needed if HCOUPLING='I'
REAL, DIMENSION(KI), INTENT(IN) :: PPET_A_COEF
REAL, DIMENSION(KI), INTENT(IN) :: PPEQ_A_COEF
REAL, DIMENSION(KI), INTENT(IN) :: PPET_B_COEF
REAL, DIMENSION(KI), INTENT(IN) :: PPEQ_B_COEF
 CHARACTER(LEN=2),    INTENT(IN) :: HTEST ! must be equal to 'OK'
!
!*      0.2    declarations of local variables
!
REAL, DIMENSION(KI)  :: ZTA    ! Temperature at forcing height above surface orography
REAL, DIMENSION(KI)  :: ZPA    ! Pressure    at forcing height above surface orography
REAL, DIMENSION(KI)  :: ZPS    ! Pressure    at surface orography
REAL, DIMENSION(KI)  :: ZQA    ! Humidity    at forcing height above surface orography
REAL, DIMENSION(KI)  :: ZRHOA  ! Density     at forcing height above surface orography
REAL, DIMENSION(KI)  :: ZLW    ! LW rad      at forcing height above surface orography
REAL, DIMENSION(KI)  :: ZRAIN  ! Rainfall    at forcing height above surface orography
REAL, DIMENSION(KI)  :: ZSNOW  ! Snowfall    at forcing height above surface orography
!
!
REAL, DIMENSION(KI)    :: Z3D_TOT_SURF ! ratio between actual surface
!                                               ! and horizontal surface
REAL, DIMENSION(KI)    :: Z3D_TOT_SURF_INV
REAL, DIMENSION(KI,KSW)::ZDIR_SW ! incoming direct SW radiation
!                                                         ! per m2 of actual surface
REAL, DIMENSION(KI,KSW)::ZSCA_SW ! incoming diffuse SW radiation
!                                                         ! per m2 of actual surface
!
REAL, DIMENSION(KI)  ::  ZPEQ_B_COEF   ! 1st explicit coefficient
REAL, DIMENSION(KI)  ::  ZPET_B_COEF   ! 2nd explicit coefficient
!
INTEGER                         :: ISWB    ! number of shortwave spectral bands
INTEGER                         :: JSWB    ! loop on shortwave spectral bands
INTEGER                         :: JSV     ! loop on scalar variables
REAL(KIND=JPRB) :: ZHOOK_HANDLE
!
!-------------------------------------------------------------------------------------
!        
!*      1.     Goes from atmospheric orography to surface orography
!              ----------------------------------------------------
!
IF (lhook) CALL dr_hook('COUPLING_ISBA_OROGRAPHY_N',0,zhook_handle)
!
zpeq_b_coef(:) = ppeq_b_coef(:)
zpet_b_coef(:) = ppet_b_coef(:)
!
IF(lvertshift)THEN
!
  zta(:) = xundef
  zqa(:) = xundef
  zps(:) = xundef
  zpa(:) = xundef
  zrhoa(:) = xundef
  zlw(:) = xundef
  zrain(:) = xundef
  zsnow(:) = xundef
!     
   CALL forcing_vert_shift(pzs, s%XZS, pta, pqa, ppa, prhoa, plw, prain, psnow, &
                           zta, zqa, zpa, zrhoa, zlw, zrain, zsnow         )
!
   zps(:) = zpa(:) + (pps(:) - ppa(:))
!
  IF (hcoupling=='I') THEN
    zpeq_b_coef = ppeq_b_coef + zqa - pqa
    zpet_b_coef = ppet_b_coef + zta/(zpa/xp00)**(xrd/xcpd) - pta/(ppa/xp00)**(xrd/xcpd)
  ENDIF
!
ELSE
!
  zta(:) = pta(:)
  zqa(:) = pqa(:)
  zps(:) = pps(:)
  zpa(:) = ppa(:)
  zrhoa(:) = prhoa(:)
  zlw(:) = plw(:)
  zrain(:) = prain(:)
  zsnow(:) = psnow(:)
!
ENDIF
!
!-------------------------------------------------------------------------------------
!
!*      2.     Presence of orography slopes
!              ----------------------------
!
IF(lnosof)THEN
!        
!  No modifications to conserve mass and energy with atmosphere
!
   z3d_tot_surf(:) = 0.
   z3d_tot_surf_inv(:) = 0.
!   
   zsca_sw(:,:) = psca_sw(:,:)
   zdir_sw(:,:) = pdir_sw(:,:)
!
ELSE
!
! Note that this effect is not conservative and should not be use with
! atmospheric model
!
!* Incoming and outgoing fluxes are supposed to be on a horizontal surface.
!  When slopes are present, the actual surface is LARGER than the
!  horizontal surface (none conservative).
!
!* Therefore, this increase of surface will lead to modify the
!  radiative and energy fluxes (none conservative).
!  
!* Note that momentum fluxes are not modified, because the
!  effect of subgrid orography is already taken into account
!  in the effective roughness length (none conservative).
!
!  The subgrid slope comes from the XSSO_SLOPE field.
!
   z3d_tot_surf(:) = sqrt(1.+iss%XSSO_SLOPE(:)**2)
   z3d_tot_surf_inv(:) = 1./z3d_tot_surf(:)
!
!  number of spectral shortwave bands
!
   iswb = SIZE(psw_bands)
!
   DO jswb=1,iswb
!     correcting for the slope angle (scaterred SW flux)
!
      zsca_sw(:,jswb) =  psca_sw(:,jswb) * z3d_tot_surf_inv(:)

!     correcting for the slope angle (scaterred SW flux)
!
      zdir_sw(:,jswb) =  pdir_sw(:,jswb) * z3d_tot_surf_inv(:)
   END DO
!
!  part of LW flux is received from the surface itself, so the outgoing flux
!  is needed.
!
!  incoming LW radiation per m2 of actual surface
!
   zlw(:) =  zlw(:)                                   *     z3d_tot_surf_inv(:) &
          + xstefan*s%XEMIS_NAT(:)*s%XTSRAD_NAT(:)**4 * (1.-z3d_tot_surf_inv(:))  
!
!  liquid precipitation per m2 of actual surface
!
   zrain(:) = zrain(:) * z3d_tot_surf_inv(:)
!
!  solid  precipitation per m2 of actual surface
!
   zsnow(:) = zsnow(:) * z3d_tot_surf_inv(:)
!
ENDIF
!
!-------------------------------------------------------------------------------------
!
!*      3.     Call of ISBA
!              ------------
!
 CALL coupling_isba_canopy_n(dtco, ug, u, uss, sb, nag, chi, nchi, dtv, id, ngb, gb,   &
                             iss, niss, ig, nig, io, s, k, nk, np, npe, ndst, slt,     &
                             hprogram, hcoupling, ptstep,                              &
                             kyear, kmonth, kday, ptime, ki, ksv, ksw, ptsun, pzenith, &
                             pzenith2, pazim, pzref, puref, pzs, pu, pv, zqa, zta,     &
                             zrhoa, psv, pco2, hsv, zrain, zsnow, zlw, zdir_sw,        &
                             zsca_sw, psw_bands, zps, zpa, psftq, psfth, psfts, psfco2,&
                             psfu, psfv, ptrad, pdir_alb, psca_alb, pemis, ptsurf, pz0,&
                             pz0h, pqsurf, ppew_a_coef, ppew_b_coef, ppet_a_coef,      &
                             ppeq_a_coef, zpet_b_coef, zpeq_b_coef, 'OK'   )  
!
!-------------------------------------------------------------------------------------
!
!*      4.     Optional modification of turbulent energy and gaz fluxes 
!              --------------------------------------------------------
!
IF(.NOT.lnosof)THEN
  psfth(:)  = psfth(:) * z3d_tot_surf(:)
  psftq(:)  = psftq(:) * z3d_tot_surf(:)
  psfco2(:)  = psfco2(:) * z3d_tot_surf(:)
  DO jsv=1,SIZE(psfts,2)
    psfts(:,jsv)  = psfts(:,jsv) * z3d_tot_surf(:)
  END DO
ENDIF
!
IF (lhook) CALL dr_hook('COUPLING_ISBA_OROGRAPHY_N',1,zhook_handle)
!
!-------------------------------------------------------------------------------------
!
END SUBROUTINE coupling_isba_orography_n