init_budget_coupl_rout.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 init_budget_coupl_rout (DEC, DC, DMI, PMESH_SIZE, IO, NP, NPE, U, KNI)
!     ##########################
!
!!
!!    PURPOSE
!!    -------
!    Initialise varriables usefull for budget computation    
!     
!!**  METHOD
!!    ------
!!    Terms of the budget on all the domain
!!    XB_VAR_TOT(forcing time step,variable)
!!    Water going in the system
!!      variable =1 : Rain
!!      variable =2 : Snow
!!    Water going out of the system
!!      variable =3 : Incerception 
!!      variable =4 : Evaporation
!!      variable =5 : Runoff
!!      variable =6 : Drainage
!!      variable =7 : Variation of liquid water stocked in the ground
!!      variable =8 : Variation of solid water stocked in the ground
!!      variable =9 : Variation of melting snow
!!    Budget 
!!      variable =10:  Water going in the system- Water going out of the system
!!    
!!    Terms of the budget on a given catchment
!!    XB_VAR_BV(forcing time step,catchment,variable)
!!    XB_VAR_NOBV(forcing time step,catchment,variable)
!!    
!!    EXTERNAL
!!    --------
!!
!!    none
!!
!!    IMPLICIT ARGUMENTS
!!    ------------------ 
!!      
!!    REFERENCE
!!    ---------
!!     
!!    AUTHOR
!!    ------
!!
!!    L. Bouilloud &  B. Vincendon      * Meteo-France *

!!    
!!    MODIFICATIONS
!!    -------------
!!
!!      Original  03/2008 
!!      03/2014: Modif BV : add more variables
!-------------------------------------------------------------------------------
!
!*       0.     DECLARATIONS
!               ------------
!
! declarative modules
!
USE modd_diag_n, ONLY : diag_t
USE modd_diag_evap_isba_n, ONLY : diag_evap_isba_t
USE modd_diag_misc_isba_n, ONLY : diag_misc_isba_t
USE modd_isba_options_n, ONLY : isba_options_t
USE modd_isba_n, ONLY : isba_np_t, isba_npe_t
USE modd_surf_atm_n, ONLY : surf_atm_t
!
USE modd_budget_coupl_rout ! contains all useful variables XB_*
!
USE modd_topodyn,       ONLY : nncat, nnmc, xqtot,&
                                 nnb_topd_step, xdxt, xqb_dr, xqb_run
USE modd_coupling_topd, ONLY : xas_nature,  nnb_topd,&
                               xatop, xbv_in_mesh
!
USE modd_surf_par,         ONLY:xundef
!
USE modi_unpack_same_rank
USE modi_avg_patch_wg
USE modi_dg_dfto3l
!
USE yomhook   ,ONLY : lhook,   dr_hook
USE parkind1  ,ONLY : jprb
!
IMPLICIT NONE
!
!*      0.1    declarations of arguments
!
!
TYPE(diag_evap_isba_t), INTENT(INOUT) :: DEC
TYPE(diag_t), INTENT(INOUT) :: DC
TYPE(diag_misc_isba_t), INTENT(INOUT) :: DMI
REAL, DIMENSION(:), INTENT(IN) :: PMESH_SIZE
TYPE(isba_options_t), INTENT(INOUT) :: IO
TYPE(isba_np_t), INTENT(INOUT) :: NP
TYPE(isba_npe_t), INTENT(INOUT) :: NPE
TYPE(surf_atm_t), INTENT(INOUT) :: U
!
INTEGER, INTENT(IN)           :: KNI      ! expected physical size of full surface array
!
!*      0.2    declarations of local variables
!
INTEGER    :: JJ,JWRK2
INTEGER           :: INB_VAR   ! number of variable to write
REAL, DIMENSION(U%NSIZE_NATURE,3)  :: ZWG_3L,ZWGI_3L,ZDG_3L  
REAL, DIMENSION(U%NSIZE_NATURE) :: ZINTER
!
REAL(KIND=JPRB) :: ZHOOK_HANDLE
!-------------------------------------------------------------------------------
IF (lhook) CALL dr_hook('INIT_BUDGET_COUPL_ROUT',0,zhook_handle)
!
!*       0.     Initialization:
!               ---------------
inb_var=12

