flood_redistrib.F90

Go to the documentation of this file.

!     #########
      SUBROUTINE flood_redistrib (TP, TPG,                              &
                                  KLON,KLAT,PTSTEP,PREAD,PSRCFLD,PRESIDU)  
!     #####################################################################
!
!!****  *FLOOD_REDISTRIB*  
!!
!!    PURPOSE
!!    -------
!
!     
!!**  METHOD
!!    ------
!
!     Direct calculation
!
!!    EXTERNAL
!!    --------
!
!     None
!!
!!    IMPLICIT ARGUMENTS
!!    ------------------
!!
!!      
!!    REFERENCE
!!    ---------
!!      
!!    AUTHOR
!!    ------
!!      B. Decharme
!!
!!    MODIFICATIONS
!!    -------------
!!      Original    01/12/13 
!-------------------------------------------------------------------------------
!
!*       0.     DECLARATIONS
!               ------------
!
USE modd_trip, ONLY : trip_t
USE modd_trip_grid, ONLY : trip_grid_t
!
USE modd_trip_listing
!
USE modd_trip_par, ONLY : xundef, xrholw
!
USE modi_abort_trip
!
USE yomhook   ,ONLY : lhook,   dr_hook
USE parkind1  ,ONLY : jprb
!
IMPLICIT NONE
!
!*      0.1    declarations of arguments
!
!
TYPE(trip_t),      INTENT(INOUT) :: TP
TYPE(trip_grid_t), INTENT(INOUT) :: TPG
!
INTEGER, INTENT(IN)               :: KLON
INTEGER, INTENT(IN)               :: KLAT
!
REAL,    INTENT(IN)               :: PTSTEP
!
REAL, DIMENSION(:,:), INTENT(IN ) :: PREAD   ![kg/m2/s]
REAL, DIMENSION(:,:), INTENT(OUT) :: PSRCFLD ![kg/m2/s]
REAL, DIMENSION(:,:), INTENT(OUT) :: PRESIDU ![kg/m2/s]
!
!
!*      0.2    declarations of local variables
!
REAL,    PARAMETER              :: ZNEG = -1.0
REAL,    PARAMETER              :: ZLIM = -0.95
REAL,    PARAMETER              :: ZSTO =  0.1  ! kg/m2
!
LOGICAL, DIMENSION(0:TPG%NBASMAX) :: LBAS_FLD
!
REAL,    DIMENSION(TPG%NBASMAX) :: ZBAS_REMAIN
REAL,    DIMENSION(TPG%NBASMAX) :: ZBAS_AREA
REAL,    DIMENSION(TPG%NBASMAX) :: ZBAS_STO
!
REAL,    DIMENSION(KLON,KLAT) :: ZFLDBUDGET
REAL,    DIMENSION(KLON,KLAT) :: ZRATIO
REAL,    DIMENSION(KLON,KLAT) :: ZREMAIN
!
REAL :: ZFLUXE_IN
REAL :: ZFLUXE_OUT
REAL :: ZAREA_TOT
REAL :: ZTOT_STO
REAL :: ZBILAN
!
INTEGER :: JBAS, JLON, JLAT, ICOUNT
!
REAL(KIND=JPRB) :: ZHOOK_HANDLE
!
!-------------------------------------------------------------------------------
!
IF (lhook) CALL dr_hook('FLOOD_REDISTRIB',0,zhook_handle)
!
!-------------------------------------------------------------------------------
! * Init
!-------------------------------------------------------------------------------
!
zfldbudget(:,:) = xundef
!
presidu(:,:) = 0.0
psrcfld(:,:) = 0.0
!
IF(all(pread(:,:)==0.0))THEN
! If no fluxes, return
  IF (lhook) CALL dr_hook('FLOOD_REDISTRIB',1,zhook_handle)
  RETURN
ENDIF
!
!-------------------------------------------------------------------------------
! * Localized water budget 
!-------------------------------------------------------------------------------
!
WHERE(tpg%GMASK_FLD(:,:).AND.pread(:,:)/=0.0)
   zfldbudget(:,:) = tp%XFLOOD_STO(:,:)+pread(:,:)*tpg%XAREA(:,:)*ptstep ! kg
