average_diag.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 average_diag(PFRAC_TILE, DGO, D, ND, DC, NDC      )                                
!     ######################################################################
!
!
!!****  *AVERAGE_DIAG*  
!!
!!    PURPOSE
!!    -------
!      Average the fluxes from the land and water surfaces depending on the
!      fraction of each surface cover type in the mesh area.
!     
!!**  METHOD
!!    ------
!
!!    EXTERNAL
!!    --------
!!
!!    IMPLICIT ARGUMENTS
!!    ------------------ 
!!
!!      
!!    REFERENCE
!!    ---------
!!      
!!    AUTHOR
!!    ------
!!    V. Masson * Meteo-France-
!!
!!    MODIFICATIONS
!!    -------------
!!      Original    06/2003
!!      Modified    08/2009 (B. Decharme) : new diag
!     02/2010 - S. Riette - Security for wind average in case of XUNDEF values
!       B. decharme 04/2013 : Add EVAP and SUBL diag
!-------------------------------------------------------------------------------
!
!*       0.     DECLARATIONS
!               ------------
!
USE modd_data_cover_par, ONLY : ntilesfc
!
USE modd_diag_n, ONLY : diag_t, diag_np_t, diag_options_t
!
USE yomhook   ,ONLY : lhook,   dr_hook
USE parkind1  ,ONLY : jprb
!
IMPLICIT NONE
!
!*      0.1    declarations of arguments
!
REAL, DIMENSION(:,:), INTENT(IN) :: PFRAC_TILE   ! Fraction in a mesh-area of 
!
TYPE(diag_options_t), INTENt(INOUT) :: DGO
TYPE(diag_t), INTENT(INOUT) :: D
TYPE(diag_np_t), INTENT(INOUT) :: ND
TYPE(diag_t), INTENT(INOUT) :: DC
TYPE(diag_np_t), INTENT(INOUT) :: NDC
!
!*      0.2    declarations of local variables
!
REAL, DIMENSION(SIZE(PFRAC_TILE,1))    :: ZLAND, ZSEA, ZFRL
INTEGER :: JT
REAL(KIND=JPRB) :: ZHOOK_HANDLE
!-------------------------------------------------------------------------------
!
!       1.     Grid-Box average fluxes
!              -----------------------
!
IF (lhook) CALL dr_hook('AVERAGE_DIAG',0,zhook_handle)
!
IF (dgo%LSURF_BUDGET) THEN
!
  DO jt = 1,ntilesfc
  !
  ! Net radiation
  !
  CALL make_average(pfrac_tile(:,jt),nd%AL(jt)%XRN,d%XRN,jt)
!
! Sensible heat flux
!
  CALL make_average(pfrac_tile(:,jt),nd%AL(jt)%XH,d%XH,jt)
!
! Total latent heat flux
!
  CALL make_average(pfrac_tile(:,jt),nd%AL(jt)%XLE,d%XLE,jt)
!
! Sublimation latent heat flux
!
  CALL make_average(pfrac_tile(:,jt),nd%AL(jt)%XLEI,d%XLEI,jt)
!
! Total evapotranspiration
!
  CALL make_average(pfrac_tile(:,jt),nd%AL(jt)%XEVAP,d%XEVAP,jt)
!
! Sublimation
!
  CALL make_average(pfrac_tile(:,jt),nd%AL(jt)%XSUBL,d%XSUBL,jt)
!
! Storage flux
!
  CALL make_average(pfrac_tile(:,jt),nd%AL(jt)%XGFLUX,d%XGFLUX,jt)
!
! Downwards short wave radiation
!
  CALL make_average(pfrac_tile(:,jt),nd%AL(jt)%XSWD,d%XSWD,jt)
!
! Upwards short wave radiation
!
  CALL make_average(pfrac_tile(:,jt),nd%AL(jt)%XSWU,d%XSWU,jt)
!
! Downwards long wave radiation
!
  CALL make_average(pfrac_tile(:,jt),nd%AL(jt)%XLWD,d%XLWD,jt)
!
! Upwards long wave radiation
!
  CALL make_average(pfrac_tile(:,jt),nd%AL(jt)%XLWU,d%XLWU,jt)
!
! Zonal wind stress
!
  CALL make_average(pfrac_tile(:,jt),nd%AL(jt)%XFMU,d%XFMU,jt)
!
! Meridian wind stress
!
  CALL make_average(pfrac_tile(:,jt),nd%AL(jt)%XFMV,d%XFMV,jt)
!
! Downwards short wave radiation for each spectral band
!
  CALL make_average_2d(pfrac_tile(:,jt),nd%AL(jt)%XSWBD,d%XSWBD,jt)
