put_sfx_land.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 put_sfx_land (IO, S, K, NK, NP, U, &
                               KLUOUT,OCPL_WTD,OCPL_FLOOD, &
                              PWTD,PFWTD,PFFLOOD,PPIFLOOD )  
!     #####################################################
!
!!****  *PUT_SFX_LAND* - routine to put some land surface variables to surfex
!!    PURPOSE
!!    -------
!!
!!**  METHOD
!!    ------
!!
!!    EXTERNAL
!!    --------
!!
!!
!!    IMPLICIT ARGUMENTS
!!    ------------------
!!
!!    REFERENCE
!!    ---------
!!
!!
!!    AUTHOR
!!    ------
!!      B. Decharme      *Meteo France*
!!
!!    MODIFICATIONS
!!    -------------
!!      Original    08/2009
!!      B. Decharme    01/16 : Bug with flood budget
!!    10/2016 B. Decharme : bug surface/groundwater coupling
!-------------------------------------------------------------------------------
!
!*       0.    DECLARATIONS
!              ------------
!
USE modd_isba_options_n, ONLY : isba_options_t
USE modd_isba_n, ONLY : isba_s_t, isba_k_t, isba_nk_t, isba_np_t, isba_p_t
USE modd_surf_atm_n, ONLY : surf_atm_t
!
USE modd_surf_par,   ONLY : xundef
USE modn_sfx_oasis,  ONLY : xflood_lim
!
USE modi_pack_same_rank
!
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_s_t), INTENT(INOUT) :: S
TYPE(isba_k_t), INTENT(INOUT) :: K
TYPE(isba_nk_t), INTENT(INOUT) :: NK
TYPE(isba_np_t), INTENT(INOUT) :: NP
TYPE(surf_atm_t), INTENT(INOUT) :: U
!
INTEGER,           INTENT(IN)  :: KLUOUT
LOGICAL,           INTENT(IN)  :: OCPL_WTD
LOGICAL,           INTENT(IN)  :: OCPL_FLOOD
!
REAL, DIMENSION(:), INTENT(IN) :: PWTD     ! water table depth (negative below soil surface) (m)
REAL, DIMENSION(:), INTENT(IN) :: PFWTD    ! fraction of water table rise (-)
REAL, DIMENSION(:), INTENT(IN) :: PFFLOOD  ! fraction of flooded area (-)
REAL, DIMENSION(:), INTENT(IN) :: PPIFLOOD ! Potential floodplain infiltration (kg/m2)
!
!*       0.2   Declarations of local variables
!              -------------------------------
!
TYPE(isba_p_t), POINTER :: PK
TYPE(isba_k_t), POINTER :: KK
!
INTEGER :: JP
 CHARACTER(LEN=50)     :: YCOMMENT
!
REAL(KIND=JPRB) :: ZHOOK_HANDLE
!
!-------------------------------------------------------------------------------
!
IF (lhook) CALL dr_hook('PUT_SFX_LAND',0,zhook_handle)
!
!*       1.0   Initialization
!              --------------
!
IF(u%NSIZE_NATURE==0)THEN
  IF (lhook) CALL dr_hook('PUT_SFX_LAND',1,zhook_handle)
  RETURN
ENDIF
!
!*       2.0   Put variable over nature
!              ------------------------
!
IF(ocpl_wtd)THEN
!    
  k%XWTD    (:) = xundef
  k%XFWTD   (:) = xundef
!
  ycomment='water table depth'
  CALL pack_same_rank(u%NR_NATURE(:),pwtd(:),k%XWTD(:))
  CALL check_land(ycomment,k%XWTD)
!  
  ycomment='fraction of water table rise'
  CALL pack_same_rank(u%NR_NATURE(:),pfwtd(:),k%XFWTD(:))
  CALL check_land(ycomment,k%XFWTD)
!
  WHERE(k%XFWTD(:)==0.0)
    k%XWTD    (:) = xundef
  ENDWHERE
!
  DO jp = 1,io%NPATCH
    pk => np%AL(jp)
    kk => nk%AL(jp)
    CALL pack_same_rank(pk%NR_P,k%XWTD,kk%XWTD)
    CALL pack_same_rank(pk%NR_P,k%XFWTD,kk%XFWTD)
  ENDDO
!   
ENDIF
!
IF(ocpl_flood)THEN
!
  k%XFFLOOD (:) = xundef
  k%XPIFLOOD(:) = xundef
!
  ycomment='Flood fraction'
  CALL pack_same_rank(u%NR_NATURE(:),pfflood(:),k%XFFLOOD(:))
  CALL check_land(ycomment,k%XFFLOOD)
!  
  ycomment='Potential flood infiltration'
  CALL pack_same_rank(u%NR_NATURE(:),ppiflood(:),k%XPIFLOOD(:))
  CALL check_land(ycomment,k%XPIFLOOD)
!
! No flood for very smal flooded area (default 1%)
!
  WHERE(k%XFFLOOD (:)<xflood_lim)
    k%XFFLOOD (:)=0.0
    k%XPIFLOOD(:)=0.0
  ENDWHERE
!
  DO jp = 1,io%NPATCH
    pk => np%AL(jp)
    kk => nk%AL(jp)
    CALL pack_same_rank(pk%NR_P,k%XFFLOOD,kk%XFFLOOD)
    CALL pack_same_rank(pk%NR_P,k%XPIFLOOD,kk%XPIFLOOD)
  ENDDO
!
ENDIF
!
IF (lhook) CALL dr_hook('PUT_SFX_LAND',1,zhook_handle)
!
!-------------------------------------------------------------------------------
CONTAINS
!-------------------------------------------------------------------------------
!
SUBROUTINE check_land(HCOMMENT,PFIELD)
!
USE modi_abor1_sfx
!
IMPLICIT NONE
!
 CHARACTER(LEN=*),   INTENT(IN) :: HCOMMENT
REAL, DIMENSION(:), INTENT(IN) :: PFIELD
!
REAL(KIND=JPRB) :: ZHOOK_HANDLE
!
IF (lhook) CALL dr_hook('PUT_SFX_LAND:CHECK_LAND',0,zhook_handle)
!
IF(any(pfield(:)>=xundef))THEN
  WRITE(kluout,*)'PUT_SFX_LAND: problem after get '//trim(hcomment)//' from OASIS'
  WRITE(kluout,*)'PUT_SFX_LAND: some points not defined = ',count(pfield(:)>=xundef)
  CALL abor1_sfx('PUT_SFX_LAND: problem after get '//trim(hcomment)//' from OASIS')          
ENDIF
!
IF (lhook) CALL dr_hook('PUT_SFX_LAND:CHECK_LAND',1,zhook_handle)
!
END SUBROUTINE check_land
!
!-------------------------------------------------------------------------------
!
END SUBROUTINE put_sfx_land