ENDWHERE
!
WHERE(tp%XFLOOD_STO(:,:)>0.0.AND.zfldbudget(:,:)>=0.0.AND.zfldbudget(:,:)/=xundef)
  psrcfld(:,:) = pread(:,:)
  presidu(:,:) = 0.0
ENDWHERE
!
WHERE(tp%XFLOOD_STO(:,:)>0.0.AND.zfldbudget(:,:)<0.0.AND.zfldbudget(:,:)/=xundef)
  psrcfld(:,:) = zneg*tp%XFLOOD_STO(:,:)/(tpg%XAREA(:,:)*ptstep)                     ! kg/m2/s
  presidu(:,:) = max(zlim*tp%XSURF_STO(:,:),zfldbudget(:,:))/(tpg%XAREA(:,:)*ptstep) ! kg/m2/s
ENDWHERE
!
zremain(:,:) = pread(:,:) - psrcfld(:,:) - presidu(:,:)
!
!-------------------------------------------------------------------------------
!  * If some residue remains, redistribute the redidue 
!-------------------------------------------------------------------------------
!
lbas_fld(:) = .false.
!
zfluxe_in  = 0.0
ztot_sto   = 0.0
!
DO jlat=1,klat
   DO jlon=1,klon
      jbas = tpg%NBASID(jlon,jlat)
      IF(tpg%GMASK_FLD(jlon,jlat).AND.(.NOT.lbas_fld(jbas)))THEN
        lbas_fld(jbas)=(tp%XFLOOD_STO(jlon,jlat)>0.0)
      ENDIF
      IF(tpg%GMASK_FLD(jlon,jlat))THEN              
        zfluxe_in  = zfluxe_in  + tpg%XAREA(jlon,jlat) * zremain(jlon,jlat) ! kg/s
        ztot_sto   = ztot_sto   + tp%XSURF_STO(jlon,jlat)
      ENDIF      
   ENDDO
ENDDO
!
zbas_area(:) = 0.0
zbas_sto(:) = 0.0
!
DO jlat=1,klat
   DO jlon=1,klon
      jbas=tpg%NBASID(jlon,jlat)
      IF(tpg%GMASK_FLD(jlon,jlat).AND.lbas_fld(jbas).AND.tp%XFLOOD_STO(jlon,jlat)>0.0)THEN        
        zbas_area(jbas)=zbas_area(jbas)+tpg%XAREA   (jlon,jlat)
        zbas_sto(jbas)=zbas_sto(jbas)+tp%XSURF_STO(jlon,jlat)
      ENDIF
   ENDDO
ENDDO
!
icount = 0
!
DO jbas=tpg%NBASMIN,tpg%NBASMAX
    IF(lbas_fld(jbas))THEN
     IF((zbas_sto(jbas)/zbas_area(jbas))<=zsto)THEN
       !WRITE(NLISTING,*)'!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!'
       !WRITE(NLISTING,*)'A basin is empty :',JBAS
       !WRITE(NLISTING,*)'MASS (kg/m2) = ', ZBAS_STO(JBAS)/ZBAS_AREA(JBAS)
       !WRITE(NLISTING,*)'!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!'
       lbas_fld(jbas)=.false.
     ELSE
       icount=icount+1
     ENDIF
   ENDIF
ENDDO
!
IF(zfluxe_in/=0.0.AND.icount==0)THEN
!
!------------------------------------------------------------------------------------------
!  * If there is no flooded areas, redistribute the redidue globaly
!------------------------------------------------------------------------------------------
!
  DO jlat=1,klat
     DO jlon=1,klon
        IF(tpg%GMASK_FLD(jlon,jlat))THEN
          zratio(jlon,jlat) = tp%XSURF_STO(jlon,jlat)/tpg%XAREA(jlon,jlat)
          presidu(jlon,jlat) = presidu(jlon,jlat) + zfluxe_in * zratio(jlon,jlat) / ztot_sto ! kg/m2/s
        ENDIF
     ENDDO
  ENDDO
