isba_to_topdsat.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 isba_to_topdsat(PKAPPA,PKAPPAC,KI,PRO_I,PRO_T)
!     ####################
!
!!****  *ISBA_TO_TOPDSAT*  
!!
!!    PURPOSE
!!    -------
!     
!         
!     
!!**  METHOD
!!    ------
!
!!    EXTERNAL
!!    --------
!!
!!    none
!!
!!    IMPLICIT ARGUMENTS
!!    ------------------ 
!!
!!
!!      
!!    REFERENCE
!!    ---------
!!
!!    
!!      
!!    AUTHOR
!!    ------
!!
!!      K. Chancibault  * LTHE / Meteo-France *
!!
!!    MODIFICATIONS
!!    -------------
!!
!!      Original   23/11/2005
!-------------------------------------------------------------------------------
!
!*       0.     DECLARATIONS
!               ------------
!
USE modd_surf_par,  ONLY : xundef,nundef
!
USE modd_topodyn, ONLY : nncat, nnmc, nmesht
USE modd_coupling_topd,ONLY: nmaski, nmaskt, nnpix
!
USE yomhook   ,ONLY : lhook,   dr_hook
USE parkind1  ,ONLY : jprb
!
IMPLICIT NONE
!
!*      0.1    declarations of arguments
!
INTEGER, INTENT(IN)              :: ki      ! Number of Isba meshes
REAL, DIMENSION(:,:), INTENT(IN) :: pkappa  ! Hydrological indexes on the catchments 
                                            ! at the previous time step
REAL, DIMENSION(:), INTENT(IN)   :: pkappac ! Hydrological index at saturation at the 
                                            ! previous time step
REAL, DIMENSION(:), INTENT(IN)   :: pro_i   ! Runoff on Isba grid
REAL, DIMENSION(:,:), INTENT(OUT):: pro_t   ! Runoff on TOPODYN grid
!
!
!*      0.2    declarations of local variables
!
INTEGER                          :: jcat, jpix, jmesh_isba,jj ! Loop indexes
INTEGER, DIMENSION(KI)           :: insat       ! number of saturated pixels in an ISBA mesh
INTEGER, DIMENSION(KI)           :: indry       ! Number of non-saturated pixels in an ISBA mesh
REAL, DIMENSION(NNCAT,NMESHT)    :: zrosat      ! 
REAL, DIMENSION(NNCAT,NMESHT)    :: zrodry      ! 
 CHARACTER(LEN=30)                :: yvar        ! name of results file
!
REAL::zsmall,ztmp,ztmp2
REAL(KIND=JPRB) :: zhook_handle
!-------------------------------------------------------------------------------
IF (lhook) CALL dr_hook('ISBA_TO_TOPDSAT',0,zhook_handle)
!
!*       0.     Initialization :
!               --------------
!
insat(:)=0
indry(:)=0
zrosat(:,:)=0.0
zrodry(:,:)=0.0
!
! Only Isba meshes over studied catchments are scanned
DO jmesh_isba = 1,ki
  !
  DO jcat = 1,nncat
    !
    jj=1
    jpix=nmaski(jmesh_isba,jcat,jj)
    !
    DO WHILE (jpix/=nundef .AND.(jj<=SIZE(nmaski,3)))
      !
      IF (pkappa(jcat,jpix)/=xundef .AND. nmaskt(jcat,jpix)/=nundef) THEN
        ! Calculation of the saturated and dry catchment pixels in each Isba mesh
        IF (pkappa(jcat,jpix).GE.pkappac(jcat)) THEN
          insat(nmaskt(jcat,jpix)) = insat(nmaskt(jcat,jpix)) + 1
          zrosat(jcat,jpix) = pro_i(nmaskt(jcat,jpix))
        ELSE
          indry(nmaskt(jcat,jpix)) = indry(nmaskt(jcat,jpix)) + 1 
          zrodry(jcat,jpix) = pro_i(nmaskt(jcat,jpix))
        ENDIF
      ENDIF
      !
      jj=jj+1
      IF (jj<=SIZE(nmaski,3)) jpix=nmaski(jmesh_isba,jcat,jj)
      !
    ENDDO
    !
  ENDDO
  !
ENDDO
!
!
DO jcat = 1,nncat
  !
  DO jpix = 1,nnmc(jcat)
    !
    IF (nmaskt(jcat,jpix)/=nundef) THEN
      ! calculation of the runoff and deep drainage to rout in each Isba mesh, for each catchment
      IF (insat(nmaskt(jcat,jpix)).GT.0 .AND. pkappa(jcat,jpix)/=xundef) THEN
        pro_t(jcat,jpix) = zrosat(jcat,jpix) / insat(nmaskt(jcat,jpix))
        ! if no runoff : calculation of the deep drainage to rout in each Isba mesh for each catchment
      ELSEIF (indry(nmaskt(jcat,jpix)).GT.0 .AND. pkappa(jcat,jpix)/=xundef) THEN
        pro_t(jcat,jpix) = zrodry(jcat,jpix) / indry(nmaskt(jcat,jpix))
      ELSE
        pro_t(jcat,jpix) = 0.
      ENDIF
    ENDIF
    !
  ENDDO
  !
  ! budget control 
  ztmp=0.
  ztmp2=0.
  !
  DO jpix = 1,nnmc(jcat)
    !
    IF (pro_t(jcat,jpix)/=xundef) ztmp = ztmp + pro_t(jcat,jpix)
    IF ( nmaskt(jcat,jpix)/=nundef) THEN
      IF (pro_i(nmaskt(jcat,jpix))/=xundef .AND. nnpix(nmaskt(jcat,jpix))/=0 ) &
      ztmp2 = ztmp2 + pro_i(nmaskt(jcat,jpix)) / nnpix(nmaskt(jcat,jpix))
    ENDIF
    !
  enddo!JPIX
  !
  zsmall=abs(ztmp2*0.001)
  !
  IF( abs(ztmp-ztmp2) > zsmall ) THEN
    WHERE ( pro_t(jcat,:)/=xundef )
      pro_t(jcat,:) = pro_t(jcat,:)- ((ztmp-ztmp2)/nnmc(jcat))
    ENDWHERE
  ENDIF
  !
ENDDO
!
IF (lhook) CALL dr_hook('ISBA_TO_TOPDSAT',1,zhook_handle)
!
END SUBROUTINE isba_to_topdsat