coupling_watfluxn.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_watflux_n (CHW, DGO, D, DC, W, DST, SLT, &
                               HPROGRAM, HCOUPLING, PTIMEC, PTSTEP, KYEAR, KMONTH, KDAY, PTIME, &
                               KI, KSV, KSW, PTSUN, PZENITH, PZENITH2, PAZIM, PZREF, PUREF,     &
                               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_WATFLUX_n * - Driver for WATER_FLUX scheme for lakes
!!
!!    PURPOSE
!!    -------
!
!!**  METHOD
!!    ------
!!
!!    REFERENCE
!!    ---------
!!      
!!
!!    AUTHOR
!!    ------
!!     V. Masson 
!!
!!    MODIFICATIONS
!!    -------------
!!      Original    01/2004
!!      B. Decharme 03/2009 TS_WATER could change during a run => ALB and EMIS
!!      V. Masson   05/2009 Implicitation of momentum fluxes
!!      B. Decharme 09/2009 Radiative properties at time t+1 in order to close
!                           the energy budget between surfex and the atmosphere 
!!      B. Decharme 01/2010 Add XTT
!!      B. Decharme 09/2012 New wind implicitation
!!      P. LeMoigne 04/2013 Wind implicitation displaced
!!      B. Decharme  04/2013 new coupling variables
!!----------------------------------------------------------------------------
!
!
USE modd_ch_watflux_n, ONLY : ch_watflux_t
USE modd_diag_n, ONLY : diag_options_t, diag_t
USE modd_watflux_n, ONLY : watflux_t
!
USE modd_dst_n, ONLY : dst_t
USE modd_slt_n, ONLY : slt_t
!
USE modd_reprod_oper, ONLY : cimplicit_wind
!
USE modd_csts,       ONLY : xrd, xcpd, xp00, xtt, xday, xtts
USE modd_surf_par,   ONLY : xundef
USE modd_sfx_oasis,  ONLY : lcpl_seaice
USE modd_water_par
!
!
USE modi_water_flux
USE modi_add_forecast_to_date_surf
USE modi_diag_inline_watflux_n
USE modi_ch_aer_dep
USE modi_ch_dep_water
USE modi_dslt_dep
USE modi_update_rad_water
USE modi_interpol_ts_water_mth
!
USE mode_dslt_surf
USE modd_dst_surf
USE modd_slt_surf
!
USE yomhook   ,ONLY : lhook,   dr_hook
USE parkind1  ,ONLY : jprb
!
USE modi_abor1_sfx
!
USE modi_coupling_iceflux_n
!
IMPLICIT NONE
!
!*      0.1    declarations of arguments
!
TYPE(ch_watflux_t), INTENT(INOUT) :: CHW
TYPE(diag_options_t), INTENT(INOUT) :: DGO
TYPE(diag_t), INTENT(INOUT) :: D 
TYPE(diag_t), INTENT(INOUT) :: DC
TYPE(watflux_t), INTENT(INOUT) :: W 
!
TYPE(dst_t), INTENT(INOUT) :: DST
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
REAL,                INTENT(IN)  :: PTIMEC    ! cumulated time since beginning of simulation
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)  :: 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   (m2s/kg)
REAL, DIMENSION(KI), INTENT(IN) :: PPEW_B_COEF! needed if HCOUPLING='I' (m/s)
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)  :: ZEXNA      ! Exner function at forcing level
REAL, DIMENSION(KI)  :: ZEXNS      ! Exner function at surface level
REAL, DIMENSION(KI)  :: ZWIND      ! Wind
REAL, DIMENSION(KI)  :: ZCD        ! Drag coefficient
REAL, DIMENSION(KI)  :: ZCDN       ! Neutral Drag coefficient
REAL, DIMENSION(KI)  :: ZCH        ! Heat transfer coefficient
REAL, DIMENSION(KI)  :: ZRI        ! Richardson number
REAL, DIMENSION(KI)  :: ZHU        ! Near surface relative humidity
REAL, DIMENSION(KI)  :: ZRESA_WATER! aerodynamical resistance
REAL, DIMENSION(KI)  :: ZUSTAR     ! friction velocity (m/s)
REAL, DIMENSION(KI)  :: ZUSTAR2    ! square of friction velocity (m2/s2)
REAL, DIMENSION(KI)  :: ZZ0H       ! heat roughness length over water
REAL, DIMENSION(KI)  :: ZQSAT      ! humidity at saturation
REAL, DIMENSION(KI)  :: ZQA        ! specific humidity (kg/kg)
REAL, DIMENSION(KI)  :: ZEMIS      ! Emissivity at time t
REAL, DIMENSION(KI)  :: ZTRAD      ! Radiative temperature at time t
REAL, DIMENSION(KI)  :: ZSFTH_ICE  ! Sea ice flux of heat
REAL, DIMENSION(KI)  :: ZSFTQ_ICE  ! Sea ice flux of ice sublimation
REAL, DIMENSION(KI)  :: ZWORK      ! Work array
!
REAL, DIMENSION(KI,KSW) :: ZDIR_ALB   ! Direct albedo at time t
REAL, DIMENSION(KI,KSW) :: ZSCA_ALB   ! Diffuse albedo at time t
!
REAL                       :: ZCONVERTFACM0_SLT, ZCONVERTFACM0_DST
REAL                       :: ZCONVERTFACM3_SLT, ZCONVERTFACM3_DST
REAL                       :: ZCONVERTFACM6_SLT, ZCONVERTFACM6_DST
!
INTEGER                          :: ISWB       ! number of shortwave spectral bands
INTEGER                          :: JSWB       ! loop counter on shortwave spectral bands      
!
INTEGER :: IBEG, IEND
!
LOGICAL                    :: GHANDLE_SIC = .false. ! no sea-ice model
!
REAL(KIND=JPRB) :: ZHOOK_HANDLE
!
!-------------------------------------------------------------------------------------
! Preliminaries:
!-------------------------------------------------------------------------------------
IF (lhook) CALL dr_hook('COUPLING_WATFLUX_N',0,zhook_handle)
IF (htest/='OK') THEN
  CALL abor1_sfx('COUPLING_WATFLUXN: FATAL ERROR DURING ARGUMENT TRANSFER')        