!
ELSE
!
!-------------------------------------------------------------------------------
!  * Redistribute the redidue  over each basin where there is flood
!-------------------------------------------------------------------------------
!
  zbas_remain(:) = 0.0
  zbas_sto(:) = 0.0
!
  zfluxe_in  = 0.0
  ztot_sto   = 0.0
!
  DO jlat=1,klat
     DO jlon=1,klon
        jbas=tpg%NBASID(jlon,jlat)
        IF(tpg%GMASK_FLD(jlon,jlat).AND.lbas_fld(jbas).AND.tp%XFLOOD_STO(jlon,jlat)>0.0)THEN
          ztot_sto      = ztot_sto      + tp%XFLOOD_STO(jlon,jlat)
          zbas_sto(jbas)=zbas_sto(jbas) + tp%XFLOOD_STO(jlon,jlat)
        ENDIF
        IF(tpg%GMASK_FLD(jlon,jlat).AND.lbas_fld(jbas))THEN
          zbas_remain(jbas)=zbas_remain(jbas)+tpg%XAREA(jlon,jlat)*zremain(jlon,jlat) ! kg/s
        ENDIF
        IF(tpg%GMASK_FLD(jlon,jlat).AND.(.NOT.lbas_fld(jbas)))THEN
          zfluxe_in  = zfluxe_in  + tpg%XAREA(jlon,jlat) * zremain(jlon,jlat) ! kg/s
        ENDIF
     ENDDO
  ENDDO
!
  DO jlat=1,klat
     DO jlon=1,klon
        jbas = tpg%NBASID(jlon,jlat)
        IF(tpg%GMASK_FLD(jlon,jlat).AND.lbas_fld(jbas).AND.tp%XFLOOD_STO(jlon,jlat)>0.0)THEN
          zratio(jlon,jlat) = tp%XFLOOD_STO(jlon,jlat)/tpg%XAREA(jlon,jlat)
          psrcfld(jlon,jlat) = psrcfld(jlon,jlat) + zbas_remain(jbas)*zratio(jlon,jlat)/zbas_sto(jbas) & ! kg/m2/s
                                                  + zfluxe_in        *zratio(jlon,jlat)/ztot_sto         ! kg/m2/s
        ENDIF
     ENDDO
  ENDDO     
!
ENDIF
!
!-------------------------------------------------------------------------------
! * Comput cumulated Fluxes (kg/s) and flooded areas (-)
!-------------------------------------------------------------------------------
!
zfluxe_in  = 0.0
zfluxe_out = 0.0
zarea_tot  = 0.0
!
DO jlat=1,klat
   DO jlon=1,klon
      IF(tpg%GMASK_FLD(jlon,jlat))THEN
        zarea_tot  = zarea_tot  + tpg%XAREA(jlon,jlat)
        zfluxe_in  = zfluxe_in  + tpg%XAREA(jlon,jlat) * pread(jlon,jlat)
        zfluxe_out = zfluxe_out + tpg%XAREA(jlon,jlat) * (psrcfld(jlon,jlat)+presidu(jlon,jlat))
      ENDIF   
   ENDDO
ENDDO
!
zbilan=(zfluxe_in-zfluxe_out)/zarea_tot
!
IF(abs(zbilan)>1.e-12)THEN
  WRITE(nlisting,*)'!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!'
  WRITE(nlisting,*)'Redistribution of flood sources has a problem'
  WRITE(nlisting,*)'BILAN = ', zbilan, zfluxe_in/zarea_tot, zfluxe_out/zarea_tot
  WRITE(nlisting,*)'!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!'
  CALL abort_trip('FLOOD_REDISTRIB: Redistribution of flood sources has a problem')        
ENDIF
!
!-------------------------------------------------------------------------------
!
IF (lhook) CALL dr_hook('FLOOD_REDISTRIB',1,zhook_handle)
!
!-------------------------------------------------------------------------------
!
END SUBROUTINE flood_redistrib