update_esm_isban.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 update_esm_isba_n (IO, S, K, NK, NP, NPE, KI,KSW,PZENITH,PSW_BANDS,PDIR_ALB,& 
                                   PSCA_ALB,PEMIS,PTSRAD,PTSURF      )
!     ################################################################
!
!!****  *UPDATE_ESM_ISBA_n* - update ISBA radiative and physical properties in Earth System Model 
!!                            after the call to OASIS coupler in order 
!!                            to close the energy budget between radiative scheme and surfex
!!
!!
!!    PURPOSE
!!    -------
!!
!!**  METHOD
!!    ------
!!
!!    EXTERNAL
!!    --------
!!
!!
!!    IMPLICIT ARGUMENTS
!!    ------------------
!!
!!    REFERENCE
!!    ---------
!!
!!
!!    AUTHOR
!!    ------
!!     B. Decharme 
!!
!!    MODIFICATIONS
!!    -------------
!!      Original    09/2009
!!      B. Decharme 06/2013 new coupling variables
!!      P. Samuelsson 10/2014 MEB
!-------------------------------------------------------------------------------
!
!*       0.    DECLARATIONS
!              ------------
!
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, isba_nk_t, &
                        isba_np_t, isba_npe_t
!
USE modd_type_snow
USE modd_surf_par, ONLY : xundef
!
USE modi_average_rad
USE modi_average_tsurf
USE modi_update_rad_isba_n
!
!
USE yomhook   ,ONLY : lhook,   dr_hook
USE parkind1  ,ONLY : jprb
!
IMPLICIT NONE
!
!*       0.1   Declarations of arguments
!              -------------------------
!
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
!
INTEGER,                            INTENT(IN)  :: KI        ! number of points
INTEGER,                            INTENT(IN)  :: KSW       ! number of short-wave spectral bands
!
REAL,             DIMENSION(KI),    INTENT(IN)  :: PZENITH   ! solar zenithal angle
REAL,             DIMENSION(KSW),   INTENT(IN)  :: PSW_BANDS ! short-wave spectral bands
!
REAL,             DIMENSION(KI,KSW),INTENT(OUT) :: PDIR_ALB  ! direct albedo for each band
REAL,             DIMENSION(KI,KSW),INTENT(OUT) :: PSCA_ALB  ! diffuse albedo for each band
REAL,             DIMENSION(KI),    INTENT(OUT) :: PEMIS     ! emissivity
REAL,             DIMENSION(KI),    INTENT(OUT) :: PTSRAD    ! radiative temperature
REAL,             DIMENSION(KI),    INTENT(OUT) :: PTSURF    ! surface effective temperature         (K)
!
!
!*       0.2   Declarations of local variables
!              -------------------------------
!
TYPE(isba_k_t), POINTER :: KK
TYPE(isba_p_t), POINTER :: PK
TYPE(isba_pe_t), POINTER :: PEK
!
REAL, DIMENSION(KI,KSW,IO%NPATCH) :: ZDIR_ALB_PATCH
REAL, DIMENSION(KI,KSW,IO%NPATCH) :: ZSCA_ALB_PATCH
REAL, DIMENSION(KI,IO%NPATCH)     :: ZEMIS_PATCH
REAL, DIMENSION(KI,IO%NPATCH)     :: ZTSRAD_PATCH
REAL, DIMENSION(KI,IO%NPATCH)     :: ZTSURF_PATCH
REAL, DIMENSION(KI,IO%NPATCH)     :: ZEMIS          ! emissivity with flood
!
LOGICAL :: LEXPLICIT_SNOW ! snow scheme key
!
INTEGER :: IMASK, JI, JP
!
REAL(KIND=JPRB) :: ZHOOK_HANDLE
!
!-------------------------------------------------------------------------------
!
!*       1.     Defaults
!               --------
!
IF (lhook) CALL dr_hook('UPDATE_ESM_ISBA_N',0,zhook_handle)
!
zdir_alb_patch(:,:,:) = 0.0
zsca_alb_patch(:,:,:) = 0.0
zemis_patch(:,:  ) = 0.0
!
lexplicit_snow = (npe%AL(1)%TSNOW%SCHEME=='3-L'.OR.npe%AL(1)%TSNOW%SCHEME=='CRO')
!
!
!
!*       2.     Update nature albedo and emissivity
!               -----------------------------------
!
zemis(:,:) = 0.0
ztsrad_patch(:,:) = 0.0
ztsurf_patch(:,:) = 0.0
!
DO jp = 1,io%NPATCH
  pk => np%AL(jp)
  pek => npe%AL(jp)
  kk => nk%AL(jp)

  CALL update_rad_isba_n(io, s, kk, pk, pek, jp, pzenith, psw_bands, &
                        zdir_alb_patch(:,:,jp),zsca_alb_patch(:,:,jp),zemis_patch(:,jp)  )
  !
  !*       3.     radiative surface temperature
  !               -----------------------------
  !
  DO ji = 1,pk%NSIZE_P
    imask = pk%NR_P(ji)

    zemis(imask,jp) = pek%XEMIS(ji)

    IF(lexplicit_snow.AND.io%LFLOOD)THEN
      IF (pek%XPSN(ji)<1.0.AND.pek%XEMIS(ji)/=xundef) THEN
        zemis(imask,jp) = ((1.-kk%XFF(ji)-pek%XPSN(ji))*pek%XEMIS(ji) + &
                           kk%XFF(ji)*kk%XEMISF(ji)) / (1.-pek%XPSN(ji))
      ENDIF
    ENDIF
    !
    ztsrad_patch(imask,jp) = pek%XTG(ji,1)
    ztsurf_patch(imask,jp) = pek%XTG(ji,1)
    !
    IF(lexplicit_snow)THEN
      IF(pek%XEMIS(ji)/=xundef.AND.zemis_patch(imask,jp)/=0.) THEN
        ztsrad_patch(imask,jp) = ( ( (1.-pek%XPSN(ji))*zemis(imask,jp)*pek%XTG(ji,1)**4     &
                               +  pek%XPSN(ji) *pek%TSNOW%EMIS(ji)*pek%TSNOW%TS(ji)**4 )   &
                             / zemis_patch(imask,jp) )**0.25     
      ENDIF
      ztsurf_patch(imask,jp) = pek%XTG(ji,1)*(1.-pek%XPSN(ji)) + pek%TSNOW%TS(ji)*pek%XPSN(ji)

    ENDIF
    !
  ENDDO    
  !
ENDDO
!
!*       4.     averaged fields
!               ---------------
!
 CALL average_rad(s%XPATCH,                                                   &
                   zdir_alb_patch, zsca_alb_patch, zemis_patch, ztsrad_patch, &
                   pdir_alb,       psca_alb,       s%XEMIS_NAT,   s%XTSRAD_NAT    )  
!
pemis = s%XEMIS_NAT
ptsrad = s%XTSRAD_NAT
!
!* averaged effective temperature
!
!
 CALL average_tsurf(s%XPATCH, ztsurf_patch, ptsurf)
!
IF (lhook) CALL dr_hook('UPDATE_ESM_ISBA_N',1,zhook_handle)
!
!-------------------------------------------------------------------------------
!
END SUBROUTINE update_esm_isba_n