!
! Upwards short wave radiation for each spectral band
!
  CALL make_average_2d(pfrac_tile(:,jt),nd%AL(jt)%XSWBU,d%XSWBU,jt)
!
  ENDDO
  !
END IF
!
IF (dgo%LSURF_BUDGETC) THEN
!
  DO jt = 1,ntilesfc
  !
! Net radiation
!
  CALL make_average(pfrac_tile(:,jt),ndc%AL(jt)%XRN,dc%XRN,jt)
!
! Sensible heat flux
!
  CALL make_average(pfrac_tile(:,jt),ndc%AL(jt)%XH,dc%XH,jt)
!
! Total latent heat flux
!
  CALL make_average(pfrac_tile(:,jt),ndc%AL(jt)%XLE,dc%XLE,jt)
!
! Sublimation latent heat flux
!
  CALL make_average(pfrac_tile(:,jt),ndc%AL(jt)%XLEI,dc%XLEI,jt)
!
! Storage flux
!
  CALL make_average(pfrac_tile(:,jt),ndc%AL(jt)%XGFLUX,dc%XGFLUX,jt)
!
! Total evapotranspiration
!
  CALL make_average(pfrac_tile(:,jt),ndc%AL(jt)%XEVAP,dc%XEVAP,jt)
!
! Sublimation
!
  CALL make_average(pfrac_tile(:,jt),ndc%AL(jt)%XSUBL,dc%XSUBL,jt)
!
! Downwards short wave radiation
!
  CALL make_average(pfrac_tile(:,jt),ndc%AL(jt)%XSWD,dc%XSWD,jt)
!
! Upwards short wave radiation
!
  CALL make_average(pfrac_tile(:,jt),ndc%AL(jt)%XSWU,dc%XSWU,jt)
!
! Downwards long wave radiation
!
  CALL make_average(pfrac_tile(:,jt),ndc%AL(jt)%XLWD,dc%XLWD,jt)
!
! Upwards long wave radiation
!
  CALL make_average(pfrac_tile(:,jt),ndc%AL(jt)%XLWU,dc%XLWU,jt)
!
! Zonal wind stress
!
  CALL make_average(pfrac_tile(:,jt),ndc%AL(jt)%XFMU,dc%XFMU,jt)
!
! Meridian wind stress
!
  CALL make_average(pfrac_tile(:,jt),ndc%AL(jt)%XFMV,dc%XFMV,jt)
!
  ENDDO
  !
END IF
!
!-------------------------------------------------------------------------------
!
!       2.     Richardson number
!              -----------------
!
IF (dgo%N2M>=1) THEN
!
  DO jt = 1,ntilesfc
    !
    CALL make_average(pfrac_tile(:,jt),nd%AL(jt)%XRI,d%XRI,jt)
    !
  ENDDO
!
ENDIF
!
!-------------------------------------------------------------------------------
!
!       3.     Operational parameters at surface, 2 and 10 meters
!              --------------------------------------------------
!
!
IF (dgo%N2M>=1.OR.dgo%LSURF_BUDGET.OR.dgo%LSURF_BUDGETC) THEN
!
  DO jt = 1,ntilesfc
    !
! Surface temperature
!
    CALL make_average(pfrac_tile(:,jt),nd%AL(jt)%XTS,d%XTS,jt)
!
  ENDDO
  !
ENDIF
!
IF (dgo%N2M>=1) THEN
!
! Temperature at 2 meters
!
  IF (dgo%LT2MMW) THEN
    DO jt=1,ntilesfc
! Modified weighting giving increased weight to LAND temperature
      CALL  make_average_mw(pfrac_tile(:,jt),nd%AL(jt)%XT2M,d%XT2M,jt,zland,zsea,zfrl)
    ENDDO
    DO jt=1,ntilesfc
      CALL make_average_mw(pfrac_tile(:,jt),nd%AL(jt)%XT2M_MIN,d%XT2M_MIN,jt,zland,zsea,zfrl)
    ENDDO
    DO jt=1,ntilesfc      
      CALL make_average_mw(pfrac_tile(:,jt),nd%AL(jt)%XT2M_MAX,d%XT2M_MAX,jt,zland,zsea,zfrl)
    ENDDO
  ELSE
    DO jt=1,ntilesfc
      CALL make_average(pfrac_tile(:,jt),nd%AL(jt)%XT2M,d%XT2M,jt)
      CALL make_average(pfrac_tile(:,jt),nd%AL(jt)%XT2M_MIN,d%XT2M_MIN,jt)
      CALL make_average(pfrac_tile(:,jt),nd%AL(jt)%XT2M_MAX,d%XT2M_MAX,jt)
    ENDDO
  ENDIF
!
  DO jt=1,ntilesfc
