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 (DGMI, PKDI, &
                             ptstep, hisba, hphoto, hsnow, oagrip, otr_ml, &
                            ptime, ksize, kpatch, kmask, pseuil,          &
                            ppsn, ppsng, ppsnv, pff, pffg, pffv,          &
                            pwg, pwgi, pwfc, pwwilt, pwsnow, prsnow,      &
                            pfaparc, pfapirc, plai_effc, pmus, pfsat,     &
                            pdg, ptg                                      )  
!     ###############################################################################
!
!!****  *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_pack_diag_isba, ONLY : pack_diag_isba_t
!
USE modd_csts,       ONLY : xtt
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) :: dgmi
TYPE(pack_diag_isba_t), INTENT(INOUT) :: pkdi
!
REAL,               INTENT(IN)    :: ptstep        ! timestep for  accumulated values 
 CHARACTER(LEN=*), INTENT(IN)      :: hisba         ! ISBA scheme
 CHARACTER(LEN=*), INTENT(IN)      :: hphoto        ! type of photosynthesis
 CHARACTER(LEN=*), INTENT(IN)      :: hsnow         ! snow scheme
LOGICAL, INTENT(IN)               :: oagrip
LOGICAL, INTENT(IN)               :: otr_ml
REAL,    INTENT(IN)               :: ptime   ! current time since midnight
INTEGER, INTENT(IN)               :: ksize, kpatch
INTEGER, DIMENSION(:), INTENT(IN) :: kmask
REAL, DIMENSION(:), INTENT(IN)    :: pseuil
!    
!Snow/flood fraction at t
REAL, DIMENSION(:), INTENT(IN)    :: ppsn
REAL, DIMENSION(:), INTENT(IN)    :: ppsng
REAL, DIMENSION(:), INTENT(IN)    :: ppsnv
REAL, DIMENSION(:), INTENT(IN)    :: pff
REAL, DIMENSION(:), INTENT(IN)    :: pffg
REAL, DIMENSION(:), INTENT(IN)    :: pffv
!
REAL, DIMENSION(:,:),  INTENT(IN) :: pwg           ! soil water content profile (m3/m3)
REAL, DIMENSION(:,:),  INTENT(IN) :: pwgi          ! soil solid water content profile (m3/m3)
REAL, DIMENSION(:,:),  INTENT(IN) :: pwfc          ! field capacity profile (m3/m3)
REAL, DIMENSION(:,:),  INTENT(IN) :: pwwilt        ! wilting point  profile (m3/m3)
REAL, DIMENSION(:,:),  INTENT(IN) :: pwsnow        ! snow reservoir (kg/m2)
REAL, DIMENSION(:,:),  INTENT(IN) :: prsnow        ! snow density (kg/m3)
!
REAL, DIMENSION(:,:),  INTENT(IN) :: pdg           ! soil layer depth
REAL, DIMENSION(:,:),  INTENT(IN) :: ptg           ! soil temperature
!
REAL, DIMENSION(:), INTENT(INOUT) :: pfaparc
REAL, DIMENSION(:), INTENT(INOUT) :: pfapirc
REAL, DIMENSION(:), INTENT(INOUT) :: plai_effc
REAL, DIMENSION(:), INTENT(INOUT) :: pmus
!
REAL, DIMENSION(:), INTENT(IN)    :: pfsat
!
!*      0.2    declarations of local variables
!
REAL, DIMENSION(SIZE(PPSN))    :: zsnowtemp
REAL, DIMENSION(SIZE(PWSNOW,1),SIZE(PWSNOW,2)) :: zwork
REAL, DIMENSION(SIZE(PWSNOW,1),SIZE(PWSNOW,2)) :: zworktemp
!
REAL, DIMENSION(KSIZE) :: zalt, zflt
!
LOGICAL :: gmask
INTEGER :: jj, ji, jk
REAL(KIND=JPRB) :: zhook_handle
!
!-------------------------------------------------------------------------------------
!
IF (lhook) CALL dr_hook('DIAG_MISC_ISBA_N',0,zhook_handle)
!
IF (dgmi%LSURF_MISC_BUDGET) THEN
  !
  pkdi%XP_SWI (:,:)=xundef
  pkdi%XP_TSWI(:,:)=xundef  
  DO jj=1,SIZE(pwg,2)
    DO ji=1,SIZE(pwg,1)
      IF(pwg(ji,jj)/=xundef)THEN    
        pkdi%XP_SWI (ji,jj) = (pwg(ji,jj) - pwwilt(ji,jj)) / (pwfc(ji,jj) - pwwilt(ji,jj))
        pkdi%XP_TSWI(ji,jj) = (pwg(ji,jj) - pwwilt(ji,jj)) / (pwfc(ji,jj) - pwwilt(ji,jj))
      ENDIF
      IF(pwgi(ji,jj)/=xundef)THEN    
        pkdi%XP_TSWI(ji,jj) = pkdi%XP_TSWI(ji,jj) +  pwgi(ji,jj) / (pwfc(ji,jj) - pwwilt(ji,jj))
      ENDIF
    ENDDO
  ENDDO
  !
  DO jk=1,SIZE(pkdi%XP_SWI,2)
!cdir nodep
    DO jj=1,ksize
      ji                      =  kmask(jj)
      !
      dgmi%XSWI     (ji,jk,kpatch)  =  pkdi%XP_SWI        (jj,jk)
      dgmi%XTSWI    (ji,jk,kpatch)  =  pkdi%XP_TSWI       (jj,jk)
      !
    END DO
  ENDDO  
  !
  DO ji = 1,SIZE(pwsnow,2)
