update_esm_surf_atmn.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_surf_atm_n (F, IM, S, U, W, HPROGRAM, KI, KSW, PZENITH, PSW_BANDS,     &
                                   PTRAD, PDIR_ALB, PSCA_ALB, PEMIS, PTSURF )  
!     #################################################################################
!
!!****  *UPDATE_ESM_SURF_ATM_n * - Routine to update radiative properties in Earth
!!                                 System Model (SEA, WATER, NATURE, TOWN) after
!!                                 the call to OASIS coupler in order to close the
!!                                 energy budget between radiative scheme and surfex
!!
!!    PURPOSE
!!    -------
!
!!**  METHOD
!!    ------
!!
!!    REFERENCE
!!    ---------
!!      
!!
!!    AUTHOR
!!    ------
!!     B. Decharme 
!!
!!    MODIFICATIONS
!!    -------------
!!      Original    09/2009
!!      B. Decharme 06/2013 new coupling variables
!!-------------------------------------------------------------
!
!
USE modd_flake_n, ONLY : flake_t
USE modd_surfex_n, ONLY : isba_model_t
USE modd_seaflux_n, ONLY : seaflux_t
USE modd_surf_atm_n, ONLY : surf_atm_t
USE modd_watflux_n, ONLY : watflux_t
!
USE modd_surf_par,       ONLY : xundef
!
USE modd_data_cover_par, ONLY : ntilesfc
!
USE modi_average_rad
!
USE modi_average_tsurf
!
USE yomhook   ,ONLY : lhook,   dr_hook
USE parkind1  ,ONLY : jprb
!
USE modi_abor1_sfx
!
USE modi_update_esm_isba_n
USE modi_update_esm_seaflux_n
USE modi_update_esm_watflux_n
USE modi_update_esm_flake_n
!
IMPLICIT NONE
!
!*      0.1    declarations of arguments
!
!
TYPE(flake_t), INTENT(INOUT) :: F
TYPE(isba_model_t), INTENT(INOUT) :: IM
TYPE(seaflux_t), INTENT(INOUT) :: S
TYPE(surf_atm_t), INTENT(INOUT) :: U
TYPE(watflux_t), INTENT(INOUT) :: W
!
 CHARACTER(LEN=6),       INTENT(IN)  :: HPROGRAM  ! program calling surf. schemes
INTEGER,                INTENT(IN)  :: KI        ! number of points
INTEGER,                INTENT(IN)  :: KSW       ! number of short-wave spectral bands
REAL, DIMENSION(KI),     INTENT(IN) :: PZENITH   ! zenithal angle       (radian from the vertical)
REAL, DIMENSION(KSW),    INTENT(IN) :: PSW_BANDS ! mean wavelength of each shortwave band (m)
!
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)
!
!*      0.2    declarations of local variables
!
INTEGER :: JTILE                        ! loop on type of surface
LOGICAL :: GNATURE, GTOWN, GWATER, GSEA ! .T. if the corresponding surface is represented
!
! Tile outputs:
!
REAL, DIMENSION(KI,NTILESFC) :: ZTRAD_TILE     ! radiative surface temperature
REAL, DIMENSION(KI,NTILESFC) :: ZEMIS_TILE     ! emissivity
REAL, DIMENSION(KI,NTILESFC) :: ZFRAC_TILE     ! fraction of each surface type
REAL, DIMENSION(KI,NTILESFC) :: ZTSURF_TILE    ! surface effective temperature
!
REAL, DIMENSION(KI,KSW,NTILESFC) :: ZDIR_ALB_TILE ! direct albedo
REAL, DIMENSION(KI,KSW,NTILESFC) :: ZSCA_ALB_TILE ! diffuse albedo
!
REAL(KIND=JPRB) :: ZHOOK_HANDLE
!-------------------------------------------------------------------------------------
! Preliminaries: Tile related operations
!-------------------------------------------------------------------------------------
! FLAGS for the various surfaces:
!
IF (lhook) CALL dr_hook('UPDATE_ESM_SURF_ATM_N',0,zhook_handle)
gsea      = (u%NSIZE_SEA    >0 .AND. u%CSEA/='NONE')
gwater    = (u%NSIZE_WATER  >0 .AND. u%CWATER/='NONE')
gnature   = (u%NSIZE_NATURE >0 .AND. u%CNATURE/='NONE')
!
gtown     = u%NSIZE_TOWN   >0
IF(gtown)THEN
  CALL abor1_sfx('UPDATE_ESM_SURF_ATM_n: TOWN SCHEME NOT YET AVAILABLE FOR EARTH SYSTEM MODEL')
