gw_redistrib.F90

Go to the documentation of this file.

!     #########
      SUBROUTINE gw_redistrib (TP, TPG,             &
                               KLON,KLAT,PREAD,PFOUT)  
!     #####################################################################
!
!!****  *GW_REDISTRIB*  
!!
!!    PURPOSE
!!    -------
!
!     
!!**  METHOD
!!    ------
!
!     Direct calculation
!
!!    EXTERNAL
!!    --------
!
!     None
!!
!!    IMPLICIT ARGUMENTS
!!    ------------------
!!
!!      
!!    REFERENCE
!!    ---------
!!      
!!    AUTHOR
!!    ------
!!      B. Decharme
!!
!!    MODIFICATIONS
!!    -------------
!!      Original    01/10/16 
!-------------------------------------------------------------------------------
!
!*       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
!
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, DIMENSION(:,:), INTENT(IN ) :: PREAD ![kg/m2/s]
REAL, DIMENSION(:,:), INTENT(OUT) :: PFOUT ![kg/m2/s]
!
!
!*      0.2    declarations of local variables
!
!
REAL,    DIMENSION(1000)      :: ZBAS_FNEG
REAL,    DIMENSION(1000)      :: ZBAS_AREA
!
LOGICAL, DIMENSION(KLON,KLAT) :: GMASK_NOGW
!
REAL,    DIMENSION(KLON,KLAT) :: ZFNEG
REAL,    DIMENSION(KLON,KLAT) :: ZRATIO
!
INTEGER, DIMENSION(KLON,KLAT) :: INUM_AQUI
!
REAL :: ZFLUXE_IN
REAL :: ZFLUXE_OUT
REAL :: ZAREA_TOT, ZTOT_STO
REAL :: ZBILAN
!
INTEGER :: JBAS, JLON, JLAT
!
REAL(KIND=JPRB) :: ZHOOK_HANDLE
!
!-------------------------------------------------------------------------------
!
IF (lhook) CALL dr_hook('GW_REDISTRIB',0,zhook_handle)
!
!-------------------------------------------------------------------------------
! * Init none groundwater mask
!-------------------------------------------------------------------------------
!
WHERE(tpg%GMASK(:,:).AND.(.NOT.tpg%GMASK_GW(:,:)))
  gmask_nogw(:,:)=.true.
ELSEWHERE
  gmask_nogw(:,:)=.false.
ENDWHERE
!
!-------------------------------------------------------------------------------
! * Init flux fileds
!-------------------------------------------------------------------------------
!
zbilan     = 0.0
zfneg(:,:) = 0.0
pfout(:,:) = pread(:,:)
!
DO jlat=1,klat
   DO jlon=1,klon
      IF(gmask_nogw(jlon,jlat).AND.pread(jlon,jlat)<0.0)THEN
        pfout(jlon,jlat) = 0.0
        zfneg(jlon,jlat) = pread(jlon,jlat)
        zbilan           = zbilan + pread(jlon,jlat)
      ENDIF
   ENDDO
ENDDO
!
IF(zbilan==0.0)THEN
! If no negative fluxes over none groundwater mask, return
  IF (lhook) CALL dr_hook('GW_REDISTRIB',1,zhook_handle)
  RETURN
ENDIF
!
!-------------------------------------------------------------------------------
!  * Redistribute negative field over aquifer basins
!-------------------------------------------------------------------------------
!
WHERE(tpg%GMASK(:,:))
  inum_aqui(:,:)=int(tp%XNEAR_AQUI(:,:))
ELSEWHERE
  inum_aqui(:,:)=0
ENDWHERE
!
zbas_fneg(:) = 0.0
zbas_area(:) = 0.0
!
DO jlat=1,klat
   DO jlon=1,klon
      jbas=inum_aqui(jlon,jlat)
      IF(tpg%GMASK_GW(jlon,jlat))THEN        
        zbas_area(jbas)=zbas_area(jbas)+tpg%XAREA(jlon,jlat)
      ENDIF
      IF(gmask_nogw(jlon,jlat))THEN        
        zbas_fneg(jbas)=zbas_fneg(jbas)+tpg%XAREA(jlon,jlat)*zfneg(jlon,jlat) ! kg/s
      ENDIF
   ENDDO
ENDDO
!
DO jlat=1,klat
   DO jlon=1,klon
      jbas = inum_aqui(jlon,jlat)
      IF(tpg%GMASK_GW(jlon,jlat))THEN
         pfout(jlon,jlat) = pfout(jlon,jlat) + zbas_fneg(jbas)/zbas_area(jbas) ! kg/m2/s
      ENDIF
   ENDDO
ENDDO     
!
!
!-------------------------------------------------------------------------------
! * 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(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) * pfout(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 negative recharge sources has a problem'
  WRITE(nlisting,*)'BILAN = ', zbilan, zfluxe_in/zarea_tot, zfluxe_out/zarea_tot
  WRITE(nlisting,*)'!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!'
  CALL abort_trip('GW_REDISTRIB: Redistribution of negative recharge sources has a problem')        
ENDIF
!
!-------------------------------------------------------------------------------
!
IF (lhook) CALL dr_hook('GW_REDISTRIB',1,zhook_handle)
!
!-------------------------------------------------------------------------------
!
END SUBROUTINE gw_redistrib