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 (I, 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
!-------------------------------------------------------------------------------
!
!*       0.    DECLARATIONS
!              ------------
!
USE modd_isba_n,     ONLY : isba_t
USE modd_surf_atm_n, ONLY : surf_atm_t
!
USE modd_surf_par,   ONLY : xundef
!
USE modi_pack_same_rank
!
USE yomhook   ,ONLY : lhook,   dr_hook
USE parkind1  ,ONLY : jprb
!
IMPLICIT NONE
!
!*       0.1   Declarations of arguments
!              -------------------------
!
!
TYPE(isba_t), INTENT(INOUT) :: i
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
!              -------------------------------
!
 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
!    
  i%XWTD    (:) = xundef
  i%XFWTD   (:) = xundef
!
  ycomment='water table depth'
  CALL pack_same_rank(u%NR_NATURE(:),pwtd(:),i%XWTD(:))
  CALL check_land(ycomment,i%XWTD)
!  
  ycomment='fraction of water table rise'
  CALL pack_same_rank(u%NR_NATURE(:),pfwtd(:),i%XFWTD(:))
  CALL check_land(ycomment,i%XFWTD)
!
  WHERE(i%XGW(:)==0.0)
        i%XWTD    (:) = xundef
        i%XFWTD   (:) = 0.0
  ENDWHERE
!
ENDIF
!
IF(ocpl_flood)THEN
!
  i%XFFLOOD (:) = xundef
  i%XPIFLOOD(:) = xundef
!
  ycomment='Flood fraction'
  CALL pack_same_rank(u%NR_NATURE(:),pfflood(:),i%XFFLOOD(:))
  CALL check_land(ycomment,i%XFFLOOD)
!  
  ycomment='Potential flood infiltration'
  CALL pack_same_rank(u%NR_NATURE(:),ppiflood(:),i%XPIFLOOD(:))
  CALL check_land(ycomment,i%XPIFLOOD)
!
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