! Relative humidity at 2 meters
!
  CALL make_average(pfrac_tile(:,jt),nd%AL(jt)%XHU2M,d%XHU2M,jt)
  CALL make_average(pfrac_tile(:,jt),nd%AL(jt)%XHU2M_MIN,d%XHU2M_MIN,jt)
  CALL make_average(pfrac_tile(:,jt),nd%AL(jt)%XHU2M_MAX,d%XHU2M_MAX,jt)
!
! Specific humidity at 2 meters
!
  CALL make_average(pfrac_tile(:,jt),nd%AL(jt)%XQ2M,d%XQ2M,jt)
!
! Wind at 10 meters
!
  CALL make_average(pfrac_tile(:,jt),nd%AL(jt)%XZON10M,d%XZON10M,jt)
!
  CALL make_average(pfrac_tile(:,jt),nd%AL(jt)%XMER10M,d%XMER10M,jt)
!
  CALL make_average(pfrac_tile(:,jt),nd%AL(jt)%XWIND10M,d%XWIND10M,jt)
  CALL make_average(pfrac_tile(:,jt),nd%AL(jt)%XWIND10M_MAX,d%XWIND10M_MAX,jt)
!
  ENDDO
  !
END IF
!-------------------------------------------------------------------------------
!
!       4.     Transfer coeffients and roughness lengths
!              -----------------------------------------
!
IF (dgo%LCOEF) THEN
!
  DO jt=1,ntilesfc
  !
  CALL make_average(pfrac_tile(:,jt),nd%AL(jt)%XCD,d%XCD,jt)
!
  CALL make_average(pfrac_tile(:,jt),nd%AL(jt)%XCH,d%XCH,jt)
!
  CALL make_average(pfrac_tile(:,jt),nd%AL(jt)%XCE,d%XCE,jt)
!
  CALL make_average_z0(pfrac_tile(:,jt),d%XUREF,nd%AL(jt)%XZ0,d%XZ0,jt)
!
  CALL make_average_z0(pfrac_tile(:,jt),d%XZREF,nd%AL(jt)%XZ0H,d%XZ0H,jt)
!
  ENDDO
  !
ENDIF
!
IF (dgo%LSURF_VARS) THEN
!
  DO jt=1,ntilesfc
    CALL make_average(pfrac_tile(:,jt),nd%AL(jt)%XQS,d%XQS,jt)
  ENDDO
!
ENDIF
!
IF (lhook) CALL dr_hook('AVERAGE_DIAG',1,zhook_handle)
!
CONTAINS
!
SUBROUTINE make_average(PFRAC,PFIELD_IN,PFIELD_OUT,KTILE)
!
USE modd_surf_par, ONLY : xundef
!
IMPLICIT NONE
!
REAL, DIMENSION(:),INTENT(IN)   :: PFRAC
REAL, DIMENSION(:),INTENT(IN)   :: PFIELD_IN
REAL, DIMENSION(:), INTENT(OUT) :: PFIELD_OUT
INTEGER, INTENT(IN) :: KTILE
REAL(KIND=JPRB) :: ZHOOK_HANDLE
INTEGER :: JT
!
IF (lhook) CALL dr_hook('AVERAGE_DIAG:MAKE_AVERAGE',0,zhook_handle)
!
IF (ktile==1) pfield_out(:) = 0.
!
WHERE (pfield_in(:)==xundef .AND. pfrac(:)/=0.) pfield_out(:) = xundef
!
WHERE (pfield_out(:)/=xundef) 
  pfield_out(:) = pfield_out(:) + pfrac(:) * pfield_in(:)
END WHERE
!
IF (lhook) CALL dr_hook('AVERAGE_DIAG:MAKE_AVERAGE',1,zhook_handle)
!
END SUBROUTINE make_average
!
SUBROUTINE make_average_2d(PFRAC,PFIELD_IN,PFIELD_OUT,KTILE)
!
USE modd_surf_par, ONLY : xundef
!
IMPLICIT NONE
!
REAL, DIMENSION(:),INTENT(IN)   :: PFRAC
REAL, DIMENSION(:,:),INTENT(IN)   :: PFIELD_IN
REAL, DIMENSION(:,:), INTENT(OUT) :: PFIELD_OUT
INTEGER, INTENT(IN) :: KTILE
REAL(KIND=JPRB) :: ZHOOK_HANDLE
INTEGER :: JT, JL
!
IF (lhook) CALL dr_hook('AVERAGE_DIAG:MAKE_AVERAGE_2D',0,zhook_handle)
!
IF (ktile==1) pfield_out(:,:) = 0.
!
DO jl=1,SIZE(pfield_in,2)
  WHERE (pfield_in(:,jl)==xundef .AND. pfrac(:)/=0.) pfield_out(:,jl) = xundef
  WHERE(pfield_out(:,jl)/=xundef)
    pfield_out(:,jl) = pfield_out(:,jl) + pfrac(:) * pfield_in(:,jl)
  END WHERE