ENDIF
!
! Tile counter:
!
jtile     = 0 
!
! Initialization: Outputs to atmosphere over each tile:
!
ztrad_tile(:,:)       = xundef
zdir_alb_tile(:,:,:)  = xundef
zsca_alb_tile(:,:,:)  = xundef
zemis_tile(:,:)       = xundef
ztsurf_tile(:,:)      = xundef
!
! Fractions for each tile:
!
zfrac_tile(:,:)    = 0.0
!
!--------------------------------------------------------------------------------------
! Call arrange interfaces for sea, water, nature and town here...
!--------------------------------------------------------------------------------------
!
! - - - - - - - - - - - - - - - - - - - - - - - - - - - - - - - - - - - - - - - - - - - 
! SEA Tile calculations:
! - - - - - - - - - - - - - - - - - - - - - - - - - - - - - - - - - - - - - - - - - - - 
!
jtile = jtile + 1
!
IF(gsea)THEN
!
   zfrac_tile(:,jtile) = u%XSEA(:)
!
   CALL treat_surf(u%NSIZE_SEA,u%NR_SEA,jtile)   ! pack variables which are arguments to this routine
!
ENDIF
!
! - - - - - - - - - - - - - - - - - - - - - - - - - - - - - - - - - - - - - - - - - - - 
! INLAND WATER Tile calculations:
! - - - - - - - - - - - - - - - - - - - - - - - - - - - - - - - - - - - - - - - - - - - 
!
jtile = jtile + 1
!
IF(gwater)THEN
!
   zfrac_tile(:,jtile) = u%XWATER(:)
!
   CALL treat_surf(u%NSIZE_WATER,u%NR_WATER,jtile)  
!
ENDIF 
! - - - - - - - - - - - - - - - - - - - - - - - - - - - - - - - - - - - - - - - - - - - 
! NATURAL SURFACE Tile calculations:
! - - - - - - - - - - - - - - - - - - - - - - - - - - - - - - - - - - - - - - - - - - - 
!
jtile = jtile + 1
!
IF(gnature)THEN
!
   zfrac_tile(:,jtile) = u%XNATURE(:)
!
   CALL treat_surf(u%NSIZE_NATURE,u%NR_NATURE,jtile)
!   
ENDIF 
!
! - - - - - - - - - - - - - - - - - - - - - - - - - - - - - - - - - - - - - - - - - - - 
! URBAN Tile calculations:
! - - - - - - - - - - - - - - - - - - - - - - - - - - - - - - - - - - - - - - - - - - - 
! Not yet implemented
!
!JTILE = JTILE + 1
!
!IF(GTOWN)THEN
!
!   ZFRAC_TILE(:,JTILE) = XTOWN(:)
!
!   CALL TREAT_SURF(NSIZE_TOWN,NR_TOWN,JTILE)  
!
!ENDIF 
!
! - - - - - - - - - - - - - - - - - - - - - - - - - - - - - - - - - - - - - - - - - - - 
! Grid box average radiative properties:
! - - - - - - - - - - - - - - - - - - - - - - - - - - - - - - - - - - - - - - - - - - - 
!
 CALL average_rad(zfrac_tile,                                           &
                   zdir_alb_tile, zsca_alb_tile, zemis_tile, ztrad_tile, &
                   pdir_alb,      psca_alb,      pemis,      ptrad       )  
!
 CALL average_tsurf(zfrac_tile, ztsurf_tile, ptsurf)
