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 (DGEI, DGMI, IG, I, 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_evap_isba_n, ONLY : diag_evap_isba_t
USE modd_diag_misc_isba_n, ONLY : diag_misc_isba_t
USE modd_isba_grid_n, ONLY : isba_grid_t
USE modd_isba_n, ONLY : isba_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) :: dgei
TYPE(diag_misc_isba_t), INTENT(INOUT) :: dgmi
TYPE(isba_grid_t), INTENT(INOUT) :: ig
TYPE(isba_t), INTENT(INOUT) :: i
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(SIZE(I%XWG,1),3)  :: zwg_3l,zwgi_3l,zdg_3l          
!
REAL(KIND=JPRB) :: zhook_handle
!-------------------------------------------------------------------------------
IF (lhook) CALL dr_hook('INIT_BUDGET_COUPL_ROUT',0,zhook_handle)
!
!*       0.     Initialization:
!               ---------------
inb_var=12

IF (i%CISBA=='DIF') THEN
 CALL dg_dfto3l(i, &
                SIZE(i%XWG,1),zdg_3l)
 zwg_3l(:,2)=dgmi%XFRD2_TWG(:)
 zwg_3l(:,3)=dgmi%XFRD3_TWG(:)
 zwgi_3l(:,2)=dgmi%XFRD2_TWGI(:)
 zwgi_3l(:,3)=dgmi%XFRD3_TWGI(:)

ELSEIF (i%CISBA=='3-L') THEN
 CALL avg_patch_wg(i, &
                   SIZE(i%XWG,1),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(u%NR_NATURE,i%XWR(:,1),xb_wrm)
 CALL unpack_same_rank(u%NR_NATURE,dgei%XAVG_EVAPC,xb_evapm)
 CALL unpack_same_rank(u%NR_NATURE,dgei%XAVG_RUNOFFC,xb_runoff_isbam)
 CALL unpack_same_rank(u%NR_NATURE,dgei%XAVG_HORTC,xb_hortonm)
 CALL unpack_same_rank(u%NR_NATURE,dgei%XAVG_DRAINC,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(u%NR_NATURE,i%TSNOW%WSNOW(:,1,1),xb_swe1m)
 CALL unpack_same_rank(u%NR_NATURE,i%TSNOW%WSNOW(:,2,1),xb_swe2m)
 CALL unpack_same_rank(u%NR_NATURE,i%TSNOW%WSNOW(:,3,1),xb_swe3m)
xb_swetotm(:) = xb_swe1m(:)+xb_swe2m(:)+xb_swe3m(:)
!
 CALL unpack_same_rank(u%NR_NATURE,ig%XMESH_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