topd_to_df.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 topd_to_df (IO, NK, NP, NPE, PWG)
!     ##########################
!
!!
!!    PURPOSE
!!    -------
!     This routines updates the soil water content of ISBA DIF afeter TOPODYN
!     lateral distribution  
!     
!!**  METHOD
!!    ------
!
!!    EXTERNAL
!!    --------
!!
!!    none
!!
!!    IMPLICIT ARGUMENTS
!!    ------------------ 
!!      
!!    REFERENCE
!!    ---------
!!     
!!    AUTHOR
!!    ------
!!
!!       ELYAZIDI/HEYMES/RISTOR * Meteo-France *
!!
!!    MODIFICATIONS
!!    -------------
!!
!!      Original  02/2011 
!-------------------------------------------------------------------------------
!
!*       0.     DECLARATIONS
!               ------------
!
USE modd_isba_options_n, ONLY : isba_options_t
USE modd_isba_n, ONLY : isba_np_t, isba_npe_t, isba_nk_t, isba_k_t, isba_p_t, isba_pe_t
!
USE modd_surf_par,      ONLY : xundef, nundef
USE modd_coupling_topd, ONLY : xtotbv_in_mesh, xfrac_d3
USE modd_isba_par,      ONLY : xwgmin
!
USE yomhook   ,         ONLY : lhook,   dr_hook
USE parkind1  ,         ONLY : jprb
!
IMPLICIT NONE
!
!*      0.1    declarations of arguments
!
TYPE(isba_options_t), INTENT(INOUT) :: IO
TYPE(isba_nk_t), INTENT(INOUT) :: NK
TYPE(isba_np_t), INTENT(INOUT) :: NP
TYPE(isba_npe_t), INTENT(INOUT) :: NPE
!
 REAL, DIMENSION(:,:), INTENT(IN) :: PWG
!      
!*      0.2    declarations of local variables
!
TYPE(isba_k_t), POINTER :: KK
TYPE(isba_p_t), POINTER :: PK
TYPE(isba_pe_t), POINTER :: PEK
REAL                              :: ZWORK          ! numbers of layers in root and deep zones
INTEGER                           :: IDEPTH, IMASK
INTEGER                           :: JI, JL, JP ! loop indexes
REAL(KIND=JPRB)                   :: ZHOOK_HANDLE
!-------------------------------------------------------------------------------
!
IF (lhook) CALL dr_hook('TOPD_TO_DF',0,zhook_handle)
!
DO jp=1,io%NPATCH

  kk => nk%AL(jp)
  pk => np%AL(jp)
  pek => npe%AL(jp)

  IF (pk%NSIZE_P == 0 ) cycle

  DO jl = 1,io%NGROUND_LAYER

    DO ji=1,pk%NSIZE_P
      imask = pk%NR_P(ji)

      idepth=pk%NWG_LAYER(ji)

      IF(jl<=idepth.AND.idepth/=nundef.AND.(xtotbv_in_mesh(imask)/=0.0).AND.(xtotbv_in_mesh(imask)/=xundef)) THEN

      ! root layers
      IF (pk%XDZG(ji,jl)/=xundef.AND.pk%XDG2(ji)/=xundef.AND.pk%XDG(ji,jl)/=xundef) THEN 
        zwork=min(pk%XDZG(ji,jl),max(0.0,pk%XDG2(ji)-pk%XDG(ji,jl)+pk%XDZG(ji,jl)))
      ENDIF

      IF ((pwg(imask,2)/=xundef).AND.(zwork>0.).AND.(zwork/=xundef)) THEN
        pek%XWG(ji,jl)=min(max(pwg(imask,2),xwgmin),kk%XWSAT(ji,jl)) 
      ENDIF

      ! deep layers
      IF ((xfrac_d3(imask)/=0.0).AND.(xfrac_d3(imask)/=xundef)) THEN     

        IF (pk%XDZG(ji,jl)/=xundef.AND.pk%XDG2(ji)/=xundef.AND.pk%XDG(ji,jl)/=xundef) THEN
          zwork=min(pk%XDZG(ji,jl),max(0.0,pk%XDG(ji,jl)-pk%XDG2(ji)))
        ENDIF

        IF ((pwg(imask,3)/=xundef).AND.(zwork>0.).AND.(zwork/=xundef)) THEN
          pek%XWG(ji,jl)=min(max(pwg(imask,3),xwgmin),kk%XWSAT(ji,jl))
        ENDIF

      ENDIF

    ENDIF

  ENDDO
 ENDDO
ENDDO
!
IF (lhook) CALL dr_hook('TOPD_TO_DF',1,zhook_handle)

END SUBROUTINE topd_to_df