END IF
!-------------------------------------------------------------------------------------
!
zexna(:) = xundef
zexns(:) = xundef
zwind(:) = xundef
zcd(:) = xundef    
zcdn(:) = xundef
zch(:) = xundef
zri(:) = xundef
zhu(:) = xundef
zresa_water(:) = xundef
zustar(:) = xundef
zustar2(:) = xundef
zz0h(:) = xundef
zqsat(:) = xundef
zemis(:) = xundef
ztrad(:) = xundef
zwork(:) = xundef
zdir_alb(:,:) = xundef
zsca_alb(:,:) = xundef
!
IF(lcpl_seaice)THEN
  zsftq_ice(:) = xundef
  zsfth_ice(:) = xundef
ENDIF
!
!-------------------------------------------------------------------------------------
!
zexns(:)     = (pps(:)/xp00)**(xrd/xcpd)
zexna(:)     = (ppa(:)/xp00)**(xrd/xcpd)
!
zwind(:) = sqrt(pu(:)**2+pv(:)**2)
!
psfts(:,:) = 0.
!
zhu = 1.
!
zqa(:) = pqa(:) / prhoa(:)
!
! - - - - - - - - - - - - - - - - - - - - - - - - - - - - - - - - - - - - - - - - - - -
! Time evolution
! - - - - - - - - - - - - - - - - - - - - - - - - - - - - - - - - - - - - - - - - - - -
!
w%TTIME%TIME = w%TTIME%TIME + ptstep
 CALL add_forecast_to_date_surf(w%TTIME%TDATE%YEAR,w%TTIME%TDATE%MONTH,w%TTIME%TDATE%DAY,w%TTIME%TIME)
!
!--------------------------------------------------------------------------------------
! Fluxes over water according to Charnock formulae
!--------------------------------------------------------------------------------------
!
!
 CALL water_flux(w%XZ0, pta, zexna, prhoa, w%XTS, zexns, zqa, prain,  &
                psnow, xtt, zwind, pzref, puref, pps, ghandle_sic,   &
                zqsat, psfth, psftq, zustar, zcd, zcdn, zch, zri,    &
                zresa_water, zz0h                                  )  