IF (io%CISBA=='DIF') THEN
  CALL dg_dfto3l(io, np, zdg_3l)
  zwg_3l(:,2)=dmi%XFRD2_TWG(:)
  zwg_3l(:,3)=dmi%XFRD3_TWG(:)
  zwgi_3l(:,2)=dmi%XFRD2_TWGI(:)
  zwgi_3l(:,3)=dmi%XFRD3_TWGI(:)
ELSEIF (io%CISBA=='3-L') THEN
  CALL avg_patch_wg(io, np, npe, zwg_3l,zwgi_3l,zdg_3l)
ENDIF
!
ALLOCATE(yb_var(inb_var)) 
yb_var(1)='RAIN  '
yb_var(2)='SNOW  '
yb_var(3)='INTERC'
yb_var(4)='EVATRA'
yb_var(5)='RUNOFF'
yb_var(6)='DRAINA'
yb_var(7)='DSTOWG'
yb_var(8)='DSTOWI'
yb_var(9)='DSTOSW'
yb_var(10)='BUDGET'
yb_var(11)='HORTON'
yb_var(12)='WATBUD'
!   
!
ALLOCATE(xb_rain(kni))
ALLOCATE(xb_snow(kni))
!
ALLOCATE(xb_wr(kni))
ALLOCATE(xb_evap(kni))
ALLOCATE(xb_runoff_isba(kni))
ALLOCATE(xb_horton(kni))
ALLOCATE(xb_drain(kni))
ALLOCATE(xb_wg2(kni))
ALLOCATE(xb_wg3(kni))
ALLOCATE(xb_wgtot(kni))
ALLOCATE(xb_wgi2(kni))
ALLOCATE(xb_wgi3(kni))
ALLOCATE(xb_wgitot(kni))
ALLOCATE(xb_swe1(kni))
ALLOCATE(xb_swe2(kni))
ALLOCATE(xb_swe3(kni))
ALLOCATE(xb_swetot(kni))
!
ALLOCATE(xb_wrm(kni))
ALLOCATE(xb_evapm(kni))
ALLOCATE(xb_drainm(kni))
ALLOCATE(xb_runoff_isbam(kni))
ALLOCATE(xb_hortonm(kni))
ALLOCATE(xb_wg2m(kni))
ALLOCATE(xb_wg3m(kni))
ALLOCATE(xb_wgtotm(kni))
ALLOCATE(xb_wgi2m(kni))
ALLOCATE(xb_wgi3m(kni))
ALLOCATE(xb_wgitotm(kni))
ALLOCATE(xb_swe1m(kni))
ALLOCATE(xb_swe2m(kni))
ALLOCATE(xb_swe3m(kni))   
ALLOCATE(xb_swetotm(kni))
!
ALLOCATE(xb_mesh_size(kni))
ALLOCATE(xb_dg2(kni))
ALLOCATE(xb_dg3(kni))
!
!init var tot
CALL UNPACK_SAME_RANK(NP%AL(1)%NR_P,NPE%AL(1)%XWR(:),ZINTER(:))
CALL UNPACK_SAME_RANK(U%NR_NATURE,ZINTER,XB_WRM)
!
CALL UNPACK_SAME_RANK(U%NR_NATURE,DC%XEVAP,XB_EVAPM)
CALL UNPACK_SAME_RANK(U%NR_NATURE,DEC%XRUNOFF,XB_RUNOFF_ISBAM)
CALL UNPACK_SAME_RANK(U%NR_NATURE,DEC%XHORT,XB_HORTONM)
CALL UNPACK_SAME_RANK(U%NR_NATURE,DEC%XDRAIN,XB_DRAINM)
CALL UNPACK_SAME_RANK(U%NR_NATURE,ZWG_3L(:,2),XB_WG2M)
CALL UNPACK_SAME_RANK(U%NR_NATURE,ZWG_3L(:,3),XB_WG3M)
CALL UNPACK_SAME_RANK(U%NR_NATURE,ZDG_3L(:,2),XB_DG2)
CALL UNPACK_SAME_RANK(U%NR_NATURE,ZDG_3L(:,3),XB_DG3)
!
WHERE ( xb_wg2m/=xundef .AND. xb_dg2/=xundef .AND. xb_wg3m/=xundef .AND. xb_dg3/=xundef )
  xb_wgtotm(:) = xb_wg2m(:)*xb_dg2(:) + xb_wg3m(:)*(xb_dg3(:)-xb_dg2(:)) !m3/m2
