topd_to_isba.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 topd_to_isba (K, UG, U, KI,KSTEP,GTOPD)
!     ####################
!
!!****  *TOPD_TO_ISBA*  
!!
!!    PURPOSE
!!    -------
!    
!     
!         
!     
!!**  METHOD
!!    ------
!
!!    EXTERNAL
!!    --------
!!
!!    none
!!
!!    IMPLICIT ARGUMENTS
!!    ------------------ 
!!
!!    
!!    
!!
!!      
!!    REFERENCE
!!    ---------
!!
!!    
!!      
!!    AUTHOR
!!    ------
!!
!!      K. Chancibault  * LTHE / Meteo-France *
!!
!!    MODIFICATIONS
!!    -------------
!!
!!      Original   09/10/2003
!!                 03/2014 (B. Vincendon) correction for meshes covered by several watersheds
!!                 03/2015 (E. Artinyan) YSTEP jusqu'a 99999 steps
!-------------------------------------------------------------------------------
!
!*       0.     DECLARATIONS
!               ------------
!
USE modd_isba_n, ONLY : isba_k_t
USE modd_surf_atm_grid_n, ONLY : surf_atm_grid_t
USE modd_surf_atm_n, ONLY : surf_atm_t
!
USE modi_unpack_same_rank
!
USE modi_write_file_isbamap
USE modi_open_file
USE modi_close_file
!
USE modd_topd_par, ONLY : nunit
USE modd_topodyn,         ONLY : nncat, nnmc, nnb_topd_step
USE modd_coupling_topd,   ONLY : xwg_full, xdtopt, xwtopt, xwsupsat,&
                                 nmaskt, xtotbv_in_mesh, nnpix,&
                                 nfreq_maps_wg, xbv_in_mesh,nnbv_in_mesh
!
USE modd_surf_par,        ONLY : xundef,nundef
USE modd_isba_par,        ONLY : xwgmin
!
USE yomhook   ,ONLY : lhook,   dr_hook
USE parkind1  ,ONLY : jprb
!
IMPLICIT NONE
!
!*      0.1    declarations of arguments
!
TYPE(isba_k_t), INTENT(INOUT) :: K
TYPE(surf_atm_grid_t), INTENT(INOUT) :: UG
TYPE(surf_atm_t), INTENT(INOUT) :: U
!
INTEGER, INTENT(IN)                 :: KI      ! Grid dimensions
INTEGER, INTENT(IN)                 :: KSTEP   ! Topodyn current time step
LOGICAL, DIMENSION(:), INTENT(INOUT)   :: GTOPD     ! 
!
!*      0.2    declarations of local variables
!
!
INTEGER                   :: JJ, JI , JMESH, JCAT         ! loop control 
REAL, DIMENSION(KI)       :: ZW              ! TOPODYN water content on ISBA grid (mm)
REAL, DIMENSION(KI)       :: ZWSAT_FULL      ! Water content at saturation on the layer 2 
                                          ! on the full grid
REAL, DIMENSION(KI)       :: ZWG_OLD
REAL, DIMENSION(KI)       :: ZDG_FULL
!
REAL, DIMENSION(KI,NNCAT) :: ZCOUNT, ZW_CAT
!
CHARACTER(LEN=5)          :: YSTEP
INTEGER                   :: JCAT_IN

REAL(KIND=JPRB) :: ZHOOK_HANDLE
!-------------------------------------------------------------------------------
IF (lhook) CALL dr_hook('TOPD_TO_ISBA',0,zhook_handle)
!
!*       0.     Initialization:
!               ---------------
!
zw(:)= 0.0
zw_cat(:,:)= 0.0
zcount(:,:)=0.0
!
zwg_old(:) = xwg_full(:)
!
!
!*       1.     TOPODYN-LAT => ISBA
!               -------------------
!*       1.1    mobilizable water
!               -----------------
!
DO jj=1,nncat
 IF (gtopd(jj)) THEN
  DO ji=1,nnmc(jj)
   IF ( (xdtopt(jj,ji) /= xundef).AND. (nmaskt(jj,ji) /= nundef) )THEN
    zw_cat(nmaskt(jj,ji),jj) = zw_cat(nmaskt(jj,ji),jj) + xwtopt(jj,ji)
    zcount(nmaskt(jj,ji),jj) = zcount(nmaskt(jj,ji),jj) + 1.0
   ENDIF
  ENDDO
 ENDIF