END DO
!
IF (lhook) CALL dr_hook('AVERAGE_DIAG:MAKE_AVERAGE_2D',1,zhook_handle)
!
END SUBROUTINE make_average_2d
!
SUBROUTINE make_average_z0(PFRAC,PREF,PFIELD_IN,PFIELD_OUT,KTILE)
!
USE modd_surf_par, ONLY : xundef
!
IMPLICIT NONE
!
REAL, DIMENSION(:),INTENT(IN)   :: PFRAC
REAL, DIMENSION(:),INTENT(IN)   :: PFIELD_IN
REAL, DIMENSION(:),INTENT(IN)   :: PREF
REAL, DIMENSION(:), INTENT(OUT) :: PFIELD_OUT
INTEGER, INTENT(IN) :: KTILE
REAL(KIND=JPRB) :: ZHOOK_HANDLE
!
IF (lhook) CALL dr_hook('AVERAGE_DIAG:MAKE_AVERAGE_Z0',0,zhook_handle)
!
IF (ktile==1) pfield_out(:) = 0.
!
WHERE (pfield_in(:)==xundef .AND. pfrac(:)/=0.) pfield_out(:) = xundef
!
WHERE (pfield_out(:)/=xundef) 
  pfield_out(:) = pfield_out(:) + pfrac(:) * 1./(log(pref(:)/pfield_in(:)))**2
END WHERE
!
IF (ktile==ntilesfc) THEN
  WHERE (pfield_out(:) == 0.)
    pfield_out(:) = xundef
  ELSEWHERE (pfield_out(:)/=xundef)
    pfield_out(:) = pref(:) * exp( - sqrt(1./pfield_out(:)) )
  ENDWHERE
ENDIF
!
IF (lhook) CALL dr_hook('AVERAGE_DIAG:MAKE_AVERAGE_Z0',1,zhook_handle)
!
END SUBROUTINE make_average_z0
!
SUBROUTINE make_average_mw(PFRAC,PFIELD_IN,PFIELD_OUT,KTILE,PLAND,PSEA,PFRL)
!
USE modd_surf_par, ONLY : xundef
!
IMPLICIT NONE
!
REAL, DIMENSION(:),INTENT(IN)   :: PFRAC
REAL, DIMENSION(:),INTENT(IN)   :: PFIELD_IN
REAL, DIMENSION(:),  INTENT(OUT)  :: PFIELD_OUT
INTEGER, INTENT(IN) :: KTILE
REAL, DIMENSION(:), INTENT(INOUT) :: PLAND
REAL, DIMENSION(:), INTENT(INOUT) :: PSEA
REAL, DIMENSION(:), INTENT(INOUT) :: PFRL
REAL(KIND=JPRB) :: ZHOOK_HANDLE
INTEGER :: JT
REAL, DIMENSION(SIZE(PFIELD_IN))    :: ZALFA
!
IF (lhook) CALL dr_hook('AVERAGE_DIAG:MAKE_AVERAGE_MW',0,zhook_handle)
!
IF (ktile==1) THEN
  pfield_out(:) = 0.
  psea(:)= 0.
  pland(:)= 0.
  pfrl(:)= 0.
ENDIF
!
WHERE (pfield_in(:)==xundef .AND. pfrac(:)/=0.) pfield_out(:) = xundef
!
IF (ktile==1.OR.ktile==2) THEN
  psea(:) = psea(:)  + pfrac(:) * pfield_in(:)
ENDIF
!
IF (ktile==3.OR.ktile==4) THEN
  pland(:) = pland(:) + pfrac(:) * pfield_in(:)
  pfrl(:) = pfrl(:) + pfrac(:)
ENDIF
! 
IF (ktile==4) THEN
  WHERE(zfrl(:)>0.)
    zland(:) = zland(:)/zfrl(:)
  ENDWHERE
  WHERE(zfrl(:)<1.)
    zsea(:) = zsea(:)/(1.-zfrl(:))
  ENDWHERE
  !
  zalfa(:) = 1. - exp(-10.*zfrl(:))
  !
  WHERE (pfield_out(:)/=xundef) 
    pfield_out(:) = zalfa(:) * zland(:) + (1. - zalfa(:)) * zsea(:)
  END WHERE
  !
ENDIF
!
IF (lhook) CALL dr_hook('AVERAGE_DIAG:MAKE_AVERAGE_MW',1,zhook_handle)
!
END SUBROUTINE make_average_mw
!
!-------------------------------------------------------------------------------
!
END SUBROUTINE average_diag