ELSEWHERE
  xb_wgtotm(:) = xundef
ENDWHERE
!
CALL UNPACK_SAME_RANK(U%NR_NATURE,ZWGI_3L(:,2),XB_WGI2M)
CALL UNPACK_SAME_RANK(U%NR_NATURE,ZWGI_3L(:,3),XB_WGI3M)
WHERE ((xb_wgi2m/=xundef).AND.(xb_dg2/=xundef).AND.(xb_wgi3m/=xundef).AND.(xb_dg3/=xundef))
  xb_wgitotm(:) = xb_wgi2m(:)*xb_dg2(:) + xb_wgi3m(:)*(xb_dg3(:)-xb_dg2(:)) !m3/m2
ELSEWHERE
  xb_wgitotm(:) = xundef
ENDWHERE
!
CALL UNPACK_SAME_RANK(NP%AL(1)%NR_P,NPE%AL(1)%TSNOW%WSNOW(:,1),ZINTER)
CALL UNPACK_SAME_RANK(U%NR_NATURE,ZINTER,XB_SWE1M)
!
CALL UNPACK_SAME_RANK(NP%AL(1)%NR_P,NPE%AL(1)%TSNOW%WSNOW(:,2),ZINTER)
CALL UNPACK_SAME_RANK(U%NR_NATURE,ZINTER,XB_SWE2M)
!
CALL UNPACK_SAME_RANK(NP%AL(1)%NR_P,NPE%AL(1)%TSNOW%WSNOW(:,3),ZINTER)
CALL UNPACK_SAME_RANK(U%NR_NATURE,ZINTER,XB_SWE3M)
!
xb_swetotm(:) = xb_swe1m(:)+xb_swe2m(:)+xb_swe3m(:)
!
CALL UNPACK_SAME_RANK(U%NR_NATURE,PMESH_SIZE,XB_MESH_SIZE)
!
ALLOCATE(xb_abv_bymesh(kni,nncat))
DO jj=1,kni
  xb_abv_bymesh(jj,:) = xbv_in_mesh(jj,:)/xb_mesh_size(jj) !*NNMC(:)*XDXT(:)**2 ! 
  xb_abv_bymesh(jj,:) = min(1.,xb_abv_bymesh(jj,:))      
ENDDO
! 
ALLOCATE(xb_var_bv(nnb_topd_step,nncat,inb_var))
xb_var_bv(:,:,:) = 0.
ALLOCATE(xb_var_nobv(nnb_topd_step,nncat,inb_var))
xb_var_nobv(:,:,:) = 0.
! 
ALLOCATE(xb_var_tot(nnb_topd_step,inb_var))
xb_var_tot(:,:) = 0.
!
ALLOCATE(xb_runoff_topd(kni))
ALLOCATE(xb_runoff_topdm(kni))
ALLOCATE(xb_atop_bymesh(kni))
!  
CALL UNPACK_SAME_RANK(U%NR_NATURE,XATOP,XB_ATOP_BYMESH)
  xb_runoff_topdm = xb_runoff_isbam
!
ALLOCATE(yb_varq(5)) 
yb_varq(1)='Q_TOT '
yb_varq(2)='Q_RUN '
yb_varq(3)='Q_DR  '
yb_varq(4)='ST_RUN'
yb_varq(5)='ST_DR '
!
!
ALLOCATE(xb_qtot(nncat))
ALLOCATE(xb_qdr(nncat))
ALLOCATE(xb_qrun(nncat))
ALLOCATE(xb_var_q(nnb_topd_step,nncat,5))
!
ALLOCATE(xb_qtotm(nncat))
ALLOCATE(xb_qdrm(nncat))
ALLOCATE(xb_qrunm(nncat))
! 
!init var bilan q
xb_qtot(:) = 0.
xb_qdr(:) = 0.
xb_qrun(:) = 0.
!
xb_var_q(:,:,:)=0
!
DO jj=1,nncat
  xb_qtotm(jj) = sum(xqtot(jj,:))
  xb_qrunm(jj) = sum(xqb_run(jj,:))
  xb_qdrm(jj) = sum(xqb_dr(jj,:))
ENDDO
!
IF (lhook) CALL dr_hook('INIT_BUDGET_COUPL_ROUT',1,zhook_handle)
!
END SUBROUTINE init_budget_coupl_rout