dif_layer.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 dif_layer(KLU, IO, PK, OMEB_3L )  
!#############################################################
!
!!****  *DIF_LAYER_n* - routine to initialize dif numbers of layers
!!
!!    PURPOSE
!!    -------
!!
!!**  METHOD
!!    ------
!!
!!    EXTERNAL
!!    --------
!!
!!
!!    IMPLICIT ARGUMENTS
!!    ------------------
!!
!!    REFERENCE
!!    ---------
!!
!!
!!    AUTHOR
!!    ------
!!    S. Faroux
!!
!!    MODIFICATIONS
!!    -------------
!!      Original    02/2012!!
!-------------------------------------------------------------------------------
!
!*       0.    DECLARATIONS
!              ------------
!
USE modd_isba_options_n, ONLY : isba_options_t
USE modd_isba_n, ONLY : isba_p_t
!
USE modd_surf_par,       ONLY : xundef, nundef
USE modd_sgh_par,        ONLY : xhort_depth
!
USE modi_abor1_sfx
!
USE yomhook   ,ONLY : lhook,   dr_hook
USE parkind1  ,ONLY : jprb
!
IMPLICIT NONE
!
!*       0.1   Declarations of arguments
!              -------------------------
!
INTEGER, INTENT(IN) :: KLU
!
TYPE(isba_options_t), INTENT(INOUT) :: IO
TYPE(isba_p_t), INTENT(INOUT) :: PK
LOGICAL, INTENT(IN), OPTIONAL :: OMEB_3L
!
!*       0.2   Declarations of local variables
!              -------------------------------
!
REAL, DIMENSION(KLU) :: ZWORK
INTEGER, DIMENSION(KLU) :: IWORK
INTEGER :: JL, JI, IDEPTH
LOGICAL :: GMEB_3L
!
REAL(KIND=JPRB) :: ZHOOK_HANDLE
!
!-------------------------------------------------------------------------------
!
!               Initialisation for IO
!
IF (lhook) CALL dr_hook('DIF_LAYER',0,zhook_handle)
!
gmeb_3l = .false.
IF (PRESENT(omeb_3l)) gmeb_3l = omeb_3l
!
pk%XDZG     (:,:) = xundef
!
!*   soil layers thicknesses
pk%XDZG(:,1) = pk%XDG(:,1)
DO jl=2,io%NGROUND_LAYER
  DO ji=1,klu
    pk%XDZG(ji,jl) = pk%XDG(ji,jl) - pk%XDG(ji,jl-1)
  ENDDO
ENDDO
!
IF (gmeb_3l) THEN
  IF (lhook) CALL dr_hook('DIF_LAYER',1,zhook_handle)
  RETURN
ENDIF
!
DO jl = 1, io%NGROUND_LAYER
  IF (any((pk%XROOTFRAC(:,jl)<0. .OR. pk%XROOTFRAC(:,jl)>1.) .AND. pk%XPATCH(:).NE.0.)) &
    CALL abor1_sfx('DIF_LAYER: WITH CISBA=DIF ROOTFRAC MUST BE DEFINED')
ENDDO
!
pk%XDZDIF   (:,:) = xundef
pk%XSOILWGHT(:,:) = 0.0
!
!*   distance between consecuative layer mid-points
DO jl=1,io%NGROUND_LAYER
  DO ji=1,klu
    IF(jl<io%NGROUND_LAYER)THEN
      pk%XDZDIF(ji,jl)=0.5*(pk%XDZG(ji,jl)+pk%XDZG(ji,jl+1))
    ELSE
      pk%XDZDIF(ji,jl)=0.5*pk%XDZG(ji,jl) 
    ENDIF
  ENDDO
ENDDO 
! 
!
! Horton runoff parameter
!
iwork(:) = pk%NWG_LAYER(:)
!
DO ji=1,klu
  idepth = pk%NWG_LAYER(ji)
  IF (idepth==nundef) idepth = io%NGROUND_LAYER
  DO jl=1,idepth-1
    IF(pk%XDG(ji,jl)<xhort_depth) iwork(ji)=jl+1
  ENDDO
ENDDO
!
!
IF (SIZE(iwork)>0.AND.maxval(iwork(:),iwork(:)/=nundef)>io%NLAYER_HORT) THEN
  io%NLAYER_HORT=maxval(iwork(:),iwork(:)/=nundef)
ENDIF
!  
! Dunne runoff parameter
!
iwork(:)=pk%NWG_LAYER(:)
!
!  
DO ji=1,klu
  IF(pk%XPATCH(ji)>0.0)THEN 
    idepth = pk%NWG_LAYER(ji)    
    IF(pk%XDROOT(ji)>0.0.AND.pk%XDROOT(ji)/=xundef)THEN
      pk%XRUNOFFD(ji) = pk%XDG(ji,1)
      DO jl=1,idepth-1
        IF(pk%XROOTFRAC(ji,jl)<0.90)THEN
          pk%XRUNOFFD(ji) = pk%XDG(ji,jl+1)
        ENDIF
      ENDDO
    ELSE
      pk%XRUNOFFD(ji) = min(0.6,pk%XDG2(ji))
    ENDIF
  ENDIF
ENDDO
!
zwork(:) = 0.0
DO jl=1,io%NGROUND_LAYER
  DO ji=1,klu
    IF(pk%XPATCH(ji)>0.0)THEN
      idepth=pk%NWG_LAYER(ji)
      IF(jl<=idepth)THEN
        zwork(ji      ) = zwork(ji) + pk%XDZG(ji,jl)  
        pk%XSOILWGHT(ji,jl) = min(pk%XDZG(ji,jl), &
                                        max(0.0,pk%XRUNOFFD(ji)-zwork(ji)+pk%XDZG(ji,jl)))
      ENDIF
      IF(pk%XDG(ji,jl)<pk%XRUNOFFD(ji))THEN
        iwork(ji)=jl+1
      ENDIF
    ENDIF
  ENDDO
ENDDO
!  
!
IF (SIZE(iwork)>0.AND.maxval(iwork(:),iwork(:)/=nundef)>io%NLAYER_DUN) THEN
  io%NLAYER_DUN=maxval(iwork(:),iwork(:)/=nundef)
ENDIF
!
IF (lhook) CALL dr_hook('DIF_LAYER',1,zhook_handle)
!
END SUBROUTINE dif_layer