!
!-------------------------------------------------------------------------------------
!radiative properties at t
!-------------------------------------------------------------------------------------
!
iswb = SIZE(psw_bands)
!
DO jswb=1,iswb
     zdir_alb(:,jswb) = w%XDIR_ALB(:)
     zsca_alb(:,jswb) = w%XSCA_ALB(:)
END DO
!
zemis  = w%XEMIS
ztrad  = w%XTS
!
!-------------------------------------------------------------------------------------
!Specific fields for GELATO when using earth system model 
!(intermediate step before explicit sea and ice fluxes comutation)
!-------------------------------------------------------------------------------------
!
IF(lcpl_seaice)THEN   
  CALL coupling_iceflux_n(ki, pta, zexna, prhoa, w%XTICE, zexns,  &
                          zqa, prain, psnow, zwind, pzref, puref, &
                          pps, w%XTS, xtt, zsfth_ice, zsftq_ice     )  
ENDIF
!
!-------------------------------------------------------------------------------------
! Scalar fluxes:
!-------------------------------------------------------------------------------------
!
!
IF (chw%SVW%NBEQ>0) THEN
  !
  IF (chw%CCH_DRY_DEP == "WES89") THEN
    !
    ibeg = chw%SVW%NSV_CHSBEG
    iend = chw%SVW%NSV_CHSEND
    !
    CALL ch_dep_water  (zresa_water, zustar, pta, ztrad, psv(:,ibeg:iend), &
                        chw%SVW%CSV(ibeg:iend), chw%XDEP(:,1:chw%SVW%NBEQ) )  

    psfts(:,ibeg:iend) = - psv(:,ibeg:iend) * chw%XDEP(:,1:chw%SVW%NBEQ)  
    IF (chw%SVW%NAEREQ > 0 ) THEN
      ibeg = chw%SVW%NSV_AERBEG
      iend = chw%SVW%NSV_AEREND        
      !
      CALL ch_aer_dep(psv(:,ibeg:iend),psfts(:,ibeg:iend),zustar,zresa_water,pta,prhoa)     
    END IF
    !
  ELSE
    !
    ibeg = chw%SVW%NSV_AERBEG
    iend = chw%SVW%NSV_AEREND        
    !
    psfts(:,ibeg:iend) =0.
    IF(ibeg.LT.ibeg) psfts(:,ibeg:ibeg) =0.
    !
  ENDIF
  !
ENDIF
!
IF (chw%SVW%NDSTEQ>0) THEN
  !
  ibeg = chw%SVW%NSV_DSTBEG
  iend = chw%SVW%NSV_DSTEND
  !
  CALL dslt_dep(psv(:,ibeg:iend), psfts(:,ibeg:iend), zustar, zresa_water, pta, prhoa, &
                dst%XEMISSIG_DST, dst%XEMISRADIUS_DST, jpmode_dst, xdensity_dst, &
                xmolarweight_dst, zconvertfacm0_dst,  zconvertfacm6_dst, zconvertfacm3_dst, &
                lvarsig_dst, lrgfix_dst, cvermod  )  
  !
  CALL massflux2momentflux(         &
    psfts(:,ibeg:iend),             & !I/O ![kg/m2/sec] In: flux of only mass, out: flux of moments
    prhoa,                          & !I [kg/m3] air density
    dst%XEMISRADIUS_DST,                &!I [um] emitted radius for the modes (max 3)
    dst%XEMISSIG_DST,                   &!I [-] emitted sigma for the different modes (max 3)
    ndstmde,                        &
    zconvertfacm0_dst,              &
    zconvertfacm6_dst,              &
    zconvertfacm3_dst,              &
    lvarsig_dst, lrgfix_dst         )  
  !