ENDDO
!
!
jcat_in=1
DO jmesh=1,ki
 IF (xtotbv_in_mesh(jmesh)/=0.0 .AND. xtotbv_in_mesh(jmesh)/=xundef ) THEN
  ! at least 1 catchment over mesh
  DO jcat=1,nncat
   IF (xtotbv_in_mesh(jmesh)==xbv_in_mesh(jmesh,jcat)) THEN ! only 1 catchment on mesh
    jcat_in=jcat
    IF (gtopd(jcat).AND. nnbv_in_mesh(jmesh,jcat) /=0.) THEN
     IF (xbv_in_mesh(jmesh,jcat)>=ug%G%XMESH_SIZE(jmesh)*0.75.AND. zcount(jmesh,jcat)/=0.) THEN ! catchment covers totaly mesh
     zw(jmesh) = zw_cat(jmesh,jcat) / zcount(jmesh,jcat) 
     ELSEIF(zcount(jmesh,jcat)/=0.)THEN
      zw(jmesh) = zw_cat(jmesh,jcat) /  zcount(jmesh,jcat) 
     ENDIF

    ELSE
     zw(jmesh)=zwg_old(jmesh)
    ENDIF
   ENDIF
  ENDDO
  !
  IF(zw(jmesh)==0.0) jcat_in=0 ! several catchments on the same mesh
  !
  IF (jcat_in==0) THEN  ! several catchments on the same mesh
   IF (xtotbv_in_mesh(jmesh)>=ug%G%XMESH_SIZE(jmesh)*0.75) THEN ! catchmentS cover totaly mesh
    DO jcat=1,nncat
     IF (gtopd(jcat).AND. zcount(jmesh,jcat)/=0.) THEN
      zw(jmesh) = zw(jmesh) + zw_cat(jmesh,jcat) / zcount(jmesh,jcat) *&
                 min(1.0,(xbv_in_mesh(jmesh,jcat)/ug%G%XMESH_SIZE(jmesh)))
     ELSE
      zw(jmesh)=0.
     ENDIF
    ENDDO
    IF (zw(jmesh)==0.) zw(jmesh)=zwg_old(jmesh)
   ELSE
    DO jcat=1,nncat
     IF (gtopd(jcat).AND. zcount(jmesh,jcat)/=0.) THEN
      zw(jmesh) = zw(jmesh) + zw_cat(jmesh,jcat) / zcount(jmesh,jcat)*&
                 min(1.0,(xbv_in_mesh(jmesh,jcat)/ug%G%XMESH_SIZE(jmesh)))
     ELSE
      zw(jmesh)=0.
     ENDIF
    ENDDO
    IF (zw(jmesh)==0.) zw(jmesh)=zwg_old(jmesh)
    !
   ENDIF
  ENDIF

 ELSE
  zw(jmesh)=zwg_old(jmesh)
 ENDIF
ENDDO
!
xwg_full(:) = max(zw(:),xwgmin)
!
!
 CALL unpack_same_rank(u%NR_NATURE,k%XWSAT(:,2),zwsat_full)
!
xwsupsat=0.
!ludo glace Wsat varie
WHERE ( xwg_full(:) > zwsat_full(:) .AND. xwg_full(:)/=xundef )
  !ludo calcul sat avant wg
  xwsupsat(:) = xwg_full(:) - zwsat_full(:)
  xwg_full(:) = zwsat_full(:)
ENDWHERE
!
IF ( (nfreq_maps_wg/=0 .AND. mod(kstep,nfreq_maps_wg)==0) .OR.&
     ( kstep==nnb_topd_step)  ) THEN
  ! writing of YSTEP to be able to write maps
  IF (kstep<10) THEN
    WRITE(ystep,'(I1)') kstep
  ELSEIF (kstep < 100) THEN
    WRITE(ystep,'(I2)') kstep
  ELSEIF (kstep < 1000) THEN
    WRITE(ystep,'(I3)') kstep
  ELSEIF (kstep < 10000) THEN
    WRITE(ystep,'(I4)') kstep
  ELSE
    WRITE(ystep,'(I5)') kstep
  ENDIF
  !
  CALL open_file('ASCII ',nunit,hfile='carte_w'//ystep,hform='FORMATTED',haction='WRITE')
  CALL write_file_isbamap(ug, nunit,xwg_full,ki)
  CALL close_file('ASCII ',nunit)
  !
ENDIF
!

IF (lhook) CALL dr_hook('TOPD_TO_ISBA',1,zhook_handle)
!
END SUBROUTINE topd_to_isba