!
! - - - - - - - - - - - - - - - - - - - - - - - - - - - - - - - - - - - - - - - - - - - 
!
IF (lhook) CALL dr_hook('UPDATE_ESM_SURF_ATM_N',1,zhook_handle)
CONTAINS
!=======================================================================================
SUBROUTINE treat_surf(KSIZE,KMASK,KTILE)
!
INTEGER, INTENT(IN)               :: KSIZE
INTEGER, INTENT(IN), DIMENSION(:) :: KMASK
INTEGER, INTENT(IN)               :: KTILE
!
REAL, DIMENSION(KSIZE) :: ZP_ZENITH   ! zenithal angle       (radian from the vertical)
!
REAL, DIMENSION(KSIZE)     :: ZP_TRAD     ! radiative temperature                 (K)
REAL, DIMENSION(KSIZE,KSW) :: ZP_DIR_ALB  ! direct albedo for each spectral band  (-)
REAL, DIMENSION(KSIZE,KSW) :: ZP_SCA_ALB  ! diffuse albedo for each spectral band (-)
REAL, DIMENSION(KSIZE)     :: ZP_EMIS     ! emissivity
REAL, DIMENSION(KSIZE)     :: ZP_TSURF    ! effective temperature                 (K)
!
INTEGER :: JJ
REAL(KIND=JPRB) :: ZHOOK_HANDLE
!
! input arguments:
!
IF (lhook) CALL dr_hook('UPDATE_ESM_SURF_ATM_N:TREAT_SURF',0,zhook_handle)
!
zp_trad    = xundef
zp_dir_alb = xundef
zp_sca_alb = xundef
zp_emis    = xundef
zp_tsurf   = xundef
!
DO jj=1,ksize
  zp_zenith(jj)     = pzenith(kmask(jj))
ENDDO
!
!
IF (ktile==1) THEN
  !
  IF (u%CSEA=='SEAFLX') THEN
    CALL update_esm_seaflux_n(s, u%NSIZE_SEA,ksw,zp_zenith,zp_dir_alb, &
                              zp_sca_alb,zp_emis,zp_trad,zp_tsurf )
  ELSE
    CALL abor1_sfx('UPDATE_ESM_SURF_ATM_n: SEA SCHEME MUST BE ACTIVATED FOR EARTH SYSTEM MODEL')
  ENDIF
  !
ELSEIF (ktile==2) THEN
  !
  IF (u%CWATER=='WATFLX') THEN   
    CALL update_esm_watflux_n(w, u%NSIZE_WATER,ksw,zp_zenith,zp_dir_alb, &
                              zp_sca_alb,zp_emis,zp_trad,zp_tsurf   )
  ELSEIF (u%CWATER=='FLAKE ') THEN
    CALL update_esm_flake_n(f, u%NSIZE_WATER,ksw,zp_zenith,zp_dir_alb, &
                            zp_sca_alb,zp_emis,zp_trad,zp_tsurf   )
  ELSE
    CALL abor1_sfx('UPDATE_ESM_SURF_ATM_n: INLAND WATER SCHEME MUST BE ACTIVATED FOR EARTH SYSTEM MODEL')
  ENDIF
  !
ELSEIF (ktile==3) THEN
  !          
  IF (u%CNATURE=='ISBA') THEN   
    CALL update_esm_isba_n(im%O, im%S, im%K, im%NK, im%NP, im%NPE, u%NSIZE_NATURE,&
                           ksw,zp_zenith,psw_bands,zp_dir_alb, &
                           zp_sca_alb,zp_emis,zp_trad,zp_tsurf              )
  ELSE
    CALL abor1_sfx('UPDATE_ESM_SURF_ATM_n: NATURE SCHEME MUST BE ACTIVATED FOR EARTH SYSTEM MODEL')
  ENDIF
  !
!ELSEIF (KTILE==4) THEN
!  !
!  IF (CTOWN=='TEB   ') THEN   
!    CALL UPDATE_ESM_TEB_n(NSIZE_SEA,KSW,ZP_ZENITH,ZP_TRAD,ZP_DIR_ALB,ZP_SCA_ALB,ZP_EMIS,ZP_TSURF)
!  ELSE
!    CALL ABOR1_SFX('UPDATE_ESM_SURF_ATM_n: TEB SCHEME MUST BE ACTIVATED FOR EARTH SYSTEM MODEL')
!  ENDIF
!  !        
ENDIF
!
DO jj=1,ksize
   ztrad_tile(kmask(jj),ktile)  = zp_trad(jj)
   zdir_alb_tile(kmask(jj),:,ktile)= zp_dir_alb(jj,:)
   zsca_alb_tile(kmask(jj),:,ktile)= zp_sca_alb(jj,:)
   zemis_tile(kmask(jj),ktile)  = zp_emis(jj)
   ztsurf_tile(kmask(jj),ktile)  = zp_tsurf(jj)
ENDDO
!
IF (lhook) CALL dr_hook('UPDATE_ESM_SURF_ATM_N:TREAT_SURF',1,zhook_handle)
!
END SUBROUTINE treat_surf
!=======================================================================================
!
END SUBROUTINE update_esm_surf_atm_n