ENDIF
!
IF (chw%SVW%NSLTEQ>0) THEN
  !
  ibeg = chw%SVW%NSV_SLTBEG
  iend = chw%SVW%NSV_SLTEND
  !     
  CALL dslt_dep(psv(:,ibeg:iend), psfts(:,ibeg:iend), zustar, zresa_water, pta, prhoa, &
                slt%XEMISSIG_SLT, slt%XEMISRADIUS_SLT, jpmode_slt, xdensity_slt, &
                xmolarweight_slt, zconvertfacm0_slt, zconvertfacm6_slt, zconvertfacm3_slt, &
                lvarsig_slt, lrgfix_slt, cvermod  )  

  CALL massflux2momentflux(         &
    psfts(:,ibeg:iend),             & !I/O ![kg/m2/sec] In: flux of only mass, out: flux of moments
    prhoa,                          & !I [kg/m3] air density
    slt%XEMISRADIUS_SLT,                &!I [um] emitted radius for the modes (max 3)
    slt%XEMISSIG_SLT,                   &!I [-] emitted sigma for the different modes (max 3)
    nsltmde,                        &
    zconvertfacm0_slt,              &
    zconvertfacm6_slt,              &
    zconvertfacm3_slt,              &
    lvarsig_slt, lrgfix_slt         ) 
  !
ENDIF
!
!-------------------------------------------------------------------------------------
! Outputs fluxes at time t+1
!-------------------------------------------------------------------------------------
!
! Momentum fluxes
!
IF(cimplicit_wind=='OLD')THEN
! old implicitation
  zustar2(:) = (zcd(:)*zwind(:)*ppew_b_coef(:)) /          &
               (1.0-prhoa(:)*zcd(:)*zwind(:)*ppew_a_coef(:))
ELSE
! new implicitation
  zustar2(:) = (zcd(:)*zwind(:)*(2.*ppew_b_coef(:)-zwind(:))) /&
               (1.0-2.0*prhoa(:)*zcd(:)*zwind(:)*ppew_a_coef(:))
!                   
  zwork(:) = prhoa(:)*ppew_a_coef(:)*zustar2(:) + ppew_b_coef(:)
  zwork(:) = max(zwork(:),0.)
!
  WHERE(ppew_a_coef(:)/= 0.)
        zustar2(:) = max( ( zwork(:) - ppew_b_coef(:) ) / (prhoa(:)*ppew_a_coef(:)), 0.)
  ENDWHERE
!              
ENDIF
!
psfu = 0.
psfv = 0.
WHERE (zwind(:)>0.)
  psfu(:) = - prhoa(:) * zustar2(:) * pu(:) / zwind(:)
  psfv(:) = - prhoa(:) * zustar2(:) * pv(:) / zwind(:)
END WHERE
!
! CO2 flux
!
psfco2(:)       =  0.0    ! Assumes no CO2 emission over water bodies
!
!-------------------------------------------------------------------------------------
! Inline diagnostics at time t for TS and TRAD
!-------------------------------------------------------------------------------------
!
 CALL diag_inline_watflux_n(dgo, d, dc, w, &
                            ptstep,pta, zqa, ppa, pps, prhoa, pu, pv, pzref,  &
                            puref, zcd, zcdn, zch, zri, zhu, zz0h, zqsat,     &
                            psfth, psftq, psfu, psfv, pdir_sw, psca_sw, plw,  &
                            zdir_alb, zsca_alb, zemis, ztrad, prain, psnow,   &
                            zsfth_ice, zsftq_ice                            )
!
!-------------------------------------------------------------------------------
! IMPOSED MONTHLY TS AT TIME t+1
!-------------------------------------------------------------------------------
!  
IF (w%LINTERPOL_TS.AND.mod(w%TTIME%TIME,xday) == 0.) THEN
   CALL interpol_ts_water_mth(w)
ENDIF
!
!-------------------------------------------------------------------------------
!Physical properties see by the atmosphere in order to close the energy budget 
!between surfex and the atmosphere. All variables should be at t+1 but very 
!difficult to do. Maybe it will be done later. However, Ts can be at time t+1
!-------------------------------------------------------------------------------
!
ptsurf(:) = w%XTS  (:)
pz0(:) = w%XZ0  (:)
pz0h(:) = zz0h(:)
pqsurf(:) = zqsat(:)
!
!-------------------------------------------------------------------------------------
!Radiative properties at time t+1 (see by the atmosphere) in order to close
!the energy budget between surfex and the atmosphere
!-------------------------------------------------------------------------------------
!
 CALL update_rad_water(w,pzenith2,xtt,pdir_alb,psca_alb,pemis,ptrad    )  
!
!=======================================================================================
!
IF (lhook) CALL dr_hook('COUPLING_WATFLUX_N',1,zhook_handle)
!
END SUBROUTINE coupling_watflux_n