!cdir nodep 
    DO jj = 1,SIZE(pwsnow,1)
      zwork(jj,ji)  = pwsnow(jj,ji) / prsnow(jj,ji)
    ENDDO
  ENDDO
  !
  pkdi%XP_TWSNOW=0.
  pkdi%XP_TDSNOW=0.
  zsnowtemp=0.  
  !
  IF (hsnow/='EBA')THEN
     zworktemp(:,:) = pkdi%XP_SNOWTEMP(:,:)
  ELSE
     zworktemp(:,1) = min(ptg(:,1),xtt)
  ENDIF
  !
  DO ji = 1,SIZE(pwsnow,2)
!cdir nodep 
    DO jj = 1,SIZE(pwsnow,1)
      pkdi%XP_TWSNOW(jj) = pkdi%XP_TWSNOW(jj) + pwsnow(jj,ji)      
      pkdi%XP_TDSNOW(jj) = pkdi%XP_TDSNOW(jj) + zwork(jj,ji)
      zsnowtemp(jj) = zsnowtemp(jj) + zworktemp(jj,ji) * zwork(jj,ji)
    ENDDO
  ENDDO
  !
  WHERE(pkdi%XP_TDSNOW(:)>0.0)
        zsnowtemp(:)=zsnowtemp(:)/pkdi%XP_TDSNOW(:)
  ELSEWHERE
        zsnowtemp(:)=xundef
  ENDWHERE
  !
!cdir nodep
  DO jj=1,ksize
     ji                     =  kmask(jj)
     !
     dgmi%XHV      (ji, kpatch)  =  pkdi%XP_HV       (jj)
     dgmi%XDPSNG   (ji, kpatch)  =  ppsng(jj)
     dgmi%XDPSNV   (ji, kpatch)  =  ppsnv(jj)
     dgmi%XDPSN    (ji, kpatch)  =  ppsn(jj)     
     dgmi%XALBT    (ji, kpatch)  =  pkdi%XP_ALBT     (jj)
     dgmi%XDFF     (ji, kpatch)  =  pff(jj)
     dgmi%XDFFG    (ji, kpatch)  =  pffg(jj)
     dgmi%XDFFV    (ji, kpatch)  =  pffv(jj)     
     dgmi%XTWSNOW  (ji, kpatch)  =  pkdi%XP_TWSNOW   (jj)
     dgmi%XTDSNOW  (ji, kpatch)  =  pkdi%XP_TDSNOW   (jj)
     dgmi%XTTSNOW  (ji, kpatch)  =  zsnowtemp(jj)
     dgmi%XDFSAT   (ji, kpatch)  =  pfsat(jj)     
     !
  END DO
!
  IF (hsnow=='3-L' .OR. hsnow=='CRO') THEN
     !
    DO jk=1,SIZE(pkdi%XP_SNOWLIQ,2)
!cdir nodep
      DO jj=1,ksize
        ji                      =  kmask(jj)
        !
        dgmi%XSNOWLIQ (ji,jk,kpatch)  =  pkdi%XP_SNOWLIQ    (jj,jk)
        dgmi%XSNOWTEMP(ji,jk,kpatch)  =  pkdi%XP_SNOWTEMP   (jj,jk)
        !
      END DO
    ENDDO
     !
  ENDIF
!
! cosine of solar zenith angle 
!

  IF (hphoto/='NON'.AND.otr_ml) THEN
       !
!cdir nodep
       DO jj=1,ksize
         ji = kmask(jj)
         !
         dgmi%XFAPAR      (ji, kpatch) = pkdi%XP_FAPAR      (jj)
         dgmi%XFAPIR      (ji, kpatch) = pkdi%XP_FAPIR      (jj)
         dgmi%XFAPAR_BS   (ji, kpatch) = pkdi%XP_FAPAR_BS   (jj)
         dgmi%XFAPIR_BS   (ji, kpatch) = pkdi%XP_FAPIR_BS   (jj)
         !
       ENDDO
       !
       ! Mask where vegetation evolution is performed (just before solar midnight)
       gmask = ( ptime - ptstep < 0. ) .AND. ( ptime >= 0. )
       IF (gmask) THEN
!cdir nodep
         DO jj=1,ksize
           ji = kmask(jj)
           !
           IF (pmus(jj).NE.0.) THEN
             dgmi%XDFAPARC   (ji, kpatch) = pfaparc(jj) / pmus(jj) 
             dgmi%XDFAPIRC   (ji, kpatch) = pfapirc(jj) / pmus(jj)
             dgmi%XDLAI_EFFC (ji, kpatch) = plai_effc(jj) / pmus(jj)
           ENDIF
           !
         ENDDO
!cdir nodep         
         DO jj=1,ksize   
           pfaparc(jj)   = 0.
           pfapirc(jj)   = 0.
           plai_effc(jj) = 0.
           pmus(jj)      = 0.
         ENDDO
       ENDIF
       !
  ENDIF
  !
  IF(hisba=='DIF')THEN
    zalt(:)=0.0
    zflt(:)=0.0
    CALL comput_cold_layers_thick(pdg,ptg,zalt,zflt)
    DO jj=1,ksize
       ji              =  kmask(jj)
       dgmi%XALT(ji,kpatch) =  zalt(jj) 
       dgmi%XFLT(ji,kpatch) =  zflt(jj)  
    ENDDO
  ENDIF
  !
END IF
!
IF (oagrip) THEN
  !
!cdir nodep
  DO jj=1,ksize
     ji                     =  kmask(jj)
     !
     dgmi%XSEUIL   (ji, kpatch)  =  pseuil(jj)
     !
  END DO
!
END IF
IF (lhook) CALL dr_hook('DIAG_MISC_ISBA_N',1,zhook_handle)
!-------------------------------------------------------------------------------------
!
END SUBROUTINE diag_misc_isba_n