diag_misc_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 diag_misc_isba_n (DMK, KK, PK, PEK, AGK, IO, OSURF_MISC_BUDGET, &
                             OVOLUMETRIC_SNOWLIQ, PTSTEP, OAGRIP, PTIME, KSIZE  )  
!     ###############################################################################
!
!!****  *DIAG_MISC-ISBA_n * - additional diagnostics for ISBA
!!
!!    PURPOSE
!!    -------
!
!!**  METHOD
!!    ------
!!
!!    REFERENCE
!!    ---------
!!      
!!
!!    AUTHOR
!!    ------
!!     P. Le Moigne 
!!
!!    MODIFICATIONS
!!    -------------
!!      Original    10/2004
!!      Modified    10/2004 by P. Le Moigne: Halstead coefficient
!!      B. Decharme   2008    Do not limit the SWI to 1
!!                            Add total SWI
!!      S. Lafont    03/2009 : change unit of carbon output in kg/m2/s
!!      A.L. Gibelin 04/2009 : Add respiration diagnostics
!!      A.L. Gibelin 07/2009 : Suppress RDK and transform GPP as a diagnostic
!!        S. Lafont  01/2011 : accumulate carbon variable between 2 outputs
!!       B. Decharme 05/2012 : Carbon fluxes in diag_evap
!!       B. Decharme 05/2012 : Active and frozen layers thickness for dif
!!       B. Decharme 06/2013 : Snow temp for EBA scheme (XP_SNOWTEMP not allocated)
!!
!!------------------------------------------------------------------
!
!
USE modd_diag_misc_isba_n, ONLY : diag_misc_isba_t
USE modd_isba_n, ONLY : isba_k_t, isba_p_t, isba_pe_t
USE modd_agri_n, ONLY : agri_t
USE modd_isba_options_n, ONLY : isba_options_t
!
USE modd_csts,       ONLY : xtt, xrholw
USE modd_surf_par,   ONLY : xundef
!
!                                     
USE modd_type_snow
!
USE modi_comput_cold_layers_thick
!
USE yomhook   ,ONLY : lhook,   dr_hook
USE parkind1  ,ONLY : jprb
!
IMPLICIT NONE
!
!*      0.1    declarations of arguments
!
TYPE(diag_misc_isba_t), INTENT(INOUT) :: DMK
TYPE(isba_k_t), INTENT(INOUT) :: KK
TYPE(isba_p_t), INTENT(INOUT) :: PK
TYPE(isba_pe_t), INTENT(INOUT) :: PEK
TYPE(agri_t), INTENT(INOUT) :: AGK
TYPE(isba_options_t), INTENT(INOUT) :: IO
!
LOGICAL, INTENT(IN) :: OSURF_MISC_BUDGET
LOGICAL, INTENT(IN) :: OVOLUMETRIC_SNOWLIQ
REAL,    INTENT(IN) :: PTSTEP        ! timestep for  accumulated values 
LOGICAL, INTENT(IN) :: OAGRIP
REAL,    INTENT(IN) :: PTIME   ! current time since midnight
INTEGER, INTENT(IN) :: KSIZE
!
!    
!*      0.2    declarations of local variables
!
REAL, DIMENSION(SIZE(PEK%XPSN))    :: ZSNOWTEMP
REAL, DIMENSION(SIZE(PEK%TSNOW%WSNOW,1),SIZE(PEK%TSNOW%WSNOW,2)) :: ZWORK
REAL, DIMENSION(SIZE(PEK%TSNOW%WSNOW,1),SIZE(PEK%TSNOW%WSNOW,2)) :: ZWORKTEMP
!
REAL, DIMENSION(KSIZE) :: ZALT, ZFLT
!
LOGICAL :: GMASK
INTEGER :: JL, JI, JK
REAL(KIND=JPRB) :: ZHOOK_HANDLE
!
!-------------------------------------------------------------------------------------
!
IF (lhook) CALL dr_hook('DIAG_MISC_ISBA_N',0,zhook_handle)
!
IF (osurf_misc_budget) THEN
  !
  dmk%XSWI (:,:)=xundef
  dmk%XTSWI(:,:)=xundef  
  DO jl=1,SIZE(pek%XWG,2)
    DO ji=1,SIZE(pek%XWG,1)
      IF(pek%XWG (ji,jl)/=xundef)THEN    
        dmk%XSWI (ji,jl) = (pek%XWG (ji,jl) - kk%XWWILT(ji,jl)) / (kk%XWFC(ji,jl) - kk%XWWILT(ji,jl))
        dmk%XTSWI(ji,jl) = (pek%XWG (ji,jl) - kk%XWWILT(ji,jl)) / (kk%XWFC(ji,jl) - kk%XWWILT(ji,jl))
      ENDIF
      IF(pek%XWGI (ji,jl)/=xundef)THEN    
        dmk%XTSWI(ji,jl) = dmk%XTSWI(ji,jl) +  pek%XWGI(ji,jl) / (kk%XWFC(ji,jl) - kk%XWWILT(ji,jl))
      ENDIF
    ENDDO
  ENDDO
  !
  DO jl = 1,SIZE(pek%TSNOW%WSNOW,2)
    DO ji = 1,SIZE(pek%TSNOW%WSNOW,1)
      zwork(ji,jl)  = pek%TSNOW%WSNOW(ji,jl) / pek%TSNOW%RHO(ji,jl)
    ENDDO
  ENDDO
  !
  dmk%XTWSNOW=0.
  dmk%XTDSNOW=0.
  zsnowtemp=0.  
  !
  IF (pek%TSNOW%SCHEME/='EBA')THEN
     zworktemp(:,:) = dmk%XSNOWTEMP(:,:)
  ELSE
     zworktemp(:,1) = min(pek%XTG(:,1),xtt)
  ENDIF
  !
  DO jl = 1,SIZE(pek%TSNOW%WSNOW,2)
    DO ji = 1,SIZE(pek%TSNOW%WSNOW,1)
      dmk%XTWSNOW(ji) = dmk%XTWSNOW(ji) + pek%TSNOW%WSNOW(ji,jl)      
      dmk%XTDSNOW(ji) = dmk%XTDSNOW(ji) + zwork(ji,jl)
      zsnowtemp(ji) = zsnowtemp(ji) + zworktemp(ji,jl) * zwork(ji,jl)
    ENDDO
  ENDDO
  !
  WHERE(dmk%XTDSNOW(:)>0.0)
        zsnowtemp(:)=zsnowtemp(:)/dmk%XTDSNOW(:)
  ELSEWHERE
        zsnowtemp(:)=xundef
  ENDWHERE
  !
  dmk%XPSNG  (:) = pek%XPSNG(:)
  dmk%XPSNV  (:) = pek%XPSNV(:)
  dmk%XPSN   (:) = pek%XPSN (:)
  dmk%XFF    (:) = kk%XFF   (:)
  dmk%XFFG   (:) = kk%XFFG  (:)
  dmk%XFFV   (:) = kk%XFFV  (:)
  dmk%XFSAT  (:) = kk%XFSAT (:)
  dmk%XTTSNOW(:) = zsnowtemp(:)
  !  
  IF ( (pek%TSNOW%SCHEME=='3-L' .OR. pek%TSNOW%SCHEME=='CRO') .AND. ovolumetric_snowliq ) THEN
    !
    WHERE (dmk%XSNOWLIQ(:,:)/=xundef) &
                    dmk%XSNOWLIQ(:,:) = dmk%XSNOWLIQ(:,:) * xrholw / dmk%XSNOWDZ(:,:)
    !
  ENDIF
  !
  ! cosine of solar zenith angle 
  !
  IF (io%CPHOTO/='NON'.AND.io%LTR_ML) THEN
       !
       ! Mask where vegetation evolution is performed (just before solar midnight)
       gmask = ( ptime - ptstep < 0. ) .AND. ( ptime >= 0. )
       IF (gmask) THEN
         DO ji=1,ksize
           !
           IF (pek%XMUS(ji).NE.0.) THEN
             dmk%XDFAPARC   (ji) = pek%XFAPARC   (ji) / pek%XMUS(ji) 
             dmk%XDFAPIRC   (ji) = pek%XFAPIRC   (ji) / pek%XMUS(ji)
             dmk%XDLAI_EFFC (ji) = pek%XLAI_EFFC (ji) / pek%XMUS(ji)
           ENDIF
           !
         ENDDO
         DO ji=1,ksize   
           pek%XFAPARC(ji)   = 0.
           pek%XFAPIRC(ji)   = 0.
           pek%XLAI_EFFC(ji) = 0.
           pek%XMUS(ji)      = 0.
         ENDDO
       ENDIF
       !
  ENDIF
  !
  IF(io%CISBA=='DIF')THEN
    zalt(:)=0.0
    zflt(:)=0.0
    CALL comput_cold_layers_thick(pk%XDG(:,:),pek%XTG(:,:),zalt,zflt)
    DO ji=1,ksize
      dmk%XALT(ji) =  zalt(ji) 
      dmk%XFLT(ji) =  zflt(ji)  
    ENDDO
  ENDIF
  !
END IF
!
IF (oagrip) THEN
  !
  DO ji=1,ksize
    dmk%XSEUIL   (ji)  =  agk%XTHRESHOLDSPT (ji)
  END DO
!
END IF
IF (lhook) CALL dr_hook('DIAG_MISC_ISBA_N',1,zhook_handle)
!-------------------------------------------------------------------------------------
!
END SUBROUTINE diag_misc_isba_n