source: branches/ORCHIDEE_2_2/ORCHIDEE/src_sechiba/routing.f90 @ 5811

! =================================================================================================================================
! MODULE       : routing
!
! CONTACT      : orchidee-help _at_ listes.ipsl.fr
!
! LICENCE      : IPSL (2006)
! This software is governed by the CeCILL licence see ORCHIDEE/ORCHIDEE_CeCILL.LIC
!
!>\BRIEF       This module routes the water over the continents into the oceans and computes the water
!!             stored in floodplains or taken for irrigation.
!!
!!\n DESCRIPTION: None
!!
!! RECENT CHANGE(S): None
!!
!! REFERENCE(S) :
!!
!! SVN          :
!! $HeadURL$
!! $Date$
!! $Revision$
!! \n
!_ ================================================================================================================================
! 
!
! Histoire Salee
!---------------
! La douce riviere
! Sortant de son lit
! S'est jetee ma chere
! dans les bras mais oui
! du beau fleuve
!
! L'eau coule sous les ponts
! Et puis les flots s'emeuvent
! - N'etes vous pas au courant ?
! Il parait que la riviere 
! Va devenir mer
!                       Roland Bacri
!


MODULE routing

  USE ioipsl   
  USE xios_orchidee
  USE ioipsl_para 
  USE constantes
  USE time, ONLY : one_day, dt_sechiba
  USE constantes_soil
  USE pft_parameters
  USE sechiba_io_p
  USE interpol_help
  USE grid
  USE mod_orchidee_para


  IMPLICIT NONE
  PRIVATE
  PUBLIC :: routing_main, routing_initialize, routing_finalize, routing_clear

!! PARAMETERS
  INTEGER(i_std), PARAMETER                                  :: nbasmax=5                   !! The maximum number of basins we wish to have per grid box (truncation of the model) (unitless)
  INTEGER(i_std), SAVE                                       :: nbvmax                      !! The maximum number of basins we can handle at any time during the generation of the maps (unitless)
!$OMP THREADPRIVATE(nbvmax)
  REAL(r_std), SAVE                                          :: fast_tcst = 3.0             !! Property of the fast reservoir, (day/m)
!$OMP THREADPRIVATE(fast_tcst)
  REAL(r_std), SAVE                                          :: slow_tcst = 25.0            !! Property of the slow reservoir, (day/m)
!$OMP THREADPRIVATE(slow_tcst)
  REAL(r_std), SAVE                                          :: stream_tcst = 0.24          !! Property of the stream reservoir, (day/m)
!$OMP THREADPRIVATE(stream_tcst)
  REAL(r_std), SAVE                                          :: flood_tcst = 4.0            !! Property of the floodplains reservoir, (day/m)
!$OMP THREADPRIVATE(flood_tcst)
  REAL(r_std), SAVE                                          :: swamp_cst = 0.2             !! Fraction of the river transport that flows to the swamps (unitless;0-1)
!$OMP THREADPRIVATE(swamp_cst)
  !
  !  Relation between volume and fraction of floodplains
  !
  REAL(r_std), SAVE                                          :: beta = 2.0                  !! Parameter to fix the shape of the floodplain (>1 for convex edges, <1 for concave edges) (unitless)
!$OMP THREADPRIVATE(beta)
  REAL(r_std), SAVE                                          :: betap = 0.5                 !! Ratio of the basin surface intercepted by ponds and the maximum surface of ponds (unitless;0-1)
!$OMP THREADPRIVATE(betap)
  REAL(r_std), SAVE                                          :: floodcri = 2000.0           !! Potential height for which all the basin is flooded (mm)
!$OMP THREADPRIVATE(floodcri)
  !
  !  Relation between maximum surface of ponds and basin surface, and drainage (mm/j) to the slow_res
  !
  REAL(r_std), PARAMETER                                     :: pond_bas = 50.0             !! [DISPENSABLE] - not used
  REAL(r_std), SAVE                                          :: pondcri = 2000.0            !! Potential height for which all the basin is a pond (mm)
!$OMP THREADPRIVATE(pondcri)
  !
  REAL(r_std), PARAMETER                                     :: maxevap_lake = 7.5/86400.   !! Maximum evaporation rate from lakes (kg/m^2/s)
  !
  REAL(r_std),SAVE                                           :: dt_routing                  !! Routing time step (s)
!$OMP THREADPRIVATE(dt_routing)
  !
  INTEGER(i_std), SAVE                                       :: diagunit = 87               !! Diagnostic file unit (unitless)
!$OMP THREADPRIVATE(diagunit)
  !
  ! Logicals to control model configuration
  !
  LOGICAL, SAVE                                              :: dofloodinfilt = .FALSE.     !! Logical to choose if floodplains infiltration is activated or not (true/false)
!$OMP THREADPRIVATE(dofloodinfilt)
  LOGICAL, SAVE                                              :: doswamps = .FALSE.          !! Logical to choose if swamps are activated or not (true/false)
!$OMP THREADPRIVATE(doswamps)
  LOGICAL, SAVE                                              :: doponds = .FALSE.           !! Logical to choose if ponds are activated or not (true/false)
!$OMP THREADPRIVATE(doponds)
  !
  ! The variables describing the basins and their routing, need to be in the restart file.
  !
  INTEGER(i_std), SAVE                                       :: num_largest                 !! Number of largest river basins which should be treated as independently as rivers
                                                                                            !! (not flow into ocean as diffusion coastal flow) (unitless)
!$OMP THREADPRIVATE(num_largest)
  REAL(r_std), SAVE                                          :: time_counter                !! Time counter (s)
!$OMP THREADPRIVATE(time_counter)
  REAL(r_std), SAVE, ALLOCATABLE, TARGET, DIMENSION(:,:)     :: routing_area_loc            !! Surface of basin (m^2)
!$OMP THREADPRIVATE(routing_area_loc)
  REAL(r_std), SAVE, ALLOCATABLE, TARGET, DIMENSION(:,:)     :: topo_resid_loc              !! Topographic index of the retention time (m)
!$OMP THREADPRIVATE(topo_resid_loc)
  INTEGER(i_std), SAVE, ALLOCATABLE, TARGET, DIMENSION(:,:)  :: route_togrid_loc            !! Grid into which the basin flows (unitless)
!$OMP THREADPRIVATE(route_togrid_loc)
  INTEGER(i_std), SAVE, ALLOCATABLE, TARGET, DIMENSION(:,:)  :: route_tobasin_loc           !! Basin in to which the water goes (unitless)
!$OMP THREADPRIVATE(route_tobasin_loc)
  INTEGER(i_std), SAVE, ALLOCATABLE, TARGET, DIMENSION(:,:)  :: route_nbintobas_loc         !! Number of basin into current one (unitless)
!$OMP THREADPRIVATE(route_nbintobas_loc)
  INTEGER(i_std), SAVE, ALLOCATABLE, TARGET, DIMENSION(:,:)  :: global_basinid_loc          !! ID of basin (unitless)
!$OMP THREADPRIVATE(global_basinid_loc)
  INTEGER(i_std), SAVE, ALLOCATABLE, TARGET, DIMENSION(:,:)  :: hydrodiag_loc               !! Variable to diagnose the hydrographs
!$OMP THREADPRIVATE(hydrodiag_loc)
  REAL(r_std), SAVE, ALLOCATABLE, TARGET, DIMENSION(:)       :: hydroupbasin_loc            !! The area upstream of the gauging station (m^2)
!$OMP THREADPRIVATE(hydroupbasin_loc)
  !
  ! parallelism
  REAL(r_std), SAVE, ALLOCATABLE, TARGET, DIMENSION(:,:)     :: routing_area_glo            !! Surface of basin (m^2)
!$OMP THREADPRIVATE(routing_area_glo)
  REAL(r_std), SAVE, ALLOCATABLE, TARGET, DIMENSION(:,:)     :: topo_resid_glo              !! Topographic index of the retention time (m)
!$OMP THREADPRIVATE(topo_resid_glo)
  INTEGER(i_std), SAVE, ALLOCATABLE, TARGET, DIMENSION(:,:)  :: route_togrid_glo            !! Grid into which the basin flows (unitless)
!$OMP THREADPRIVATE(route_togrid_glo)
  INTEGER(i_std), SAVE, ALLOCATABLE, TARGET, DIMENSION(:,:)  :: route_tobasin_glo           !! Basin in to which the water goes (unitless)
!$OMP THREADPRIVATE(route_tobasin_glo)
  INTEGER(i_std), SAVE, ALLOCATABLE, TARGET, DIMENSION(:,:)  :: route_nbintobas_glo         !! Number of basin into current one (unitless)
!$OMP THREADPRIVATE(route_nbintobas_glo)
  INTEGER(i_std), SAVE, ALLOCATABLE, TARGET, DIMENSION(:,:)  :: global_basinid_glo          !! ID of basin (unitless)
!$OMP THREADPRIVATE(global_basinid_glo)
  INTEGER(i_std), SAVE, ALLOCATABLE, TARGET, DIMENSION(:,:)  :: hydrodiag_glo               !! Variable to diagnose the hydrographs
!$OMP THREADPRIVATE(hydrodiag_glo)
  REAL(r_std), SAVE, ALLOCATABLE, TARGET, DIMENSION(:)       :: hydroupbasin_glo            !! The area upstream of the gauging station (m^2)
!$OMP THREADPRIVATE(hydroupbasin_glo)
  !
  REAL(r_std), SAVE, POINTER, DIMENSION(:,:)                 :: routing_area                !! Surface of basin (m^2)
!$OMP THREADPRIVATE(routing_area)
  REAL(r_std), SAVE, POINTER, DIMENSION(:,:)                 :: topo_resid                  !! Topographic index of the retention time (m)
!$OMP THREADPRIVATE(topo_resid)
  INTEGER(i_std), SAVE, POINTER, DIMENSION(:,:)              :: route_togrid                !! Grid into which the basin flows (unitless)
!$OMP THREADPRIVATE(route_togrid)
  INTEGER(i_std), SAVE, POINTER, DIMENSION(:,:)              :: route_tobasin               !! Basin in to which the water goes (unitless)
!$OMP THREADPRIVATE(route_tobasin)
  INTEGER(i_std), SAVE, POINTER, DIMENSION(:,:)              :: route_nbintobas             !! Number of basin into current one (unitless)
!$OMP THREADPRIVATE(route_nbintobas)
  INTEGER(i_std), SAVE, POINTER, DIMENSION(:,:)              :: global_basinid              !! ID of basin (unitless)
!$OMP THREADPRIVATE(global_basinid)
  INTEGER(i_std), SAVE, POINTER, DIMENSION(:,:)              :: hydrodiag                   !! Variable to diagnose the hydrographs
!$OMP THREADPRIVATE(hydrodiag)
  REAL(r_std), SAVE, ALLOCATABLE, DIMENSION(:)               :: slowflow_diag               !! Diagnostic slow flow hydrographs (kg/dt)
!$OMP THREADPRIVATE(slowflow_diag)  
  REAL(r_std), SAVE, POINTER, DIMENSION(:)                   :: hydroupbasin                !! The area upstream of the gauging station (m^2)
!$OMP THREADPRIVATE(hydroupbasin)
  !
  REAL(r_std), SAVE, ALLOCATABLE, DIMENSION(:)               :: irrigated                   !! Area equipped for irrigation in each grid box (m^2)
!$OMP THREADPRIVATE(irrigated)
  REAL(r_std), SAVE, ALLOCATABLE, DIMENSION(:)               :: floodplains                 !! Maximal surface which can be inundated in each grid box (m^2)
!$OMP THREADPRIVATE(floodplains)
  REAL(r_std), SAVE, ALLOCATABLE, DIMENSION(:)               :: swamp                       !! Maximal surface of swamps in each grid box (m^2)
!$OMP THREADPRIVATE(swamp)
  !
  ! The reservoirs, also to be put into the restart file.
  !
  REAL(r_std), SAVE, ALLOCATABLE, DIMENSION(:,:)             :: fast_reservoir              !! Water amount in the fast reservoir (kg)
!$OMP THREADPRIVATE(fast_reservoir)
  REAL(r_std), SAVE, ALLOCATABLE, DIMENSION(:,:)             :: slow_reservoir              !! Water amount in the slow reservoir (kg)
!$OMP THREADPRIVATE(slow_reservoir)
  REAL(r_std), SAVE, ALLOCATABLE, DIMENSION(:,:)             :: stream_reservoir            !! Water amount in the stream reservoir (kg)
!$OMP THREADPRIVATE(stream_reservoir)
  REAL(r_std), SAVE, ALLOCATABLE, DIMENSION(:,:)             :: flood_reservoir             !! Water amount in the floodplains reservoir (kg)
!$OMP THREADPRIVATE(flood_reservoir)
  REAL(r_std), SAVE, ALLOCATABLE, DIMENSION(:)               :: lake_reservoir              !! Water amount in the lake reservoir (kg)
!$OMP THREADPRIVATE(lake_reservoir)
  REAL(r_std), SAVE, ALLOCATABLE, DIMENSION(:)               :: pond_reservoir              !! Water amount in the pond reservoir (kg)
!$OMP THREADPRIVATE(pond_reservoir)
  REAL(r_std), SAVE, ALLOCATABLE, DIMENSION(:,:)             :: flood_frac_bas              !! Flooded fraction per basin (unitless;0-1)
!$OMP THREADPRIVATE(flood_frac_bas)
  REAL(r_std), SAVE, ALLOCATABLE, DIMENSION(:)               :: pond_frac                   !! Pond fraction per grid box (unitless;0-1)
!$OMP THREADPRIVATE(pond_frac)
  REAL(r_std), SAVE, ALLOCATABLE, DIMENSION(:)               :: flood_height                !! Floodplain height (mm)
!$OMP THREADPRIVATE(flood_height)
  !
  ! The accumulated fluxes.
  !
  REAL(r_std), SAVE, ALLOCATABLE, DIMENSION(:)               :: floodout_mean               !! Accumulated flow out of floodplains (kg/m^2/dt)
!$OMP THREADPRIVATE(floodout_mean)
  REAL(r_std), SAVE, ALLOCATABLE, DIMENSION(:)               :: runoff_mean                 !! Accumulated runoff (kg/m^2/dt)
!$OMP THREADPRIVATE(runoff_mean)
  REAL(r_std), SAVE, ALLOCATABLE, DIMENSION(:)               :: drainage_mean               !! Accumulated drainage (kg/m^2/dt)
!$OMP THREADPRIVATE(drainage_mean)
  REAL(r_std), SAVE, ALLOCATABLE, DIMENSION(:)               :: transpot_mean               !! Mean potential transpiration from the plants (kg/m^2/dt)
!$OMP THREADPRIVATE(transpot_mean)
  REAL(r_std), SAVE, ALLOCATABLE, DIMENSION(:)               :: precip_mean                 !! Accumulated precipitation (kg/m^2/dt)
!$OMP THREADPRIVATE(precip_mean)
  REAL(r_std), SAVE, ALLOCATABLE, DIMENSION(:)               :: humrel_mean                 !! Mean soil moisture stress, mean root extraction potential (unitless)
!$OMP THREADPRIVATE(humrel_mean)
  REAL(r_std), SAVE, ALLOCATABLE, DIMENSION(:)               :: totnobio_mean               !! Mean last total fraction of no bio (unitless;0-1)
!$OMP THREADPRIVATE(totnobio_mean)
  REAL(r_std), SAVE, ALLOCATABLE, DIMENSION(:)               :: vegtot_mean                 !! Mean potentially vegetated fraction (unitless;0-1)
!$OMP THREADPRIVATE(vegtot_mean)
  REAL(r_std), SAVE, ALLOCATABLE, DIMENSION(:)               :: k_litt_mean                 !! Mean averaged conductivity for saturated infiltration in the 'litter' layer (kg/m^2/dt)
!$OMP THREADPRIVATE(k_litt_mean)
  !
  ! The averaged outflow fluxes.
  !
  REAL(r_std), SAVE, ALLOCATABLE, DIMENSION(:)               :: lakeinflow_mean              !! Mean lake inflow (kg/m^2/dt)
!$OMP THREADPRIVATE(lakeinflow_mean)
  REAL(r_std), SAVE, ALLOCATABLE, DIMENSION(:)               :: returnflow_mean              !! Mean water flow from lakes and swamps which returns to the grid box.
                                                                                             !! This water will go back into the hydrol module to allow re-evaporation (kg/m^2/dt)
!$OMP THREADPRIVATE(returnflow_mean)
  REAL(r_std), SAVE, ALLOCATABLE, DIMENSION(:)               :: reinfiltration_mean          !! Mean water flow which returns to the grid box (kg/m^2/dt)
!$OMP THREADPRIVATE(reinfiltration_mean)
  REAL(r_std), SAVE, ALLOCATABLE, DIMENSION(:)               :: irrigation_mean              !! Mean irrigation flux.
                                                                                             !! This is the water taken from the reservoirs and beeing put into the upper layers of the soil (kg/m^2/dt)
!$OMP THREADPRIVATE(irrigation_mean)
  REAL(r_std), SAVE, ALLOCATABLE, DIMENSION(:)               :: riverflow_mean               !! Mean Outflow of the major rivers.
                                                                                             !! The flux will be located on the continental grid but this should be a coastal point (kg/dt)
!$OMP THREADPRIVATE(riverflow_mean)
  REAL(r_std), SAVE, ALLOCATABLE, DIMENSION(:)               :: coastalflow_mean             !! Mean outflow on coastal points by small basins.
                                                                                             !! This is the water which flows in a disperse way into the ocean (kg/dt)
!$OMP THREADPRIVATE(coastalflow_mean)
  REAL(r_std), SAVE, ALLOCATABLE, DIMENSION(:)               :: floodtemp                    !! Temperature to decide if floodplains work (K)
!$OMP THREADPRIVATE(floodtemp)
  INTEGER(i_std), SAVE                                       :: floodtemp_lev                !! Temperature level to decide if floodplains work (K)
!$OMP THREADPRIVATE(floodtemp_lev)
  !
  ! Diagnostic variables ... well sort of !
  !
  REAL(r_std), SAVE, ALLOCATABLE, DIMENSION(:)               :: irrig_netereq                !! Irrigation requirement (water requirements by the crop for its optimal growth (kg/m^2/dt)
!$OMP THREADPRIVATE(irrig_netereq)
  REAL(r_std), SAVE, ALLOCATABLE, DIMENSION(:)               :: hydrographs                  !! Hydrographs at the outflow of the grid box for major basins (kg/dt)
!$OMP THREADPRIVATE(hydrographs)
  !
  ! Diagnostics for the various reservoirs we use (Kg/m^2)
  !
  REAL(r_std), SAVE, ALLOCATABLE, DIMENSION(:)               :: fast_diag                    !! Diagnostic for the fast reservoir (kg/m^2)
!$OMP THREADPRIVATE(fast_diag)
  REAL(r_std), SAVE, ALLOCATABLE, DIMENSION(:)               :: slow_diag                    !! Diagnostic for the slow reservoir (kg/m^2)
!$OMP THREADPRIVATE(slow_diag)
  REAL(r_std), SAVE, ALLOCATABLE, DIMENSION(:)               :: stream_diag                  !! Diagnostic for the stream reservoir (kg/m^2)
!$OMP THREADPRIVATE(stream_diag)
  REAL(r_std), SAVE, ALLOCATABLE, DIMENSION(:)               :: flood_diag                   !! Diagnostic for the floodplain reservoir (kg/m^2)
!$OMP THREADPRIVATE(flood_diag)
  REAL(r_std), SAVE, ALLOCATABLE, DIMENSION(:)               :: pond_diag                    !! Diagnostic for the pond reservoir (kg/m^2)
!$OMP THREADPRIVATE(pond_diag)
  REAL(r_std), SAVE, ALLOCATABLE, DIMENSION(:)               :: lake_diag                    !! Diagnostic for the lake reservoir (kg/m^2)
!$OMP THREADPRIVATE(lake_diag)

  REAL(r_std), SAVE, ALLOCATABLE, DIMENSION(:)               :: mask_coast                   !! Mask with coastal gridcells on local grid(1/0)
!$OMP THREADPRIVATE(mask_coast)
  REAL(r_std), SAVE                                          :: max_lake_reservoir           !! Maximum limit of water in lake_reservoir [kg/m2]
  !$OMP THREADPRIVATE(max_lake_reservoir)
  INTEGER(i_std), SAVE                                       :: nb_coast_gridcells           !! Number of gridcells which can receive coastalflow


CONTAINS
  !!  =============================================================================================================================
  !! SUBROUTINE:         routing_initialize
  !!
  !>\BRIEF               Initialize the routing module
  !!
  !! DESCRIPTION:        Initialize the routing module. Read from restart file or read the routing.nc file to initialize the
  !!                     routing scheme. 
  !!
  !! RECENT CHANGE(S)
  !!
  !! REFERENCE(S)
  !! 
  !! FLOWCHART   
  !! \n
  !_ ==============================================================================================================================

  SUBROUTINE routing_initialize( kjit,       nbpt,           index,                 &
                                rest_id,     hist_id,        hist2_id,   lalo,      &
                                neighbours,  resolution,     contfrac,   stempdiag, &
                                returnflow,  reinfiltration, irrigation, riverflow, &
                                coastalflow, flood_frac,     flood_res )
       
    IMPLICIT NONE
    
    !! 0.1 Input variables
    INTEGER(i_std), INTENT(in)     :: kjit                 !! Time step number (unitless)
    INTEGER(i_std), INTENT(in)     :: nbpt                 !! Domain size (unitless)
    INTEGER(i_std), INTENT(in)     :: index(nbpt)          !! Indices of the points on the map (unitless)
    INTEGER(i_std),INTENT(in)      :: rest_id              !! Restart file identifier (unitless)
    INTEGER(i_std),INTENT(in)      :: hist_id              !! Access to history file (unitless)
    INTEGER(i_std),INTENT(in)      :: hist2_id             !! Access to history file 2 (unitless)
    REAL(r_std), INTENT(in)        :: lalo(nbpt,2)         !! Vector of latitude and longitudes (beware of the order !)

    INTEGER(i_std), INTENT(in)     :: neighbours(nbpt,NbNeighb) !! Vector of neighbours for each grid point 
                                                           !! (1=N, 2=NE, 3=E, 4=SE, 5=S, 6=SW, 7=W, 8=NW) (unitless)
    REAL(r_std), INTENT(in)        :: resolution(nbpt,2)   !! The size of each grid box in X and Y (m)
    REAL(r_std), INTENT(in)        :: contfrac(nbpt)       !! Fraction of land in each grid box (unitless;0-1)
    REAL(r_std), INTENT(in)        :: stempdiag(nbpt,nslm) !! Diagnostic soil temperature profile

    !! 0.2 Output variables
    REAL(r_std), INTENT(out)       :: returnflow(nbpt)     !! The water flow from lakes and swamps which returns to the grid box.
                                                           !! This water will go back into the hydrol module to allow re-evaporation (kg/m^2/dt)
    REAL(r_std), INTENT(out)       :: reinfiltration(nbpt) !! Water flow from ponds and floodplains which returns to the grid box (kg/m^2/dt)
    REAL(r_std), INTENT(out)       :: irrigation(nbpt)     !! Irrigation flux. This is the water taken from the reservoirs and beeing put into the upper layers of the soil (kg/m^2/dt)
    REAL(r_std), INTENT(out)       :: riverflow(nbpt)      !! Outflow of the major rivers. The flux will be located on the continental grid but this should be a coastal point (kg/dt)

    REAL(r_std), INTENT(out)       :: coastalflow(nbpt)    !! Outflow on coastal points by small basins. This is the water which flows in a disperse way into the ocean (kg/dt)
    REAL(r_std), INTENT(out)       :: flood_frac(nbpt)     !! Flooded fraction of the grid box (unitless;0-1)
    REAL(r_std), INTENT(out)       :: flood_res(nbpt)      !! Diagnostic of water amount in the floodplains reservoir (kg)
    
    !! 0.3 Local variables
    REAL(r_std), DIMENSION(nbp_glo):: mask_coast_glo       !! Mask with coastal gridcells on global grid (1/0)
    LOGICAL                        :: init_irrig           !! Logical to initialize the irrigation (true/false)
    LOGICAL                        :: init_flood           !! Logical to initialize the floodplains (true/false)
    LOGICAL                        :: init_swamp           !! Logical to initialize the swamps (true/false)
    INTEGER                        :: ig, ib, rtg, rtb     !! Index
    INTEGER                        :: ier                  !! Error handeling
!_ ================================================================================================================================

    !
    ! do initialisation
    !
    nbvmax = 440
    ! Here we will allocate the memory and get the fixed fields from the restart file.
    ! If the info is not found then we will compute the routing map.
    !

    CALL routing_init (kjit, nbpt, index, returnflow, reinfiltration, irrigation, &
         riverflow, coastalflow, flood_frac, flood_res, stempdiag, rest_id)

    routing_area => routing_area_loc  
    topo_resid => topo_resid_loc
    route_togrid => route_togrid_loc
    route_tobasin => route_tobasin_loc
    global_basinid => global_basinid_loc
    hydrodiag => hydrodiag_loc
    
    ! This routine computes the routing map if the route_togrid_glo is undefined. This means that the
    ! map has not been initialized during the restart process..
    !
    !! Reads in the map of the basins and flow directions to construct the catchments of each grid box
    !
    IF ( COUNT(route_togrid_glo .GE. undef_int) .GT. 0 ) THEN
       CALL routing_basins_p(nbpt, lalo, neighbours, resolution, contfrac)
    ENDIF

    !! Create a mask containing all possible coastal gridcells and count total number of coastal gridcells
    IF (is_root_prc) THEN
       mask_coast_glo(:)=0
       DO ib=1,nbasmax
          DO ig=1,nbp_glo
             rtg = route_togrid_glo(ig,ib)
             rtb = route_tobasin_glo(ig,ib)
             ! Coastal gridcells are stored in nbasmax+2
             IF (rtb == nbasmax+2) THEN
                mask_coast_glo(rtg) = 1
             END IF
          END DO
       END DO
       nb_coast_gridcells=SUM(mask_coast_glo)
       IF (printlev>=3) WRITE(numout,*) 'Number of coastal gridcells = ', nb_coast_gridcells
    ENDIF
    CALL bcast(nb_coast_gridcells)

    ALLOCATE(mask_coast(nbpt), stat=ier)
    IF (ier /= 0) CALL ipslerr_p(3,'routing_inititalize','Pb in allocate for mask_coast','','')
    CALL scatter(mask_coast_glo, mask_coast)
    CALL xios_orchidee_send_field("mask_coast",mask_coast)


    !
    ! Do we have what we need if we want to do irrigation
    !! Initialisation of flags for irrigated land, flood plains and swamps
    !
    init_irrig = .FALSE.
    IF ( do_irrigation ) THEN 
       IF (COUNT(irrigated .GE. undef_sechiba-1) > 0) init_irrig = .TRUE.
    END IF
    
    init_flood = .FALSE.
    IF ( do_floodplains ) THEN
       IF (COUNT(floodplains .GE. undef_sechiba-1) > 0) init_flood = .TRUE.
    END IF
    
    init_swamp = .FALSE.
    IF ( doswamps ) THEN
       IF (COUNT(swamp .GE. undef_sechiba-1) > 0 ) init_swamp = .TRUE.
    END IF
       
    !! If we have irrigated land, flood plains or swamps then we need to interpolate the 0.5 degree
    !! base data set to the resolution of the model.
    
    IF ( init_irrig .OR. init_flood .OR. init_swamp ) THEN
       CALL routing_irrigmap(nbpt, index, lalo, neighbours, resolution, &
            contfrac, init_irrig, irrigated, init_flood, floodplains, init_swamp, swamp, hist_id, hist2_id)
    ENDIF
    
    IF ( do_irrigation ) THEN 
       CALL xios_orchidee_send_field("irrigmap",irrigated)
       
       IF (printlev >= 3) WRITE(numout,*) 'Verification : range of irrigated : ', MINVAL(irrigated), MAXVAL(irrigated) 
       IF ( .NOT. almaoutput ) THEN
          CALL histwrite_p(hist_id, 'irrigmap', 1, irrigated, nbpt, index)
       ELSE
          CALL histwrite_p(hist_id, 'IrrigationMap', 1, irrigated, nbpt, index)
       ENDIF
       IF ( hist2_id > 0 ) THEN
          IF ( .NOT. almaoutput ) THEN
             CALL histwrite_p(hist2_id, 'irrigmap', 1, irrigated, nbpt, index)
          ELSE
             CALL histwrite_p(hist2_id, 'IrrigationMap', 1, irrigated, nbpt, index)
          ENDIF
       ENDIF
    ENDIF
    
    IF ( do_floodplains ) THEN
       CALL xios_orchidee_send_field("floodmap",floodplains)
       
       IF (printlev>=3) WRITE(numout,*) 'Verification : range of floodplains : ', MINVAL(floodplains), MAXVAL(floodplains) 
       IF ( .NOT. almaoutput ) THEN
          CALL histwrite_p(hist_id, 'floodmap', 1, floodplains, nbpt, index)
       ELSE
          CALL histwrite_p(hist_id, 'FloodplainsMap', 1, floodplains, nbpt, index)
       ENDIF
       IF ( hist2_id > 0 ) THEN
          IF ( .NOT. almaoutput ) THEN
             CALL histwrite_p(hist2_id, 'floodmap', 1, floodplains, nbpt, index)
          ELSE
             CALL histwrite_p(hist2_id, 'FloodplainsMap', 1, floodplains, nbpt, index)
          ENDIF
       ENDIF
    ENDIF
    
    IF ( doswamps ) THEN
       CALL xios_orchidee_send_field("swampmap",swamp)
       
       IF (printlev>=3) WRITE(numout,*) 'Verification : range of swamp : ', MINVAL(swamp), MAXVAL(swamp) 
       IF ( .NOT. almaoutput ) THEN
          CALL histwrite_p(hist_id, 'swampmap', 1, swamp, nbpt, index)
       ELSE
          CALL histwrite_p(hist_id, 'SwampMap', 1, swamp, nbpt, index)
       ENDIF
       IF ( hist2_id > 0 ) THEN
          IF ( .NOT. almaoutput ) THEN
             CALL histwrite_p(hist2_id, 'swampmap', 1, swamp, nbpt, index)
          ELSE
             CALL histwrite_p(hist2_id, 'SwampMap', 1, swamp, nbpt, index)
          ENDIF
       ENDIF
    ENDIF
    
    !! This routine gives a diagnostic of the basins used.
    CALL routing_diagnostic_p(nbpt, index, lalo, resolution, contfrac, hist_id, hist2_id)
    
  END SUBROUTINE routing_initialize

!! ================================================================================================================================
!! SUBROUTINE   : routing_main 
!!
!>\BRIEF          This module routes the water over the continents (runoff and
!!                drainage produced by the hydrol module) into the oceans. 
!!
!! DESCRIPTION (definitions, functional, design, flags):
!! The routing scheme (Polcher, 2003) carries the water from the runoff and drainage simulated by SECHIBA
!! to the ocean through reservoirs, with some delay. The routing scheme is based on
!! a parametrization of the water flow on a global scale (Miller et al., 1994; Hagemann
!! and Dumenil, 1998). Given the global map of the main watersheds (Oki et al., 1999;
!! Fekete et al., 1999; Vorosmarty et al., 2000) which delineates the boundaries of subbasins
!! and gives the eight possible directions of water flow within the pixel, the surface
!! runoff and the deep drainage are routed to the ocean. The time-step of the routing is one day.
!! The scheme also diagnoses how much water is retained in the foodplains and thus return to soil
!! moisture or is taken out of the rivers for irrigation. \n
!!
!! RECENT CHANGE(S): None
!!
!! MAIN OUTPUT VARIABLE(S): 
!! The result of the routing are 3 fluxes :
!! - riverflow   : The water which flows out from the major rivers. The flux will be located
!!                 on the continental grid but this should be a coastal point.
!! - coastalflow : This is the water which flows in a disperse way into the ocean. Essentially these
!!                 are the outflows from all of the small rivers.
!! - returnflow  : This is the water which flows into a land-point - typically rivers which end in
!!                 the desert. This water will go back into the hydrol module to allow re-evaporation.
!! - irrigation  : This is water taken from the reservoir and is being put into the upper 
!!                 layers of the soil.
!! The two first fluxes are in kg/dt and the last two fluxes are in kg/(m^2dt).\n
!!
!! REFERENCE(S) :
!! - Miller JR, Russell GL, Caliri G (1994)
!!   Continental-scale river flow in climate models.
!!   J. Clim., 7:914-928
!! - Hagemann S and Dumenil L. (1998)
!!   A parametrization of the lateral waterflow for the global scale.
!!   Clim. Dyn., 14:17-31
!! - Oki, T., T. Nishimura, and P. Dirmeyer (1999)
!!   Assessment of annual runoff from land surface models using total runoff integrating pathways (TRIP)
!!   J. Meteorol. Soc. Jpn., 77, 235-255
!! - Fekete BM, Charles V, Grabs W (2000)
!!   Global, composite runoff fields based on observed river discharge and simulated water balances.
!!   Technical report, UNH/GRDC, Global Runoff Data Centre, Koblenz
!! - Vorosmarty, C., B. Fekete, B. Meybeck, and R. Lammers (2000)
!!   Global system of rivers: Its role in organizing continental land mass and defining land-to-ocean linkages
!!   Global Biogeochem. Cycles, 14, 599-621
!! - Vivant, A-C. (?? 2002)
!!   Développement du schéma de routage et des plaines d'inondation, MSc Thesis, Paris VI University
!! - J. Polcher (2003)
!!   Les processus de surface a l'echelle globale et leurs interactions avec l'atmosphere
!!   Habilitation a diriger les recherches, Paris VI University, 67pp.
!!
!! FLOWCHART    :
!! \latexonly 
!! \includegraphics[scale=0.75]{routing_main_flowchart.png}
!! \endlatexonly
!! \n
!_ ================================================================================================================================

SUBROUTINE routing_main(kjit, nbpt, index, &
       & lalo, neighbours, resolution, contfrac, totfrac_nobio, veget_max, floodout, runoff, &
       & drainage, transpot, precip_rain, humrel, k_litt, flood_frac, flood_res, &
       & stempdiag, reinf_slope, returnflow, reinfiltration, irrigation, riverflow, coastalflow, rest_id, hist_id, hist2_id)

    IMPLICIT NONE

    !! 0.1 Input variables
    INTEGER(i_std), INTENT(in)     :: kjit                 !! Time step number (unitless)
    INTEGER(i_std), INTENT(in)     :: nbpt                 !! Domain size (unitless)
    INTEGER(i_std),INTENT(in)      :: rest_id              !! Restart file identifier (unitless)
    INTEGER(i_std),INTENT(in)      :: hist_id              !! Access to history file (unitless)
    INTEGER(i_std),INTENT(in)      :: hist2_id             !! Access to history file 2 (unitless)
    INTEGER(i_std), INTENT(in)     :: index(nbpt)          !! Indices of the points on the map (unitless)
    REAL(r_std), INTENT(in)        :: lalo(nbpt,2)         !! Vector of latitude and longitudes (beware of the order !)
    INTEGER(i_std), INTENT(in)     :: neighbours(nbpt,NbNeighb)   !! Vector of neighbours for each grid point (1=N, 2=NE, 3=E, 4=SE, 5=S, 6=SW, 7=W, 8=NW) (unitless)
    REAL(r_std), INTENT(in)        :: resolution(nbpt,2)   !! The size of each grid box in X and Y (m)
    REAL(r_std), INTENT(in)        :: contfrac(nbpt)       !! Fraction of land in each grid box (unitless;0-1)
    REAL(r_std), INTENT(in)        :: totfrac_nobio(nbpt)  !! Total fraction of no-vegetation (continental ice, lakes ...) (unitless;0-1)
    REAL(r_std), INTENT(in)        :: veget_max(nbpt,nvm)  !! Maximal fraction of vegetation (unitless;0-1)
    REAL(r_std), INTENT(in)        :: floodout(nbpt)       !! Grid-point flow out of floodplains (kg/m^2/dt)
    REAL(r_std), INTENT(in)        :: runoff(nbpt)         !! Grid-point runoff (kg/m^2/dt)
    REAL(r_std), INTENT(in)        :: drainage(nbpt)       !! Grid-point drainage (kg/m^2/dt)
    REAL(r_std), INTENT(in)        :: transpot(nbpt,nvm)   !! Potential transpiration of the vegetation (kg/m^2/dt)
    REAL(r_std), INTENT(in)        :: precip_rain(nbpt)    !! Rainfall (kg/m^2/dt)
    REAL(r_std), INTENT(in)        :: k_litt(nbpt)         !! Averaged conductivity for saturated infiltration in the 'litter' layer (kg/m^2/dt)
    REAL(r_std), INTENT(in)        :: humrel(nbpt,nvm)     !! Soil moisture stress, root extraction potential (unitless)
    REAL(r_std), INTENT(in)        :: stempdiag(nbpt,nslm) !! Diagnostic soil temperature profile
    REAL(r_std), INTENT(in)        :: reinf_slope(nbpt)    !! Coefficient which determines the reinfiltration ratio in the grid box due to flat areas (unitless;0-1)

    !! 0.2 Output variables
    REAL(r_std), INTENT(out)       :: returnflow(nbpt)     !! The water flow from lakes and swamps which returns to the grid box.
                                                           !! This water will go back into the hydrol module to allow re-evaporation (kg/m^2/dt)
    REAL(r_std), INTENT(out)       :: reinfiltration(nbpt) !! Water flow from ponds and floodplains which returns to the grid box (kg/m^2/dt)
    REAL(r_std), INTENT(out)       :: irrigation(nbpt)     !! Irrigation flux. This is the water taken from the reservoirs and beeing put into the upper layers of the soil (kg/m^2/dt)
    REAL(r_std), INTENT(out)       :: riverflow(nbpt)      !! Outflow of the major rivers. The flux will be located on the continental grid but this should be a coastal point (kg/dt)
    REAL(r_std), INTENT(out)       :: coastalflow(nbpt)    !! Outflow on coastal points by small basins. This is the water which flows in a disperse way into the ocean (kg/dt)
    REAL(r_std), INTENT(out)       :: flood_frac(nbpt)     !! Flooded fraction of the grid box (unitless;0-1)
    REAL(r_std), INTENT(out)       :: flood_res(nbpt)      !! Diagnostic of water amount in the floodplains reservoir (kg)

    !! 0.3 Local variables
    CHARACTER(LEN=30)              :: var_name             !! To store variables names for I/O (unitless)
    REAL(r_std), DIMENSION(1)      :: tmp_day              !! 
    REAL(r_std), DIMENSION(nbpt)   :: return_lakes         !! Water from lakes flowing back into soil moisture (kg/m^2/dt)

    INTEGER(i_std)                 :: ig, jv               !! Indices (unitless)
    REAL(r_std), DIMENSION(nbpt)   :: tot_vegfrac_nowoody  !! Total fraction occupied by grass (0-1,unitless)

    REAL(r_std), DIMENSION(nbpt)   :: fast_diag_old        !! Reservoir in the beginning of the time step
    REAL(r_std), DIMENSION(nbpt)   :: slow_diag_old        !! Reservoir in the beginning of the time step
    REAL(r_std), DIMENSION(nbpt)   :: stream_diag_old      !! Reservoir in the beginning of the time step
    REAL(r_std), DIMENSION(nbpt)   :: lake_diag_old        !! Reservoir in the beginning of the time step
    REAL(r_std), DIMENSION(nbpt)   :: pond_diag_old        !! Reservoir in the beginning of the time step
    REAL(r_std), DIMENSION(nbpt)   :: flood_diag_old       !! Reservoir in the beginning of the time step

    !! For water budget check in the three routing reservoirs (positive if input > output)
    !! Net fluxes averaged over each grid cell in kg/m^2/dt
    REAL(r_std), DIMENSION(nbpt)   :: netflow_stream_diag  !! Input - Output flow to stream reservoir
    REAL(r_std), DIMENSION(nbpt)   :: netflow_fast_diag    !! Input - Output flow to fast reservoir
    REAL(r_std), DIMENSION(nbpt)   :: netflow_slow_diag    !! Input - Output flow to slow reservoir


!_ ================================================================================================================================

    ! Save reservoirs in beginning of time step to calculate the water budget
    fast_diag_old   = fast_diag
    slow_diag_old   = slow_diag
    stream_diag_old = stream_diag
    lake_diag_old   = lake_diag
    pond_diag_old   = pond_diag
    flood_diag_old  = flood_diag

    !
    !! Computes the variables averaged between routing time steps and which will be used in subsequent calculations
    !
    floodout_mean(:) = floodout_mean(:) + floodout(:)
    runoff_mean(:) = runoff_mean(:) + runoff(:)
    drainage_mean(:) = drainage_mean(:) + drainage(:)
    floodtemp(:) = stempdiag(:,floodtemp_lev)
    precip_mean(:) =  precip_mean(:) + precip_rain(:)
    !
    !! Computes the total fraction occupied by the grasses and the crops for each grid cell
    tot_vegfrac_nowoody(:) = zero
    DO jv  = 1, nvm
       IF ( (jv /= ibare_sechiba) .AND. .NOT.(is_tree(jv)) ) THEN
          tot_vegfrac_nowoody(:) = tot_vegfrac_nowoody(:) + veget_max(:,jv) 
       END IF
    END DO

    DO ig = 1, nbpt
       IF ( tot_vegfrac_nowoody(ig) .GT. min_sechiba ) THEN
          DO jv = 1,nvm
             IF ( (jv /= ibare_sechiba) .AND. .NOT.(is_tree(jv)) ) THEN
                transpot_mean(ig) = transpot_mean(ig) + transpot(ig,jv) * veget_max(ig,jv)/tot_vegfrac_nowoody(ig)  
             END IF
          END DO
       ELSE
          IF (MAXVAL(veget_max(ig,2:nvm)) .GT. min_sechiba) THEN
             DO jv = 2, nvm
                transpot_mean(ig) = transpot_mean(ig) + transpot(ig,jv) * veget_max(ig,jv)/ SUM(veget_max(ig,2:nvm))
             ENDDO
          ENDIF
       ENDIF
    ENDDO

    !
    ! Averaged variables (i.e. *dt_sechiba/dt_routing). This accounts for the difference between the shorter
    ! timestep dt_sechiba of other parts of the model and the long dt_routing timestep (set to one day at present)
    !
    totnobio_mean(:) = totnobio_mean(:) + totfrac_nobio(:)*dt_sechiba/dt_routing
    k_litt_mean(:) = k_litt_mean(:) + k_litt(:)*dt_sechiba/dt_routing
    !
    ! Only potentially vegetated surfaces are taken into account. At the start of
    ! the growing seasons we will give more weight to these areas.
    !
    DO jv=2,nvm
       DO ig=1,nbpt
          humrel_mean(ig) = humrel_mean(ig) + humrel(ig,jv)*veget_max(ig,jv)*dt_sechiba/dt_routing
          vegtot_mean(ig) = vegtot_mean(ig) + veget_max(ig,jv)*dt_sechiba/dt_routing
       ENDDO
    ENDDO
    !
    time_counter = time_counter + dt_sechiba 
    !
    ! If the time has come we do the routing.
    !
    IF ( NINT(time_counter) .GE. NINT(dt_routing) ) THEN 
       !
       !! Computes the transport of water in the various reservoirs
       !
       CALL routing_flow(nbpt, dt_routing, lalo, floodout_mean, runoff_mean, drainage_mean, &
            & vegtot_mean, totnobio_mean, transpot_mean, precip_mean, humrel_mean, k_litt_mean, floodtemp, reinf_slope, &
            & lakeinflow_mean, returnflow_mean, reinfiltration_mean, irrigation_mean, riverflow_mean, &
            & coastalflow_mean, hydrographs, slowflow_diag, flood_frac, flood_res, &
            & netflow_stream_diag, netflow_fast_diag, netflow_slow_diag)
       !
       !! Responsible for storing the water in lakes
       !
       CALL routing_lake(nbpt, dt_routing, lakeinflow_mean, humrel_mean, return_lakes)
       !
       returnflow_mean(:) = returnflow_mean(:) + return_lakes(:)

       time_counter = zero
       !
       floodout_mean(:) = zero
       runoff_mean(:) = zero
       drainage_mean(:) = zero
       transpot_mean(:) = zero
       precip_mean(:) = zero
       !
       humrel_mean(:) = zero
       totnobio_mean(:) = zero
       k_litt_mean(:) = zero
       vegtot_mean(:) = zero

       ! Change the units of the routing fluxes from kg/dt_routing into kg/dt_sechiba
       hydrographs(:) = hydrographs(:)/dt_routing*dt_sechiba
       slowflow_diag(:) = slowflow_diag(:)/dt_routing*dt_sechiba

       ! Change the units of the routing fluxes from kg/m^2/dt_routing into kg/m^2/dt_sechiba
       returnflow_mean(:) = returnflow_mean(:)/dt_routing*dt_sechiba
       reinfiltration_mean(:) = reinfiltration_mean(:)/dt_routing*dt_sechiba
       irrigation_mean(:) = irrigation_mean(:)/dt_routing*dt_sechiba
       irrig_netereq(:) = irrig_netereq(:)/dt_routing*dt_sechiba
       
       ! Change units as above but at the same time transform the kg/dt_routing to m^3/dt_sechiba
       riverflow_mean(:) = riverflow_mean(:)/dt_routing*dt_sechiba/mille
       coastalflow_mean(:) = coastalflow_mean(:)/dt_routing*dt_sechiba/mille

       ! Water budget residu of the three routing reservoirs (in kg/m^2/s)
       ! Note that these diagnostics are done using local variables only calculated 
       ! during the time steps when the routing is calculated
       CALL xios_orchidee_send_field("wbr_stream",(stream_diag - stream_diag_old - netflow_stream_diag)/dt_routing)
       CALL xios_orchidee_send_field("wbr_fast",  (fast_diag   - fast_diag_old - netflow_fast_diag)/dt_routing)
       CALL xios_orchidee_send_field("wbr_slow",  (slow_diag   - slow_diag_old - netflow_slow_diag)/dt_routing)
       CALL xios_orchidee_send_field("wbr_lake",  (lake_diag   - lake_diag_old - &
                                                   lakeinflow_mean + return_lakes)/dt_routing)
    ENDIF

    !
    ! Return the fraction of routed water for this time step.
    !
    returnflow(:) = returnflow_mean(:)
    reinfiltration(:) = reinfiltration_mean(:)
    irrigation(:) = irrigation_mean(:)
    riverflow(:) = riverflow_mean(:)
    coastalflow(:) = coastalflow_mean(:)

    !
    ! Write diagnostics
    !

    ! Water storage in reservoirs [kg/m^2]
    CALL xios_orchidee_send_field("fastr",fast_diag)
    CALL xios_orchidee_send_field("slowr",slow_diag)
    CALL xios_orchidee_send_field("streamr",stream_diag)
    CALL xios_orchidee_send_field("laker",lake_diag)
    CALL xios_orchidee_send_field("pondr",pond_diag)
    CALL xios_orchidee_send_field("floodr",flood_diag)
    CALL xios_orchidee_send_field("floodh",flood_height)

    ! Difference between the end and the beginning of the routing time step [kg/m^2]
    CALL xios_orchidee_send_field("delfastr",   fast_diag   - fast_diag_old)
    CALL xios_orchidee_send_field("delslowr",   slow_diag   - slow_diag_old)
    CALL xios_orchidee_send_field("delstreamr", stream_diag - stream_diag_old)
    CALL xios_orchidee_send_field("dellaker",   lake_diag   - lake_diag_old)
    CALL xios_orchidee_send_field("delpondr",   pond_diag   - pond_diag_old)
    CALL xios_orchidee_send_field("delfloodr",  flood_diag  - flood_diag_old)

    ! Water fluxes converted from kg/m^2/dt_sechiba into kg/m^2/s 
    CALL xios_orchidee_send_field("irrigation",irrigation/dt_sechiba)
    CALL xios_orchidee_send_field("netirrig",irrig_netereq/dt_sechiba)
    CALL xios_orchidee_send_field("riversret",returnflow/dt_sechiba)
    CALL xios_orchidee_send_field("reinfiltration",reinfiltration/dt_sechiba)

    ! Transform from kg/dt_sechiba into m^3/s
    CALL xios_orchidee_send_field("hydrographs",hydrographs/mille/dt_sechiba)
    CALL xios_orchidee_send_field("slowflow",slowflow_diag/mille/dt_sechiba) ! previous id name: Qb
    CALL xios_orchidee_send_field("coastalflow",coastalflow/dt_sechiba)
    CALL xios_orchidee_send_field("riverflow",riverflow/dt_sechiba)

    IF ( .NOT. almaoutput ) THEN
       !
       CALL histwrite_p(hist_id, 'riversret', kjit, returnflow, nbpt, index)
       IF (do_floodplains .OR. doponds) THEN
          CALL histwrite_p(hist_id, 'reinfiltration', kjit, reinfiltration, nbpt, index)
       ENDIF
       CALL histwrite_p(hist_id, 'hydrographs', kjit, hydrographs/mille, nbpt, index)
       !
       CALL histwrite_p(hist_id, 'fastr', kjit, fast_diag, nbpt, index)
       CALL histwrite_p(hist_id, 'slowr', kjit, slow_diag, nbpt, index)
       CALL histwrite_p(hist_id, 'streamr', kjit, stream_diag, nbpt, index)
       IF ( do_floodplains ) THEN
          CALL histwrite_p(hist_id, 'floodr', kjit, flood_diag, nbpt, index)
          CALL histwrite_p(hist_id, 'floodh', kjit, flood_height, nbpt, index)
       ENDIF
       CALL histwrite_p(hist_id, 'pondr', kjit, pond_diag, nbpt, index)
       CALL histwrite_p(hist_id, 'lakevol', kjit, lake_diag, nbpt, index)
       !
       IF ( do_irrigation ) THEN
          CALL histwrite_p(hist_id, 'irrigation', kjit, irrigation, nbpt, index)
          CALL histwrite_p(hist_id, 'returnflow', kjit, returnflow, nbpt, index)
          CALL histwrite_p(hist_id, 'netirrig', kjit, irrig_netereq, nbpt, index)
       ENDIF
       !
    ELSE
       CALL histwrite_p(hist_id, 'SurfStor', kjit, flood_diag+pond_diag+lake_diag, nbpt, index)
       CALL histwrite_p(hist_id, 'Dis', kjit, hydrographs/mille, nbpt, index)
       !
       CALL histwrite_p(hist_id, 'slowr', kjit, slow_diag, nbpt, index)
       CALL histwrite_p(hist_id, 'fastr', kjit, fast_diag, nbpt, index)
       CALL histwrite_p(hist_id, 'streamr', kjit, stream_diag, nbpt, index)
       CALL histwrite_p(hist_id, 'lakevol', kjit, lake_diag, nbpt, index)
       CALL histwrite_p(hist_id, 'pondr', kjit, pond_diag, nbpt, index)
       !
       IF ( do_irrigation ) THEN
          CALL histwrite_p(hist_id, 'Qirrig', kjit, irrigation, nbpt, index)
          CALL histwrite_p(hist_id, 'Qirrig_req', kjit, irrig_netereq, nbpt, index)
       ENDIF
       !
    ENDIF
    IF ( hist2_id > 0 ) THEN
       IF ( .NOT. almaoutput ) THEN
          !
          CALL histwrite_p(hist2_id, 'riversret', kjit, returnflow, nbpt, index)
          IF (do_floodplains .OR. doponds) THEN
             CALL histwrite_p(hist2_id, 'reinfiltration', kjit, reinfiltration, nbpt, index)
          ENDIF
          CALL histwrite_p(hist2_id, 'hydrographs', kjit, hydrographs/mille, nbpt, index)
          !
          CALL histwrite_p(hist2_id, 'fastr', kjit, fast_diag, nbpt, index)
          CALL histwrite_p(hist2_id, 'slowr', kjit, slow_diag, nbpt, index)
          IF ( do_floodplains ) THEN
             CALL histwrite_p(hist2_id, 'floodr', kjit, flood_diag, nbpt, index)
             CALL histwrite_p(hist2_id, 'floodh', kjit, flood_height, nbpt, index)
          ENDIF
          CALL histwrite_p(hist2_id, 'pondr', kjit, pond_diag, nbpt, index)
          CALL histwrite_p(hist2_id, 'streamr', kjit, stream_diag, nbpt, index)
          CALL histwrite_p(hist2_id, 'lakevol', kjit, lake_diag, nbpt, index)
          !
          IF ( do_irrigation ) THEN
             CALL histwrite_p(hist2_id, 'irrigation', kjit, irrigation, nbpt, index)
             CALL histwrite_p(hist2_id, 'returnflow', kjit, returnflow, nbpt, index)
             CALL histwrite_p(hist2_id, 'netirrig', kjit, irrig_netereq, nbpt, index)
          ENDIF
          !
       ELSE
          !
          CALL histwrite_p(hist2_id, 'SurfStor', kjit, flood_diag+pond_diag+lake_diag, nbpt, index)
          CALL histwrite_p(hist2_id, 'Dis', kjit, hydrographs/mille, nbpt, index)
          !
       ENDIF
    ENDIF
    !
    !
  END SUBROUTINE routing_main
  
  !!  =============================================================================================================================
  !! SUBROUTINE:         routing_finalize
  !!
  !>\BRIEF               Write to restart file
  !!
  !! DESCRIPTION:        Write module variables to restart file
  !!
  !! RECENT CHANGE(S)
  !!
  !! REFERENCE(S)
  !! 
  !! FLOWCHART   
  !! \n
  !_ ==============================================================================================================================

  SUBROUTINE routing_finalize( kjit, nbpt, rest_id, flood_frac, flood_res )
    
    IMPLICIT NONE
    
    !! 0.1 Input variables
    INTEGER(i_std), INTENT(in)     :: kjit                 !! Time step number (unitless)
    INTEGER(i_std), INTENT(in)     :: nbpt                 !! Domain size (unitless)
    INTEGER(i_std),INTENT(in)      :: rest_id              !! Restart file identifier (unitless)
    REAL(r_std), INTENT(in)        :: flood_frac(nbpt)     !! Flooded fraction of the grid box (unitless;0-1)
    REAL(r_std), INTENT(in)        :: flood_res(nbpt)      !! Diagnostic of water amount in the floodplains reservoir (kg)
    
    !! 0.2 Local variables
    REAL(r_std), DIMENSION(1)      :: tmp_day              

!_ ================================================================================================================================
    
    !
    ! Write restart variables
    !
    tmp_day(1) = time_counter
    IF (is_root_prc) CALL restput (rest_id, 'routingcounter', 1, 1, 1, kjit, tmp_day)

    CALL restput_p (rest_id, 'routingarea', nbp_glo, nbasmax, 1, kjit, routing_area, 'scatter',  nbp_glo, index_g)
    CALL restput_p (rest_id, 'routetogrid', nbp_glo, nbasmax, 1, kjit, REAL(route_togrid,r_std), 'scatter', &
         nbp_glo, index_g)
    CALL restput_p (rest_id, 'routetobasin', nbp_glo, nbasmax, 1, kjit, REAL(route_tobasin,r_std), 'scatter', &
         nbp_glo, index_g)
    CALL restput_p (rest_id, 'basinid', nbp_glo, nbasmax, 1, kjit, REAL(global_basinid,r_std), 'scatter', &
         nbp_glo, index_g)
    CALL restput_p (rest_id, 'topoindex', nbp_glo, nbasmax, 1, kjit, topo_resid, 'scatter',  nbp_glo, index_g)
    CALL restput_p (rest_id, 'fastres', nbp_glo, nbasmax, 1, kjit, fast_reservoir, 'scatter',  nbp_glo, index_g)
    CALL restput_p (rest_id, 'slowres', nbp_glo, nbasmax, 1, kjit, slow_reservoir, 'scatter',  nbp_glo, index_g)
    CALL restput_p (rest_id, 'streamres', nbp_glo, nbasmax, 1, kjit, stream_reservoir, 'scatter',nbp_glo,index_g)
    CALL restput_p (rest_id, 'floodres', nbp_glo, nbasmax, 1, kjit, flood_reservoir, 'scatter',  nbp_glo, index_g)
    CALL restput_p (rest_id, 'floodh', nbp_glo, 1, 1, kjit, flood_height, 'scatter',  nbp_glo, index_g)
    CALL restput_p (rest_id, 'flood_frac_bas', nbp_glo, nbasmax, 1, kjit, flood_frac_bas, 'scatter',  nbp_glo, index_g)
    CALL restput_p (rest_id, 'pond_frac', nbp_glo, 1, 1, kjit, pond_frac, 'scatter',  nbp_glo, index_g)
    CALL restput_p (rest_id, 'flood_frac', nbp_glo, 1, 1, kjit, flood_frac, 'scatter',  nbp_glo, index_g)
    CALL restput_p (rest_id, 'flood_res', nbp_glo, 1, 1, kjit, flood_res, 'scatter', nbp_glo, index_g)

    CALL restput_p (rest_id, 'lakeres', nbp_glo, 1, 1, kjit, lake_reservoir, 'scatter',  nbp_glo, index_g)
    CALL restput_p (rest_id, 'pondres', nbp_glo, 1, 1, kjit, pond_reservoir, 'scatter',  nbp_glo, index_g)

    CALL restput_p (rest_id, 'lakeinflow', nbp_glo, 1, 1, kjit, lakeinflow_mean, 'scatter',  nbp_glo, index_g)
    CALL restput_p (rest_id, 'returnflow', nbp_glo, 1, 1, kjit, returnflow_mean, 'scatter',  nbp_glo, index_g)
    CALL restput_p (rest_id, 'reinfiltration', nbp_glo, 1, 1, kjit, reinfiltration_mean, 'scatter',  nbp_glo, index_g)
    CALL restput_p (rest_id, 'riverflow', nbp_glo, 1, 1, kjit, riverflow_mean, 'scatter',  nbp_glo, index_g)
    CALL restput_p (rest_id, 'coastalflow', nbp_glo, 1, 1, kjit, coastalflow_mean, 'scatter',  nbp_glo, index_g)
    CALL restput_p (rest_id, 'hydrographs', nbp_glo, 1, 1, kjit, hydrographs, 'scatter',  nbp_glo, index_g)
    CALL restput_p (rest_id, 'slowflow_diag', nbp_glo, 1, 1, kjit, slowflow_diag, 'scatter',  nbp_glo, index_g)
    !
    ! Keep track of the accumulated variables
    !
    CALL restput_p (rest_id, 'floodout_route', nbp_glo, 1, 1, kjit, floodout_mean, 'scatter',  nbp_glo, index_g)
    CALL restput_p (rest_id, 'runoff_route', nbp_glo, 1, 1, kjit, runoff_mean, 'scatter',  nbp_glo, index_g)
    CALL restput_p (rest_id, 'drainage_route', nbp_glo, 1, 1, kjit, drainage_mean, 'scatter',  nbp_glo, index_g)
    CALL restput_p (rest_id, 'transpot_route', nbp_glo, 1, 1, kjit, transpot_mean, 'scatter',  nbp_glo, index_g)
    CALL restput_p (rest_id, 'precip_route', nbp_glo, 1, 1, kjit, precip_mean, 'scatter',  nbp_glo, index_g)
    CALL restput_p (rest_id, 'humrel_route', nbp_glo, 1, 1, kjit, humrel_mean, 'scatter',  nbp_glo, index_g)
    CALL restput_p (rest_id, 'totnobio_route', nbp_glo, 1, 1, kjit, totnobio_mean, 'scatter',  nbp_glo, index_g)
    CALL restput_p (rest_id, 'k_litt_route', nbp_glo, 1, 1, kjit, k_litt_mean, 'scatter',  nbp_glo, index_g)
    CALL restput_p (rest_id, 'vegtot_route', nbp_glo, 1, 1, kjit, vegtot_mean, 'scatter',  nbp_glo, index_g)

    IF ( do_irrigation ) THEN
       CALL restput_p (rest_id, 'irrigated', nbp_glo, 1, 1, kjit, irrigated, 'scatter',  nbp_glo, index_g)
       CALL restput_p (rest_id, 'irrigation', nbp_glo, 1, 1, kjit, irrigation_mean, 'scatter',  nbp_glo, index_g)
    ENDIF

    IF ( do_floodplains ) THEN
       CALL restput_p (rest_id, 'floodplains', nbp_glo, 1, 1, kjit, floodplains, 'scatter',  nbp_glo, index_g)
    ENDIF
    IF ( doswamps ) THEN
       CALL restput_p (rest_id, 'swamp', nbp_glo, 1, 1, kjit, swamp, 'scatter',  nbp_glo, index_g)
    ENDIF
  
  END SUBROUTINE routing_finalize

!! ================================================================================================================================
!! SUBROUTINE   : routing_init
!!
!>\BRIEF         This subroutine allocates the memory and get the fixed fields from the restart file.
!!
!! DESCRIPTION (definitions, functional, design, flags) : None
!!
!! RECENT CHANGE(S): None
!!
!! MAIN OUTPUT VARIABLE(S):
!!
!! REFERENCES   : None
!!
!! FLOWCHART    :None
!! \n
!_ ================================================================================================================================

  SUBROUTINE routing_init(kjit, nbpt, index, returnflow, reinfiltration, irrigation, &
       &                  riverflow, coastalflow, flood_frac, flood_res, stempdiag, rest_id)
    !
    IMPLICIT NONE
    !
    ! interface description
    !
!! INPUT VARIABLES
    INTEGER(i_std), INTENT(in)                   :: kjit           !! Time step number (unitless)
    INTEGER(i_std), INTENT(in)                   :: nbpt           !! Domain size (unitless)
    INTEGER(i_std), DIMENSION (nbpt), INTENT(in) :: index          !! Indices of the points on the map (unitless)
    REAL(r_std), DIMENSION(nbpt,nslm),INTENT(in) :: stempdiag      !! Temperature profile in soil
    INTEGER(i_std), INTENT(in)                   :: rest_id        !! Restart file identifier (unitless)
    !
!! OUTPUT VARIABLES
    REAL(r_std), DIMENSION (nbpt),INTENT(out)    :: returnflow     !! The water flow from lakes and swamps which returns into the grid box.
                                                                   !! This water will go back into the hydrol module to allow re-evaporation (kg/m^2/dt)
    REAL(r_std), DIMENSION (nbpt),INTENT(out)    :: reinfiltration !! Water flow from ponds and floodplains which returns to the grid box (kg/m^2/dt)
    REAL(r_std), DIMENSION (nbpt),INTENT(out)    :: irrigation     !! Irrigation flux. This is the water taken from the reservoirs and beeing put into the upper layers of the soil.(kg/m^2/dt)
    REAL(r_std), DIMENSION (nbpt),INTENT(out)    :: riverflow      !! Outflow of the major rivers. The flux will be located on the continental grid but this should be a coastal point (kg/dt)
    REAL(r_std), DIMENSION (nbpt),INTENT(out)    :: coastalflow    !! Outflow on coastal points by small basins. This is the water which flows in a disperse way into the ocean (kg/dt)
    REAL(r_std), DIMENSION (nbpt),INTENT(out)    :: flood_frac     !! Flooded fraction of the grid box (unitless;0-1)
    REAL(r_std), DIMENSION (nbpt),INTENT(out)    :: flood_res      !! Diagnostic of water amount in the floodplains reservoir (kg)
    !
!! LOCAL VARIABLES
    CHARACTER(LEN=80)                            :: var_name       !! To store variables names for I/O (unitless)
    REAL(r_std), ALLOCATABLE, DIMENSION(:,:)     :: tmp_real_g     !! A temporary real array for the integers
    REAL(r_std), DIMENSION(1)                    :: tmp_day        !!
    REAL(r_std)                                  :: ratio          !! Diagnostic ratio to check that dt_routing is a multiple of dt_sechiba (unitless)
    REAL(r_std)                                  :: totarea        !! Total area of basin (m^2)
    INTEGER(i_std)                               :: ier, ig, ib, ipn(1) !! Indices (unitless)

!_ ================================================================================================================================
    !
    !
    ! These variables will require the configuration infrastructure
    !
    !Config Key   = DT_ROUTING 
    !Config If    = RIVER_ROUTING
    !Config Desc  = Time step of the routing scheme
    !Config Def   = one_day
    !Config Help  = This values gives the time step in seconds of the routing scheme. 
    !Config         It should be multiple of the main time step of ORCHIDEE. One day
    !Config         is a good value.
    !Config Units = [seconds]
    !
    dt_routing = one_day
    CALL getin_p('DT_ROUTING', dt_routing)
    !
    !Config Key   = ROUTING_RIVERS
    !Config If    = RIVER_ROUTING
    !Config Desc  = Number of rivers 
    !Config Def   = 50
    !Config Help  = This parameter chooses the number of largest river basins
    !Config         which should be treated as independently as rivers and not
    !Config         flow into the oceans as diffusion coastal flow.
    !Config Units = [-]
    num_largest = 50
    CALL getin_p('ROUTING_RIVERS', num_largest)
    !
    !Config Key   = DO_FLOODINFILT
    !Config Desc  = Should floodplains reinfiltrate into the soil 
    !Config If    = RIVER_ROUTING
    !Config Def   = n
    !Config Help  = This parameters allows the user to ask the model
    !Config         to take into account the flood plains reinfiltration 
    !Config         into the soil moisture. It then can go 
    !Config         back to the slow and fast reservoirs
    !Config Units = [FLAG]
    !
    dofloodinfilt = .FALSE.
    CALL getin_p('DO_FLOODINFILT', dofloodinfilt)
    !
    !Config Key   = DO_SWAMPS
    !Config Desc  = Should we include swamp parameterization 
    !Config If    = RIVER_ROUTING
    !Config Def   = n
    !Config Help  = This parameters allows the user to ask the model
    !Config         to take into account the swamps and return 
    !Config         the water into the bottom of the soil. It then can go 
    !Config         back to the atmopshere. This tried to simulate 
    !Config         internal deltas of rivers.
    !Config Units = [FLAG]
    !
    doswamps = .FALSE.
    CALL getin_p('DO_SWAMPS', doswamps)
    !
    !Config Key   = DO_PONDS
    !Config Desc  = Should we include ponds 
    !Config If    = RIVER_ROUTING
    !Config Def   = n
    !Config Help  = This parameters allows the user to ask the model
    !Config         to take into account the ponds and return 
    !Config         the water into the soil moisture. It then can go 
    !Config         back to the atmopshere. This tried to simulate 
    !Config         little ponds especially in West Africa.
    !Config Units = [FLAG]
    !
    doponds = .FALSE.
    CALL getin_p('DO_PONDS', doponds)


    !Config Key   = SLOW_TCST
    !Config Desc  = Time constant for the slow reservoir 
    !Config If    = RIVER_ROUTING 
    !Config Def   = 25.0 
    !Config Help  = This parameters allows the user to fix the 
    !Config         time constant (in days) of the slow reservoir
    !Config         in order to get better river flows for 
    !Config         particular regions.
    !Config Units = [days]
    !
!> A value for property of each reservoir (in day/m) is given to compute a time constant (in day)
!> for each reservoir (product of tcst and topo_resid).
!> The value of tcst has been calibrated for the three reservoirs over the Senegal river basin only,
!> during the 1 degree NCEP Corrected by Cru (NCC) resolution simulations (Ngo-Duc et al., 2005, Ngo-Duc et al., 2006) and
!> generalized for all the basins of the world. The "slow reservoir" and the "fast reservoir"
!> have the highest value in order to simulate the groundwater. 
!> The "stream reservoir", which represents all the water of the stream, has the lowest value.
!> Those figures are the same for all the basins of the world.
!> The value of slow_tcst is equal to fast_tcst when CWRR is activated.
!> This assumption should be re-discussed.
    !
    CALL getin_p('SLOW_TCST', slow_tcst)
    !
    !Config Key   = FAST_TCST
    !Config Desc  = Time constant for the fast reservoir 
    !Config If    = RIVER_ROUTING 
    !Config Def   = 3.0 
    !Config Help  = This parameters allows the user to fix the 
    !Config         time constant (in days) of the fast reservoir
    !Config         in order to get better river flows for 
    !Config         particular regions.
    !Config Units = [days]
    CALL getin_p('FAST_TCST', fast_tcst)
    
    !Config Key   = STREAM_TCST
    !Config Desc  = Time constant for the stream reservoir 
    !Config If    = RIVER_ROUTING
    !Config Def   = 0.24
    !Config Help  = This parameters allows the user to fix the 
    !Config         time constant (in days) of the stream reservoir
    !Config         in order to get better river flows for 
    !Config         particular regions.
    !Config Units = [days]
    CALL getin_p('STREAM_TCST', stream_tcst)
    
    !Config Key   = FLOOD_TCST
    !Config Desc  = Time constant for the flood reservoir 
    !Config If    = RIVER_ROUTING
    !Config Def   = 4.0
    !Config Help  = This parameters allows the user to fix the 
    !Config         time constant (in days) of the flood reservoir
    !Config         in order to get better river flows for 
    !Config         particular regions.
    !Config Units = [days]
    CALL getin_p('FLOOD_TCST', flood_tcst)
    
    !Config Key   = SWAMP_CST
    !Config Desc  = Fraction of the river that flows back to swamps 
    !Config If    = RIVER_ROUTING
    !Config Def   = 0.2
    !Config Help  = This parameters allows the user to fix the 
    !Config         fraction of the river transport
    !Config         that flows to swamps
    !Config Units = [-]
    CALL getin_p('SWAMP_CST', swamp_cst)
    
    !Config Key   = FLOOD_BETA
    !Config Desc  = Parameter to fix the shape of the floodplain  
    !Config If    = RIVER_ROUTING
    !Config Def   = 2.0
    !Config Help  = Parameter to fix the shape of the floodplain
    !Config         (>1 for convex edges, <1 for concave edges)
    !Config Units = [-] 
    CALL getin_p("FLOOD_BETA", beta)
    !
    !Config Key   = POND_BETAP
    !Config Desc  = Ratio of the basin surface intercepted by ponds and the maximum surface of ponds
    !Config If    = RIVER_ROUTING
    !Config Def   = 0.5
    !Config Help  = 
    !Config Units = [-] 
    CALL getin_p("POND_BETAP", betap)    
    !
    !Config Key   = FLOOD_CRI
    !Config Desc  = Potential height for which all the basin is flooded
    !Config If    = DO_FLOODPLAINS or DO_PONDS
    !Config Def   = 2000.
    !Config Help  = 
    !Config Units = [mm] 
    CALL getin_p("FLOOD_CRI", floodcri)
    !
    !Config Key   = POND_CRI
    !Config Desc  = Potential height for which all the basin is a pond
    !Config If    = DO_FLOODPLAINS or DO_PONDS
    !Config Def   = 2000.
    !Config Help  = 
    !Config Units = [mm] 
    CALL getin_p("POND_CRI", pondcri)

    !Config Key   = MAX_LAKE_RESERVOIR
    !Config Desc  = Maximum limit of water in lake_reservoir
    !Config If    = RIVER_ROUTING
    !Config Def   = 7000
    !Config Help  = 
    !Config Units = [kg/m2(routing area)] 
    max_lake_reservoir = 7000
    CALL getin_p("MAX_LAKE_RESERVOIR", max_lake_reservoir)

    !
    !
    ! In order to simplify the time cascade check that dt_routing
    ! is a multiple of dt_sechiba
    !
    ratio = dt_routing/dt_sechiba
    IF ( ABS(NINT(ratio) - ratio) .GT. 10*EPSILON(ratio)) THEN
       WRITE(numout,*) 'WARNING -- WARNING -- WARNING -- WARNING'
       WRITE(numout,*) "The chosen time step for the routing is not a multiple of the"
       WRITE(numout,*) "main time step of the model. We will change dt_routing so that"
       WRITE(numout,*) "this condition os fulfilled"
       dt_routing = NINT(ratio) * dt_sechiba
       WRITE(numout,*) 'THE NEW DT_ROUTING IS : ', dt_routing
    ENDIF
    !
    IF ( dt_routing .LT. dt_sechiba) THEN
       WRITE(numout,*) 'WARNING -- WARNING -- WARNING -- WARNING'
       WRITE(numout,*) 'The routing timestep can not be smaller than the one'
       WRITE(numout,*) 'of the model. We reset its value to the model''s timestep.'
       WRITE(numout,*) 'The old DT_ROUTING is : ', dt_routing
       dt_routing = dt_sechiba
       WRITE(numout,*) 'THE NEW DT_ROUTING IS : ', dt_routing
    ENDIF
    !
    var_name ="routingcounter"
    IF (is_root_prc) THEN
       CALL ioconf_setatt('UNITS', 's')
       CALL ioconf_setatt('LONG_NAME','Time counter for the routing scheme')
       CALL restget (rest_id, var_name, 1, 1, 1, kjit, .TRUE., tmp_day)
       IF (tmp_day(1) == val_exp) THEN
          ! The variable was not found in restart file, initialize to zero
          time_counter = zero
       ELSE
          ! Take the value from restart file
          time_counter = tmp_day(1) 
       ENDIF
    ENDIF
    CALL bcast(time_counter)

    
    ALLOCATE (routing_area_loc(nbpt,nbasmax), stat=ier)
    IF (ier /= 0) CALL ipslerr_p(3,'routing_init','Pb in allocate for routing_area_loc','','')

    ALLOCATE (routing_area_glo(nbp_glo,nbasmax))
    IF (ier /= 0) CALL ipslerr_p(3,'routing_init','Pb in allocate for routing_area_glo','','')
    var_name = 'routingarea'
    IF (is_root_prc) THEN
       CALL ioconf_setatt('UNITS', 'm^2')
       CALL ioconf_setatt('LONG_NAME','Area of basin')
       CALL restget (rest_id, var_name, nbp_glo, nbasmax, 1, kjit, .TRUE., routing_area_glo, "gather", nbp_glo, index_g)
    ENDIF
    CALL scatter(routing_area_glo,routing_area_loc)
    routing_area=>routing_area_loc

    ALLOCATE (tmp_real_g(nbp_glo,nbasmax), stat=ier)
    IF (ier /= 0) CALL ipslerr_p(3,'routing_init','Pb in allocate for tmp_real_g','','')

    ALLOCATE (route_togrid_loc(nbpt,nbasmax), stat=ier)
    IF (ier /= 0) CALL ipslerr_p(3,'routing_init','Pb in allocate for route_togrid_loc','','')
    ALLOCATE (route_togrid_glo(nbp_glo,nbasmax), stat=ier)      ! used in global in routing_flow
    IF (ier /= 0) CALL ipslerr_p(3,'routing_init','Pb in allocate for route_togrid_glo','','')

    IF (is_root_prc) THEN
       var_name = 'routetogrid'
       CALL ioconf_setatt('UNITS', '-')
       CALL ioconf_setatt('LONG_NAME','Grid into which the basin flows')
       CALL restget (rest_id, var_name, nbp_glo, nbasmax, 1, kjit, .TRUE., tmp_real_g, "gather", nbp_glo, index_g)
       route_togrid_glo(:,:) = undef_int
       WHERE ( tmp_real_g .LT. val_exp )
          route_togrid_glo = NINT(tmp_real_g)
    ENDWHERE
    ENDIF
    CALL bcast(route_togrid_glo)                      ! used in global in routing_flow
    CALL scatter(route_togrid_glo,route_togrid_loc)
    route_togrid=>route_togrid_loc
    !
    ALLOCATE (route_tobasin_loc(nbpt,nbasmax), stat=ier)
    IF (ier /= 0) CALL ipslerr_p(3,'routing_init','Pb in allocate for route_tobasin_loc','','')

    ALLOCATE (route_tobasin_glo(nbp_glo,nbasmax), stat=ier)
    IF (ier /= 0) CALL ipslerr_p(3,'routing_init','Pb in allocate for route_tobasin_glo','','')

    IF (is_root_prc) THEN
       var_name = 'routetobasin'
       CALL ioconf_setatt('UNITS', '-')
       CALL ioconf_setatt('LONG_NAME','Basin in to which the water goes')
       CALL restget (rest_id, var_name, nbp_glo, nbasmax, 1, kjit, .TRUE., tmp_real_g, "gather", nbp_glo, index_g)
       route_tobasin_glo = undef_int
       WHERE ( tmp_real_g .LT. val_exp )
         route_tobasin_glo = NINT(tmp_real_g)
      ENDWHERE
    ENDIF
    CALL scatter(route_tobasin_glo,route_tobasin_loc)
    route_tobasin=>route_tobasin_loc
    !
    ! nbintobasin
    !
    ALLOCATE (route_nbintobas_loc(nbpt,nbasmax), stat=ier)
    IF (ier /= 0) CALL ipslerr_p(3,'routing_init','Pb in allocate for route_nbintobas_loc','','')
    ALLOCATE (route_nbintobas_glo(nbp_glo,nbasmax), stat=ier)
    IF (ier /= 0) CALL ipslerr_p(3,'routing_init','Pb in allocate for route_nbintobas_glo','','')

    IF (is_root_prc) THEN
       var_name = 'routenbintobas'
       CALL ioconf_setatt('UNITS', '-')
       CALL ioconf_setatt('LONG_NAME','Number of basin into current one')
       CALL restget (rest_id, var_name, nbp_glo, nbasmax, 1, kjit, .TRUE., tmp_real_g, "gather", nbp_glo, index_g)
       route_nbintobas_glo = undef_int
       WHERE ( tmp_real_g .LT. val_exp )
         route_nbintobas_glo = NINT(tmp_real_g)
      ENDWHERE
    ENDIF
    CALL scatter(route_nbintobas_glo,route_nbintobas_loc)
    route_nbintobas=>route_nbintobas_loc
    !
    ALLOCATE (global_basinid_loc(nbpt,nbasmax), stat=ier)
    IF (ier /= 0) CALL ipslerr_p(3,'routing_init','Pb in allocate for global_basinid_loc','','')
    ALLOCATE (global_basinid_glo(nbp_glo,nbasmax), stat=ier)
    IF (ier /= 0) CALL ipslerr_p(3,'routing_init','Pb in allocate for global_basinid_glo','','')

    IF (is_root_prc) THEN
       var_name = 'basinid'
       CALL ioconf_setatt('UNITS', '-')
       CALL ioconf_setatt('LONG_NAME','ID of basin')
       CALL restget (rest_id, var_name, nbp_glo, nbasmax, 1, kjit, .TRUE., tmp_real_g, "gather", nbp_glo, index_g)
       global_basinid_glo = undef_int
       WHERE ( tmp_real_g .LT. val_exp )
          global_basinid_glo = NINT(tmp_real_g)
       ENDWHERE
    ENDIF
    CALL scatter(global_basinid_glo,global_basinid_loc)
    global_basinid=>global_basinid_loc
    !
    ALLOCATE (topo_resid_loc(nbpt,nbasmax), stat=ier)
    IF (ier /= 0) CALL ipslerr_p(3,'routing_init','Pb in allocate for topo_resid_loc','','')
    ALLOCATE (topo_resid_glo(nbp_glo,nbasmax), stat=ier)
    IF (ier /= 0) CALL ipslerr_p(3,'routing_init','Pb in allocate for topo_resid_glo','','')

    IF (is_root_prc) THEN
       var_name = 'topoindex'
       CALL ioconf_setatt('UNITS', 'm')
       CALL ioconf_setatt('LONG_NAME','Topographic index of the residence time')
       CALL restget (rest_id, var_name, nbp_glo, nbasmax, 1, kjit, .TRUE., topo_resid_glo, "gather", nbp_glo, index_g)
    ENDIF
    CALL scatter(topo_resid_glo,topo_resid_loc)
    topo_resid=>topo_resid_loc

    ALLOCATE (fast_reservoir(nbpt,nbasmax), stat=ier)
    IF (ier /= 0) CALL ipslerr_p(3,'routing_init','Pb in allocate for fast_reservoir','','')
    var_name = 'fastres'
    CALL ioconf_setatt_p('UNITS', 'Kg')
    CALL ioconf_setatt_p('LONG_NAME','Water in the fast reservoir')
    CALL restget_p (rest_id, var_name, nbp_glo, nbasmax, 1, kjit, .TRUE., fast_reservoir, "gather", nbp_glo, index_g)
    CALL setvar_p (fast_reservoir, val_exp, 'NO_KEYWORD', zero)

    ALLOCATE (slow_reservoir(nbpt,nbasmax), stat=ier)
    IF (ier /= 0) CALL ipslerr_p(3,'routing_init','Pb in allocate for slow_reservoir','','')
    var_name = 'slowres'
    CALL ioconf_setatt_p('UNITS', 'Kg')
    CALL ioconf_setatt_p('LONG_NAME','Water in the slow reservoir')
    CALL restget_p (rest_id, var_name, nbp_glo, nbasmax, 1, kjit, .TRUE., slow_reservoir, "gather", nbp_glo, index_g)
    CALL setvar_p (slow_reservoir, val_exp, 'NO_KEYWORD', zero)

    ALLOCATE (stream_reservoir(nbpt,nbasmax), stat=ier)
    IF (ier /= 0) CALL ipslerr_p(3,'routing_init','Pb in allocate for stream_reservoir','','')
    var_name = 'streamres'
    CALL ioconf_setatt_p('UNITS', 'Kg')
    CALL ioconf_setatt_p('LONG_NAME','Water in the stream reservoir')
    CALL restget_p (rest_id, var_name, nbp_glo, nbasmax, 1, kjit, .TRUE., stream_reservoir, "gather", nbp_glo, index_g)
    CALL setvar_p (stream_reservoir, val_exp, 'NO_KEYWORD', zero)

    ALLOCATE (flood_reservoir(nbpt,nbasmax), stat=ier)
    IF (ier /= 0) CALL ipslerr_p(3,'routing_init','Pb in allocate for flood_reservoir','','')
    var_name = 'floodres'
    CALL ioconf_setatt_p('UNITS', 'Kg')
    CALL ioconf_setatt_p('LONG_NAME','Water in the flood reservoir')
    CALL restget_p (rest_id, var_name, nbp_glo, nbasmax, 1, kjit, .TRUE., flood_reservoir, "gather", nbp_glo, index_g)
    CALL setvar_p (flood_reservoir, val_exp, 'NO_KEYWORD', zero)

    ALLOCATE (flood_frac_bas(nbpt,nbasmax), stat=ier)
    IF (ier /= 0) CALL ipslerr_p(3,'routing_init','Pb in allocate for flood_frac_bas','','')
    var_name = 'flood_frac_bas'
    CALL ioconf_setatt_p('UNITS', '-')
    CALL ioconf_setatt_p('LONG_NAME','Flooded fraction per basin')
    CALL restget_p (rest_id, var_name, nbp_glo, nbasmax, 1, kjit, .TRUE., flood_frac_bas, "gather", nbp_glo, index_g)
    CALL setvar_p (flood_frac_bas, val_exp, 'NO_KEYWORD', zero)

    ALLOCATE (flood_height(nbpt), stat=ier)
    IF (ier /= 0) CALL ipslerr_p(3,'routing_init','Pb in allocate for flood_height','','')
    var_name = 'floodh'
    CALL ioconf_setatt_p('UNITS', '-')
    CALL ioconf_setatt_p('LONG_NAME','')
    CALL restget_p (rest_id, var_name, nbp_glo, 1, 1, kjit, .TRUE., flood_height, "gather", nbp_glo, index_g)
    CALL setvar_p (flood_height, val_exp, 'NO_KEYWORD', zero)
    
    ALLOCATE (pond_frac(nbpt), stat=ier)
    IF (ier /= 0) CALL ipslerr_p(3,'routing_init','Pb in allocate for pond_frac','','')
    var_name = 'pond_frac'
    CALL ioconf_setatt_p('UNITS', '-')
    CALL ioconf_setatt_p('LONG_NAME','Pond fraction per grid box')
    CALL restget_p (rest_id, var_name, nbp_glo, 1, 1, kjit, .TRUE., pond_frac, "gather", nbp_glo, index_g)
    CALL setvar_p (pond_frac, val_exp, 'NO_KEYWORD', zero)
    
    var_name = 'flood_frac'
    CALL ioconf_setatt_p('UNITS', '-')
    CALL ioconf_setatt_p('LONG_NAME','Flooded fraction per grid box')
    CALL restget_p (rest_id, var_name, nbp_glo, 1, 1, kjit, .TRUE., flood_frac, "gather", nbp_glo, index_g)
    CALL setvar_p (flood_frac, val_exp, 'NO_KEYWORD', zero)
    
    var_name = 'flood_res'
    CALL ioconf_setatt_p('UNITS','mm')
    CALL ioconf_setatt_p('LONG_NAME','Flooded quantity (estimation)')
    CALL restget_p (rest_id, var_name, nbp_glo, 1, 1, kjit, .TRUE., flood_res, "gather", nbp_glo, index_g)
    CALL setvar_p (flood_res, val_exp, 'NO_KEYWORD', zero)
!    flood_res = zero
    
    ALLOCATE (lake_reservoir(nbpt), stat=ier)
    IF (ier /= 0) CALL ipslerr_p(3,'routing_init','Pb in allocate for lake_reservoir','','')
    var_name = 'lakeres'
    CALL ioconf_setatt_p('UNITS', 'Kg')
    CALL ioconf_setatt_p('LONG_NAME','Water in the lake reservoir')
    CALL restget_p (rest_id, var_name, nbp_glo, 1, 1, kjit, .TRUE., lake_reservoir, "gather", nbp_glo, index_g)
    CALL setvar_p (lake_reservoir, val_exp, 'NO_KEYWORD', zero)
    
    ALLOCATE (pond_reservoir(nbpt), stat=ier)
    IF (ier /= 0) CALL ipslerr_p(3,'routing_init','Pb in allocate for pond_reservoir','','')
    var_name = 'pondres'
    CALL ioconf_setatt_p('UNITS', 'Kg')
    CALL ioconf_setatt_p('LONG_NAME','Water in the pond reservoir')
    CALL restget_p (rest_id, var_name, nbp_glo, 1, 1, kjit, .TRUE., pond_reservoir, "gather", nbp_glo, index_g)
    CALL setvar_p (pond_reservoir, val_exp, 'NO_KEYWORD', zero)
    !
    ! Map of irrigated areas
    !
    IF ( do_irrigation ) THEN
       ALLOCATE (irrigated(nbpt), stat=ier)
       IF (ier /= 0) CALL ipslerr_p(3,'routing_init','Pb in allocate for irrigated','','')
       var_name = 'irrigated'
       CALL ioconf_setatt_p('UNITS', 'm^2')
       CALL ioconf_setatt_p('LONG_NAME','Surface of irrigated area')
       CALL restget_p (rest_id, var_name, nbp_glo, 1, 1, kjit, .TRUE., irrigated, "gather", nbp_glo, index_g)
       CALL setvar_p (irrigated, val_exp, 'NO_KEYWORD', undef_sechiba)
    ENDIF
    
    IF ( do_floodplains ) THEN
       ALLOCATE (floodplains(nbpt), stat=ier)
       IF (ier /= 0) CALL ipslerr_p(3,'routing_init','Pb in allocate for floodplains','','')
       var_name = 'floodplains'
       CALL ioconf_setatt_p('UNITS', 'm^2')
       CALL ioconf_setatt_p('LONG_NAME','Surface which can be flooded')
       CALL restget_p (rest_id, var_name, nbp_glo, 1, 1, kjit, .TRUE., floodplains, "gather", nbp_glo, index_g)
       CALL setvar_p (floodplains, val_exp, 'NO_KEYWORD', undef_sechiba)
    ENDIF
    IF ( doswamps ) THEN
       ALLOCATE (swamp(nbpt), stat=ier)
       IF (ier /= 0) CALL ipslerr_p(3,'routing_init','Pb in allocate for swamp','','')
       var_name = 'swamp'
       CALL ioconf_setatt_p('UNITS', 'm^2')
       CALL ioconf_setatt_p('LONG_NAME','Surface which can become swamp')
       CALL restget_p (rest_id, var_name, nbp_glo, 1, 1, kjit, .TRUE., swamp, "gather", nbp_glo, index_g)
       CALL setvar_p (swamp, val_exp, 'NO_KEYWORD', undef_sechiba)
    ENDIF
    !
    ! Put into the restart file the fluxes so that they can be regenerated at restart.
    !
    ALLOCATE (lakeinflow_mean(nbpt), stat=ier)
    IF (ier /= 0) CALL ipslerr_p(3,'routing_init','Pb in allocate for lakeinflow_mean','','')
    var_name = 'lakeinflow'
    CALL ioconf_setatt_p('UNITS', 'Kg/dt')
    CALL ioconf_setatt_p('LONG_NAME','Lake inflow')
    CALL restget_p (rest_id, var_name, nbp_glo, 1, 1, kjit, .TRUE., lakeinflow_mean, "gather", nbp_glo, index_g)
    CALL setvar_p (lakeinflow_mean, val_exp, 'NO_KEYWORD', zero)
    
    ALLOCATE (returnflow_mean(nbpt), stat=ier)
    IF (ier /= 0) CALL ipslerr_p(3,'routing_init','Pb in allocate for returnflow_mean','','')
    var_name = 'returnflow'
    CALL ioconf_setatt_p('UNITS', 'Kg/m^2/dt')
    CALL ioconf_setatt_p('LONG_NAME','Deep return flux')
    CALL restget_p (rest_id, var_name, nbp_glo, 1, 1, kjit, .TRUE., returnflow_mean, "gather", nbp_glo, index_g)
    CALL setvar_p (returnflow_mean, val_exp, 'NO_KEYWORD', zero)
    returnflow(:) = returnflow_mean(:)
    
    ALLOCATE (reinfiltration_mean(nbpt), stat=ier)
    IF (ier /= 0) CALL ipslerr_p(3,'routing_init','Pb in allocate for reinfiltration_mean','','')
    var_name = 'reinfiltration'
    CALL ioconf_setatt_p('UNITS', 'Kg/m^2/dt')
    CALL ioconf_setatt_p('LONG_NAME','Top return flux')
    CALL restget_p (rest_id, var_name, nbp_glo, 1, 1, kjit, .TRUE., reinfiltration_mean, "gather", nbp_glo, index_g)
    CALL setvar_p (reinfiltration_mean, val_exp, 'NO_KEYWORD', zero)
    reinfiltration(:) = reinfiltration_mean(:)
    
    ALLOCATE (irrigation_mean(nbpt), stat=ier)
    IF (ier /= 0) CALL ipslerr_p(3,'routing_init','Pb in allocate for irrigation_mean','','')
    ALLOCATE (irrig_netereq(nbpt), stat=ier)
    IF (ier /= 0) CALL ipslerr_p(3,'routing_init','Pb in allocate for irrig_netereq','','')
    irrig_netereq(:) = zero
    
    IF ( do_irrigation ) THEN
       var_name = 'irrigation'
       CALL ioconf_setatt_p('UNITS', 'Kg/dt')
       CALL ioconf_setatt_p('LONG_NAME','Artificial irrigation flux')
       CALL restget_p (rest_id, var_name, nbp_glo, 1, 1, kjit, .TRUE., irrigation_mean, "gather", nbp_glo, index_g)
       CALL setvar_p (irrigation_mean, val_exp, 'NO_KEYWORD', zero)
    ELSE
       irrigation_mean(:) = zero
    ENDIF
    irrigation(:) = irrigation_mean(:) 
    
    ALLOCATE (riverflow_mean(nbpt), stat=ier)
    IF (ier /= 0) CALL ipslerr_p(3,'routing_init','Pb in allocate for riverflow_mean','','')
    var_name = 'riverflow'
    CALL ioconf_setatt_p('UNITS', 'Kg/dt')
    CALL ioconf_setatt_p('LONG_NAME','River flux into the sea')
    CALL restget_p (rest_id, var_name, nbp_glo, 1, 1, kjit, .TRUE., riverflow_mean, "gather", nbp_glo, index_g)
    CALL setvar_p (riverflow_mean, val_exp, 'NO_KEYWORD', zero)
    riverflow(:) = riverflow_mean(:)
    
    ALLOCATE (coastalflow_mean(nbpt), stat=ier)
    IF (ier /= 0) CALL ipslerr_p(3,'routing_init','Pb in allocate for coastalflow_mean','','')
    var_name = 'coastalflow'
    CALL ioconf_setatt_p('UNITS', 'Kg/dt')
    CALL ioconf_setatt_p('LONG_NAME','Diffuse flux into the sea')
    CALL restget_p (rest_id, var_name, nbp_glo, 1, 1, kjit, .TRUE., coastalflow_mean, "gather", nbp_glo, index_g)
    CALL setvar_p (coastalflow_mean, val_exp, 'NO_KEYWORD', zero)
    coastalflow(:) = coastalflow_mean(:)
    
    ! Locate it at the 2m level
    ipn = MINLOC(ABS(diaglev-2))
    floodtemp_lev = ipn(1)
    ALLOCATE (floodtemp(nbpt), stat=ier)
    IF (ier /= 0) CALL ipslerr_p(3,'routing_init','Pb in allocate for floodtemp','','')
    floodtemp(:) = stempdiag(:,floodtemp_lev)
    
    ALLOCATE(hydrographs(nbpt), stat=ier)
    IF (ier /= 0) CALL ipslerr_p(3,'routing_init','Pb in allocate for hydrographs','','')
    var_name = 'hydrographs'
    CALL ioconf_setatt_p('UNITS', 'kg/dt_sechiba')
    CALL ioconf_setatt_p('LONG_NAME','Hydrograph at outlow of grid')
    CALL restget_p (rest_id, var_name, nbp_glo, 1, 1, kjit, .TRUE., hydrographs, "gather", nbp_glo, index_g)
    CALL setvar_p (hydrographs, val_exp, 'NO_KEYWORD', zero)
 
    ALLOCATE(slowflow_diag(nbpt), stat=ier)
    IF (ier /= 0) CALL ipslerr_p(3,'routing_init','Pb in allocate for slowflow_diag','','')
    var_name = 'slowflow_diag'
    CALL ioconf_setatt_p('UNITS', 'kg/dt_sechiba')
    CALL ioconf_setatt_p('LONG_NAME','Slowflow hydrograph at outlow of grid')
    CALL restget_p (rest_id, var_name, nbp_glo, 1, 1, kjit, .TRUE.,slowflow_diag, "gather", nbp_glo, index_g)
    CALL setvar_p (slowflow_diag, val_exp, 'NO_KEYWORD', zero)

    !
    ! The diagnostic variables, they are initialized from the above restart variables.
    !
    ALLOCATE(fast_diag(nbpt), slow_diag(nbpt), stream_diag(nbpt), flood_diag(nbpt), &
         & pond_diag(nbpt), lake_diag(nbpt), stat=ier)
    IF (ier /= 0) CALL ipslerr_p(3,'routing_init','Pb in allocate for fast_diag,..','','')
    
    fast_diag(:) = zero
    slow_diag(:) = zero
    stream_diag(:) = zero
    flood_diag(:) = zero
    pond_diag(:) = zero
    lake_diag(:) = zero
    
    DO ig=1,nbpt
       totarea = zero
       DO ib=1,nbasmax
          totarea = totarea + routing_area(ig,ib)
          fast_diag(ig) = fast_diag(ig) + fast_reservoir(ig,ib)
          slow_diag(ig) = slow_diag(ig) + slow_reservoir(ig,ib)
          stream_diag(ig) = stream_diag(ig) + stream_reservoir(ig,ib)
          flood_diag(ig) = flood_diag(ig) + flood_reservoir(ig,ib)
       ENDDO
       !
       fast_diag(ig) = fast_diag(ig)/totarea
       slow_diag(ig) = slow_diag(ig)/totarea
       stream_diag(ig) = stream_diag(ig)/totarea
       flood_diag(ig) = flood_diag(ig)/totarea
       !
       ! This is the volume of the lake scaled to the entire grid.
       ! It would be better to scale it to the size of the lake
       ! but this information is not yet available.
       !
       lake_diag(ig) = lake_reservoir(ig)/totarea
       !
    ENDDO
    !
    ! Get from the restart the fluxes we accumulated.
    !
    ALLOCATE (floodout_mean(nbpt), stat=ier)
    IF (ier /= 0) CALL ipslerr_p(3,'routing_init','Pb in allocate for floodout_mean','','')
    var_name = 'floodout_route'
    CALL ioconf_setatt_p('UNITS', 'Kg')
    CALL ioconf_setatt_p('LONG_NAME','Accumulated flow out of floodplains for routing')
    CALL restget_p (rest_id, var_name, nbp_glo, 1, 1, kjit, .TRUE., floodout_mean, "gather", nbp_glo, index_g)
    CALL setvar_p (floodout_mean, val_exp, 'NO_KEYWORD', zero)
    
    ALLOCATE (runoff_mean(nbpt), stat=ier)
    IF (ier /= 0) CALL ipslerr_p(3,'routing_init','Pb in allocate for runoff_mean','','')
    var_name = 'runoff_route'
    CALL ioconf_setatt_p('UNITS', 'Kg')
    CALL ioconf_setatt_p('LONG_NAME','Accumulated runoff for routing')
    CALL restget_p (rest_id, var_name, nbp_glo, 1, 1, kjit, .TRUE., runoff_mean, "gather", nbp_glo, index_g)
    CALL setvar_p (runoff_mean, val_exp, 'NO_KEYWORD', zero)
    
    ALLOCATE(drainage_mean(nbpt), stat=ier)
    IF (ier /= 0) CALL ipslerr_p(3,'routing_init','Pb in allocate for drainage_mean','','')
    var_name = 'drainage_route'
    CALL ioconf_setatt_p('UNITS', 'Kg')
    CALL ioconf_setatt_p('LONG_NAME','Accumulated drainage for routing')
    CALL restget_p (rest_id, var_name, nbp_glo, 1, 1, kjit, .TRUE., drainage_mean, "gather", nbp_glo, index_g)
    CALL setvar_p (drainage_mean, val_exp, 'NO_KEYWORD', zero)
    
    ALLOCATE(transpot_mean(nbpt), stat=ier)
    IF (ier /= 0) CALL ipslerr_p(3,'routing_init','Pb in allocate for transpot_mean','','')
    var_name = 'transpot_route'
    CALL ioconf_setatt_p('UNITS', 'Kg/m^2')
    CALL ioconf_setatt_p('LONG_NAME','Accumulated potential transpiration for routing/irrigation')
    CALL restget_p (rest_id, var_name, nbp_glo, 1, 1, kjit, .TRUE., transpot_mean, "gather", nbp_glo, index_g)
    CALL setvar_p (transpot_mean, val_exp, 'NO_KEYWORD', zero)

    ALLOCATE(precip_mean(nbpt), stat=ier)
    IF (ier /= 0) CALL ipslerr_p(3,'routing_init','Pb in allocate for precip_mean','','')
    var_name = 'precip_route'
    CALL ioconf_setatt_p('UNITS', 'Kg/m^2')
    CALL ioconf_setatt_p('LONG_NAME','Accumulated rain precipitation for irrigation')
    CALL restget_p (rest_id, var_name, nbp_glo, 1, 1, kjit, .TRUE., precip_mean, "gather", nbp_glo, index_g)
    CALL setvar_p (precip_mean, val_exp, 'NO_KEYWORD', zero)
    
    ALLOCATE(humrel_mean(nbpt), stat=ier)
    IF (ier /= 0) CALL ipslerr_p(3,'routing_init','Pb in allocate for humrel_mean','','')
    var_name = 'humrel_route'
    CALL ioconf_setatt_p('UNITS', '-')
    CALL ioconf_setatt_p('LONG_NAME','Mean humrel for irrigation')
    CALL restget_p (rest_id, var_name, nbp_glo, 1, 1, kjit, .TRUE., humrel_mean, "gather", nbp_glo, index_g)
    CALL setvar_p (humrel_mean, val_exp, 'NO_KEYWORD', un)
    
    ALLOCATE(k_litt_mean(nbpt), stat=ier)
    IF (ier /= 0) CALL ipslerr_p(3,'routing_init','Pb in allocate for k_litt_mean','','')
    var_name = 'k_litt_route'
    CALL ioconf_setatt_p('UNITS', '-')
    CALL ioconf_setatt_p('LONG_NAME','Mean cond. for litter')
    CALL restget_p (rest_id, var_name, nbp_glo, 1, 1, kjit, .TRUE., k_litt_mean, "gather", nbp_glo, index_g)
    CALL setvar_p (k_litt_mean, val_exp, 'NO_KEYWORD', zero)
    
    ALLOCATE(totnobio_mean(nbpt), stat=ier)
    IF (ier /= 0) CALL ipslerr_p(3,'routing_init','Pb in allocate for totnobio_mean','','')
    var_name = 'totnobio_route'
    CALL ioconf_setatt_p('UNITS', '-')
    CALL ioconf_setatt_p('LONG_NAME','Last Total fraction of no bio for irrigation')
    CALL restget_p (rest_id, var_name, nbp_glo, 1, 1, kjit, .TRUE., totnobio_mean, "gather", nbp_glo, index_g)
    CALL setvar_p (totnobio_mean, val_exp, 'NO_KEYWORD', zero)
    
    ALLOCATE(vegtot_mean(nbpt), stat=ier)
    IF (ier /= 0) CALL ipslerr_p(3,'routing_init','Pb in allocate for vegtot_mean','','')
    var_name = 'vegtot_route'
    CALL ioconf_setatt_p('UNITS', '-')
    CALL ioconf_setatt_p('LONG_NAME','Last Total fraction of vegetation')
    CALL restget_p (rest_id, var_name, nbp_glo, 1, 1, kjit, .TRUE., vegtot_mean, "gather", nbp_glo, index_g)
    CALL setvar_p (vegtot_mean, val_exp, 'NO_KEYWORD', un)
    !
    !
    DEALLOCATE(tmp_real_g)
    !
    ! Allocate diagnostic variables
    !
    ALLOCATE(hydrodiag_loc(nbpt,nbasmax),hydrodiag_glo(nbp_glo,nbasmax),stat=ier)
    IF (ier /= 0) CALL ipslerr_p(3,'routing_init','Pb in allocate for hydrodiag_glo','','')
    hydrodiag=>hydrodiag_loc

    ALLOCATE(hydroupbasin_loc(nbpt),hydroupbasin_glo(nbp_glo), stat=ier)
    IF (ier /= 0) CALL ipslerr_p(3,'routing_init','Pb in allocate for hydroupbasin_glo','','')
    hydroupbasin=>hydroupbasin_loc

  END SUBROUTINE routing_init
  !
!! ================================================================================================================================
!! SUBROUTINE   : routing_clear
!!
!>\BRIEF        : This subroutine deallocates the block memory previously allocated.
!! \n
!_ ================================================================================================================================

  SUBROUTINE routing_clear()

    IF (ALLOCATED(routing_area_loc)) DEALLOCATE(routing_area_loc)
    IF (ALLOCATED(route_togrid_loc)) DEALLOCATE(route_togrid_loc)
    IF (ALLOCATED(route_tobasin_loc)) DEALLOCATE(route_tobasin_loc)
    IF (ALLOCATED(route_nbintobas_loc)) DEALLOCATE(route_nbintobas_loc)
    IF (ALLOCATED(global_basinid_loc)) DEALLOCATE(global_basinid_loc)
    IF (ALLOCATED(topo_resid_loc)) DEALLOCATE(topo_resid_loc)
    IF (ALLOCATED(routing_area_glo)) DEALLOCATE(routing_area_glo)
    IF (ALLOCATED(route_togrid_glo)) DEALLOCATE(route_togrid_glo)
    IF (ALLOCATED(route_tobasin_glo)) DEALLOCATE(route_tobasin_glo)
    IF (ALLOCATED(route_nbintobas_glo)) DEALLOCATE(route_nbintobas_glo)
    IF (ALLOCATED(global_basinid_glo)) DEALLOCATE(global_basinid_glo)
    IF (ALLOCATED(topo_resid_glo)) DEALLOCATE(topo_resid_glo)
    IF (ALLOCATED(fast_reservoir)) DEALLOCATE(fast_reservoir)
    IF (ALLOCATED(slow_reservoir)) DEALLOCATE(slow_reservoir)
    IF (ALLOCATED(stream_reservoir)) DEALLOCATE(stream_reservoir)
    IF (ALLOCATED(flood_reservoir)) DEALLOCATE(flood_reservoir)
    IF (ALLOCATED(flood_frac_bas)) DEALLOCATE(flood_frac_bas)
    IF (ALLOCATED(flood_height)) DEALLOCATE(flood_height)
    IF (ALLOCATED(pond_frac)) DEALLOCATE(pond_frac)
    IF (ALLOCATED(lake_reservoir)) DEALLOCATE(lake_reservoir)
    IF (ALLOCATED(pond_reservoir)) DEALLOCATE(pond_reservoir)
    IF (ALLOCATED(returnflow_mean)) DEALLOCATE(returnflow_mean)
    IF (ALLOCATED(reinfiltration_mean)) DEALLOCATE(reinfiltration_mean)
    IF (ALLOCATED(riverflow_mean)) DEALLOCATE(riverflow_mean)
    IF (ALLOCATED(coastalflow_mean)) DEALLOCATE(coastalflow_mean)
    IF (ALLOCATED(lakeinflow_mean)) DEALLOCATE(lakeinflow_mean)
    IF (ALLOCATED(runoff_mean)) DEALLOCATE(runoff_mean)
    IF (ALLOCATED(floodout_mean)) DEALLOCATE(floodout_mean)
    IF (ALLOCATED(drainage_mean)) DEALLOCATE(drainage_mean)
    IF (ALLOCATED(transpot_mean)) DEALLOCATE(transpot_mean)
    IF (ALLOCATED(precip_mean)) DEALLOCATE(precip_mean)
    IF (ALLOCATED(humrel_mean)) DEALLOCATE(humrel_mean)
    IF (ALLOCATED(k_litt_mean)) DEALLOCATE(k_litt_mean)
    IF (ALLOCATED(totnobio_mean)) DEALLOCATE(totnobio_mean)
    IF (ALLOCATED(vegtot_mean)) DEALLOCATE(vegtot_mean)
    IF (ALLOCATED(floodtemp)) DEALLOCATE(floodtemp)
    IF (ALLOCATED(hydrodiag_loc)) DEALLOCATE(hydrodiag_loc)
    IF (ALLOCATED(hydrodiag_glo)) DEALLOCATE(hydrodiag_glo)
    IF (ALLOCATED(hydroupbasin_loc)) DEALLOCATE(hydroupbasin_loc)    
    IF (ALLOCATED(hydroupbasin_glo)) DEALLOCATE(hydroupbasin_glo)
    IF (ALLOCATED(hydrographs)) DEALLOCATE(hydrographs)
    IF (ALLOCATED(slowflow_diag)) DEALLOCATE(slowflow_diag)
    IF (ALLOCATED(irrigation_mean)) DEALLOCATE(irrigation_mean)
    IF (ALLOCATED(irrigated)) DEALLOCATE(irrigated)
    IF (ALLOCATED(floodplains)) DEALLOCATE(floodplains)
    IF (ALLOCATED(swamp)) DEALLOCATE(swamp)
    IF (ALLOCATED(fast_diag)) DEALLOCATE(fast_diag)
    IF (ALLOCATED(slow_diag)) DEALLOCATE(slow_diag)
    IF (ALLOCATED(stream_diag)) DEALLOCATE(stream_diag)
    IF (ALLOCATED(flood_diag)) DEALLOCATE(flood_diag)
    IF (ALLOCATED(pond_diag)) DEALLOCATE(pond_diag)
    IF (ALLOCATED(lake_diag)) DEALLOCATE(lake_diag)

  END SUBROUTINE routing_clear
  !

!! ================================================================================================================================
!! SUBROUTINE   : routing_flow
!!
!>\BRIEF         This subroutine computes the transport of water in the various reservoirs
!!                (including ponds and floodplains) and the water withdrawals from the reservoirs for irrigation.
!!
!! DESCRIPTION (definitions, functional, design, flags) :
!! This will first compute the amount of water which flows out of each of the 3 reservoirs using the assumption of an 
!! exponential decrease of water in the reservoir (see Hagemann S and Dumenil L. (1998)). Then we compute the fluxes 
!! for floodplains and ponds. All this will then be used in order to update each of the basins : taking water out of 
!! the up-stream basin and adding it to the down-stream one.
!! As this step happens globaly we have to stop the parallel processing in order to exchange the information. Once 
!! all reservoirs are updated we deal with irrigation. The final step is to compute diagnostic fluxes. Among them
!! the hydrographs of the largest rivers we have chosen to monitor.
!!
!! RECENT CHANGE(S): None
!!
!! MAIN OUTPUT VARIABLE(S): lakeinflow, returnflow, reinfiltration, irrigation, riverflow, coastalflow, hydrographs, flood_frac, flood_res
!!
!! REFERENCES   :
!! - Ngo-Duc, T., K. Laval, G. Ramillien, J. Polcher, and A. Cazenave (2007)
!!   Validation of the land water storage simulated by Organising Carbon and Hydrology in Dynamic Ecosystems (ORCHIDEE) with Gravity Recovery and Climate Experiment (GRACE) data.
!!   Water Resour. Res., 43, W04427, doi:10.1029/2006WR004941.
!! * Irrigation:
!! - de Rosnay, P., J. Polcher, K. Laval, and M. Sabre (2003)
!!   Integrated parameterization of irrigation in the land surface model ORCHIDEE. Validation over Indian Peninsula.
!!   Geophys. Res. Lett., 30(19), 1986, doi:10.1029/2003GL018024.
!! - A.C. Vivant (2003)
!!   Les plaines d'inondations et l'irrigation dans ORCHIDEE, impacts de leur prise en compte.
!!   , , 51pp.
!! - N. Culson (2004)
!!   Impact de l'irrigation sur le cycle de l'eau
!!   Master thesis, Paris VI University, 55pp.
!! - X.-T. Nguyen-Vinh (2005)
!!   Analyse de l'impact de l'irrigation en Amerique du Nord - plaine du Mississippi - sur la climatologie regionale
!!   Master thesis, Paris VI University, 33pp.
!! - M. Guimberteau (2006)
!!   Analyse et modifications proposees de la modelisation de l'irrigation dans un modele de surface.
!!   Master thesis, Paris VI University, 46pp.
!! - Guimberteau M. (2010)
!!   Modelisation de l'hydrologie continentale et influences de l'irrigation sur le cycle de l'eau.
!!   Ph.D. thesis, Paris VI University, 195pp.
!! - Guimberteau M., Laval K., Perrier A. and Polcher J. (2011).
!!   Global effect of irrigation and its impact on the onset of the Indian summer monsoon.
!!   In press, Climate Dynamics, doi: 10.1007/s00382-011-1252-5.
!! * Floodplains:
!! - A.C. Vivant (2002)
!!   L'ecoulement lateral de l'eau sur les surfaces continentales. Prise en compte des plaines d'inondations dans ORCHIDEE.
!!   Master thesis, Paris VI University, 46pp.
!! - A.C. Vivant (2003)
!!   Les plaines d'inondations et l'irrigation dans ORCHIDEE, impacts de leur prise en compte.
!!   , , 51pp.
!! - T. d'Orgeval (2006)
!!   Impact du changement climatique sur le cycle de l'eau en Afrique de l'Ouest: modelisation et incertitudes.
!!   Ph.D. thesis, Paris VI University, 188pp.
!! - T. d'Orgeval, J. Polcher, and P. de Rosnay (2008)
!!   Sensitivity of the West African hydrological cycle in ORCHIDEE to infiltration processes.
!!   Hydrol. Earth Syst. Sci., 12, 1387-1401
!! - M. Guimberteau, G. Drapeau, J. Ronchail, B. Sultan, J. Polcher, J.-M. Martinez, C. Prigent, J.-L. Guyot, G. Cochonneau,
!!   J. C. Espinoza, N. Filizola, P. Fraizy, W. Lavado, E. De Oliveira, R. Pombosa, L. Noriega, and P. Vauchel (2011)
!!   Discharge simulation in the sub-basins of the Amazon using ORCHIDEE forced by new datasets.
!!   Hydrol. Earth Syst. Sci. Discuss., 8, 11171-11232, doi:10.5194/hessd-8-11171-2011
!!
!! FLOWCHART    :None
!! \n
!_ ================================================================================================================================

  SUBROUTINE routing_flow(nbpt, dt_routing, lalo, floodout, runoff, drainage, &
       &                  vegtot, totnobio, transpot_mean, precip, humrel, k_litt, floodtemp, reinf_slope, &
       &                  lakeinflow, returnflow, reinfiltration, irrigation, riverflow, &
       &                  coastalflow, hydrographs, slowflow_diag, flood_frac, flood_res, &
                          netflow_stream_diag, netflow_fast_diag, netflow_slow_diag)
    !
    IMPLICIT NONE
    !
!! INPUT VARIABLES
    INTEGER(i_std), INTENT(in)                   :: nbpt                      !! Domain size (unitless)
    REAL(r_std), INTENT (in)                     :: dt_routing                !! Routing time step (s)
    REAL(r_std), INTENT(in)                      :: lalo(nbpt,2)              !! Vector of latitude and longitudes
    REAL(r_std), INTENT(in)                      :: runoff(nbpt)              !! Grid-point runoff (kg/m^2/dt)
    REAL(r_std), INTENT(in)                      :: floodout(nbpt)            !! Grid-point flow out of floodplains (kg/m^2/dt)
    REAL(r_std), INTENT(in)                      :: drainage(nbpt)            !! Grid-point drainage (kg/m^2/dt)
    REAL(r_std), INTENT(in)                      :: vegtot(nbpt)              !! Potentially vegetated fraction (unitless;0-1)
    REAL(r_std), INTENT(in)                      :: totnobio(nbpt)            !! Other areas which can not have vegetation
    REAL(r_std), INTENT(in)                      :: transpot_mean(nbpt)       !! Mean potential transpiration of the vegetation (kg/m^2/dt)
    REAL(r_std), INTENT(in)                      :: precip(nbpt)              !! Rainfall (kg/m^2/dt)
    REAL(r_std), INTENT(in)                      :: humrel(nbpt)              !! Soil moisture stress, root extraction potential (unitless)
    REAL(r_std), INTENT(in)                      :: k_litt(nbpt)              !! Averaged conductivity for saturated infiltration in the 'litter' layer (kg/m^2/dt)
    REAL(r_std), INTENT(in)                      :: floodtemp(nbpt)           !! Temperature to decide if floodplains work (K)
    REAL(r_std), INTENT(in)                      :: reinf_slope(nbpt)         !! Coefficient which determines the reinfiltration ratio in the grid box due to flat areas (unitless;0-1)
    REAL(r_std), INTENT(out)                     :: lakeinflow(nbpt)          !! Water inflow to the lakes (kg/dt)
    !
!! OUTPUT VARIABLES
    REAL(r_std), INTENT(out)                     :: returnflow(nbpt)          !! The water flow from lakes and swamps which returns into the grid box.
                                                                              !! This water will go back into the hydrol module to allow re-evaporation (kg/m^2/dt_routing)
    REAL(r_std), INTENT(out)                     :: reinfiltration(nbpt)      !! Water flow from ponds and floodplains which returns to the grid box (kg/m^2/dt)
    REAL(r_std), INTENT(out)                     :: irrigation(nbpt)          !! Irrigation flux. This is the water taken from the reservoirs and beeing put into the upper layers of the soil (kg/m^2/dt_routing)
    REAL(r_std), INTENT(out)                     :: riverflow(nbpt)           !! Outflow of the major rivers. The flux will be located on the continental grid but this should be a coastal point (kg/dt_routing)
    REAL(r_std), INTENT(out)                     :: coastalflow(nbpt)         !! Outflow on coastal points by small basins. This is the water which flows in a disperse way into the ocean (kg/dt_routing)
    REAL(r_std), INTENT(out)                     :: hydrographs(nbpt)         !! Hydrographs at the outflow of the grid box for major basins (kg/dt)
    REAL(r_std), INTENT(out)                     :: slowflow_diag(nbpt)       !! Hydrographs of slow_flow = routed slow_flow for major basins (kg/dt)
    REAL(r_std), INTENT(out)                     :: flood_frac(nbpt)          !! Flooded fraction of the grid box (unitless;0-1)
    REAL(r_std), INTENT(out)                     :: flood_res(nbpt)           !! Diagnostic of water amount in the floodplains reservoir (kg)

    REAL(r_std), INTENT(out)                     :: netflow_stream_diag(nbpt) !! Input - Output flow to stream reservoir
    REAL(r_std), INTENT(out)                     :: netflow_fast_diag(nbpt)   !! Input - Output flow to fast reservoir
    REAL(r_std), INTENT(out)                     :: netflow_slow_diag(nbpt)   !! Input - Output flow to slow reservoir
    !
!! LOCAL VARIABLES
    REAL(r_std), DIMENSION(nbpt, nbasmax)        :: fast_flow                 !! Outflow from the fast reservoir (kg/dt)
    REAL(r_std), DIMENSION(nbpt, nbasmax)        :: slow_flow                 !! Outflow from the slow reservoir (kg/dt)
    REAL(r_std), DIMENSION(nbpt, nbasmax)        :: stream_flow               !! Outflow from the stream reservoir (kg/dt)
    REAL(r_std), DIMENSION(nbpt, nbasmax)        :: flood_flow                !! Outflow from the floodplain reservoir (kg/dt)
    REAL(r_std), DIMENSION(nbpt, nbasmax)        :: pond_inflow               !! Inflow to the pond reservoir (kg/dt)
    REAL(r_std), DIMENSION(nbpt, nbasmax)        :: pond_drainage             !! Drainage from pond (kg/m^2/dt)
    REAL(r_std), DIMENSION(nbpt, nbasmax)        :: flood_drainage            !! Drainage from floodplains (kg/m^2/dt)
    REAL(r_std), DIMENSION(nbpt, nbasmax)        :: return_swamp              !! Inflow to the swamp (kg/dt)
    !
    ! Irrigation per basin
    !
    REAL(r_std), DIMENSION(nbpt, nbasmax)        :: irrig_needs               !! Total irrigation requirement (water requirements by the crop for its optimal growth) (kg)
    REAL(r_std), DIMENSION(nbpt, nbasmax)        :: irrig_actual              !! Possible irrigation according to the water availability in the reservoirs (kg)
    REAL(r_std), DIMENSION(nbpt, nbasmax)        :: irrig_deficit             !! Amount of water missing for irrigation (kg)
    REAL(r_std), DIMENSION(nbpt, nbasmax)        :: irrig_adduct              !! Amount of water carried over from other basins for irrigation (kg)
    !
    REAL(r_std), DIMENSION(nbpt, 0:nbasmax+3)    :: transport                 !! Water transport between basins (kg/dt)
    REAL(r_std), DIMENSION(nbp_glo, 0:nbasmax+3) :: transport_glo             !! Water transport between basins (kg/dt)
    REAL(r_std), DIMENSION(nbpt, nbasmax)        :: floods                    !! Water flow in to the floodplains (kg/dt)
    REAL(r_std), DIMENSION(nbpt, nbasmax)        :: potflood                  !! Potential inflow to the swamps (kg/dt)
    REAL(r_std), DIMENSION(nbpt)                 :: tobeflooded               !! Maximal surface which can be inundated in each grid box (m^2)
    REAL(r_std), DIMENSION(nbpt)                 :: totarea                   !! Total area of basin (m^2)
    REAL(r_std), DIMENSION(nbpt)                 :: totflood                  !! Total amount of water in the floodplains reservoir (kg)
    REAL(r_std), DIMENSION(nbasmax)              :: pond_excessflow           !! 
    REAL(r_std)                                  :: flow                      !! Outflow computation for the reservoirs (kg/dt)
    REAL(r_std)                                  :: floodindex                !! Fraction of grid box area inundated (unitless;0-1)
    REAL(r_std)                                  :: pondex                    !! 
    REAL(r_std)                                  :: flood_frac_pot            !! Total fraction of the grid box which is flooded at optimum repartition (unitless;0-1)
    REAL(r_std)                                  :: stream_tot                !! Total water amount in the stream reservoirs (kg)
    REAL(r_std)                                  :: adduction                 !! Importation of water from a stream reservoir of a neighboring grid box (kg)
    REAL(r_std), DIMENSION(nbp_glo)              :: lake_overflow_g           !! Removed water from lake reservoir on global grid (kg/gridcell/dt_routing)
    REAL(r_std), DIMENSION(nbpt)                 :: lake_overflow             !! Removed water from lake reservoir on local grid (kg/gridcell/dt_routing)
    REAL(r_std), DIMENSION(nbpt)                 :: lake_overflow_coast       !! lake_overflow distributed on coast gridcells, only diag(kg/gridcell/dt_routing)
    REAL(r_std)                                  :: total_lake_overflow       !! Sum of lake_overflow over full grid (kg)
    REAL(r_std), DIMENSION(8,nbasmax)            :: streams_around            !! Stream reservoirs of the neighboring grid boxes (kg)
    INTEGER(i_std), DIMENSION(8)                 :: igrd                      !! 
    INTEGER(i_std), DIMENSION(2)                 :: ff                        !! 
    INTEGER(i_std), DIMENSION(1)                 :: fi                        !! 
    INTEGER(i_std)                               :: ig, ib, ib2, ig2          !! Indices (unitless)
    INTEGER(i_std)                               :: rtg, rtb, in              !! Indices (unitless)
    INTEGER(i_std)                               :: ier                       !! Error handling 
    REAL(r_std), ALLOCATABLE, DIMENSION(:,:)     :: fast_flow_g               !! Outflow from the fast reservoir (kg/dt)
    REAL(r_std), ALLOCATABLE, DIMENSION(:,:)     :: slow_flow_g               !! Outflow from the slow reservoir (kg/dt)
    REAL(r_std), ALLOCATABLE, DIMENSION(:,:)     :: stream_flow_g             !! Outflow from the stream reservoir (kg/dt)
    REAL(r_std), ALLOCATABLE, DIMENSION(:,:)     :: irrig_deficit_glo         !! Amount of water missing for irrigation (kg)
    REAL(r_std), ALLOCATABLE, DIMENSION(:,:)     :: stream_reservoir_glo      !! Water amount in the stream reservoir (kg)
    REAL(r_std), ALLOCATABLE, DIMENSION(:,:)     :: irrig_adduct_glo          !! Amount of water carried over from other basins for irrigation (kg)

    REAL(r_std), DIMENSION(nbpt, nbasmax)        :: netflow_stream            !! Input - Output flow to stream reservoir
    REAL(r_std), DIMENSION(nbpt, nbasmax)        :: netflow_fast              !! Input - Output flow to fast reservoir
    REAL(r_std), DIMENSION(nbpt, nbasmax)        :: netflow_slow              !! Input - Output flow to slow reservoir


    !! PARAMETERS
    LOGICAL, PARAMETER                           :: check_reservoir = .FALSE. !! Logical to choose if we write informations when a negative amount of water is occurring in a reservoir (true/false)
!_ ================================================================================================================================
    !
    transport(:,:) = zero
    transport_glo(:,:) = zero
    irrig_netereq(:) = zero
    irrig_needs(:,:) = zero
    irrig_actual(:,:) = zero
    irrig_deficit(:,:) = zero
    irrig_adduct(:,:) = zero
    totarea(:) = zero
    totflood(:) = zero
    !
    ! Compute all the fluxes
    !
    DO ib=1,nbasmax
       DO ig=1,nbpt
          !
          totarea(ig) = totarea(ig) + routing_area(ig,ib)
          totflood(ig) = totflood(ig) + flood_reservoir(ig,ib)
       ENDDO
    ENDDO
          !
!> The outflow fluxes from the three reservoirs are computed. 
!> The outflow of volume of water Vi into the reservoir i is assumed to be linearly related to its volume.
!> The water travel simulated by the routing scheme is dependent on the water retention index topo_resid
!> given by a 0.5 degree resolution map for each pixel performed from a simplification of Manning's formula
!> (Dingman, 1994; Ducharne et al., 2003).
!> The resulting product of tcst (in day/m) and topo_resid (in m) represents the time constant (day)
!> which is an e-folding time, the time necessary for the water amount
!> in the stream reservoir to decrease by a factor e. Hence, it gives an order of
!> magnitude of the travel time through this reservoir between
!> the sub-basin considered and its downstream neighbor.

    DO ib=1,nbasmax
       DO ig=1,nbpt
          IF ( route_tobasin(ig,ib) .GT. 0 ) THEN
             !
             ! Each of the fluxes is limited by the water in the reservoir and a small margin 
             ! (min_reservoir) to avoid rounding errors.
             !
             flow = MIN(fast_reservoir(ig,ib)/((topo_resid(ig,ib)/1000.)*fast_tcst*one_day/dt_routing),&
                  & fast_reservoir(ig,ib)-min_sechiba)
             fast_flow(ig,ib) = MAX(flow, zero)

             flow = MIN(slow_reservoir(ig,ib)/((topo_resid(ig,ib)/1000.)*slow_tcst*one_day/dt_routing),&
                  & slow_reservoir(ig,ib)-min_sechiba)
             slow_flow(ig,ib) = MAX(flow, zero)

             flow = MIN(stream_reservoir(ig,ib)/((topo_resid(ig,ib)/1000.)*stream_tcst* & 
                  & MAX(un-SQRT(flood_frac_bas(ig,ib)),min_sechiba)*one_day/dt_routing),&
                  & stream_reservoir(ig,ib)-min_sechiba)
             stream_flow(ig,ib) = MAX(flow, zero)
             !
          ELSE
             fast_flow(ig,ib) = zero
             slow_flow(ig,ib) = zero
             stream_flow(ig,ib) = zero
          ENDIF
       ENDDO
    ENDDO
    !-
    !- Compute the fluxes out of the floodplains and ponds if they exist.
    !-
    IF (do_floodplains .OR. doponds) THEN
       DO ig=1,nbpt
          IF (flood_frac(ig) .GT. min_sechiba) THEN
             !
             flow = MIN(floodout(ig)*totarea(ig)*pond_frac(ig)/flood_frac(ig), pond_reservoir(ig)+totflood(ig))
             pondex = MAX(flow - pond_reservoir(ig), zero)
             pond_reservoir(ig) = pond_reservoir(ig) - (flow - pondex) 
             !
             ! If demand was over reservoir size, we will take it out from floodplains
             !
             pond_excessflow(:) = zero
             DO ib=1,nbasmax
                pond_excessflow(ib) = MIN(pondex*flood_frac_bas(ig,ib)/(flood_frac(ig)-pond_frac(ig)),&
                     &                    flood_reservoir(ig,ib))
                pondex = pondex - pond_excessflow(ib)
             ENDDO
             !
             IF ( pondex .GT. min_sechiba) THEN
                WRITE(numout,*) "Unable to redistribute the excess pond outflow over the water available in the floodplain."
                WRITE(numout,*) "Pondex = ", pondex
                WRITE(numout,*) "pond_excessflow(:) = ", pond_excessflow(:)
             ENDIF
             !
             DO ib=1,nbasmax
                !
                flow = floodout(ig)*routing_area(ig,ib)*flood_frac_bas(ig,ib)/flood_frac(ig) + pond_excessflow(ib)
                !
                flood_reservoir(ig,ib) = flood_reservoir(ig,ib) - flow
                !
                !
                IF (flood_reservoir(ig,ib) .LT. min_sechiba) THEN
                   flood_reservoir(ig,ib) = zero
                ENDIF
                IF (pond_reservoir(ig) .LT. min_sechiba) THEN
                   pond_reservoir(ig) = zero
                ENDIF
             ENDDO
          ENDIF
       ENDDO
    ENDIF

    !-
    !- Computing the drainage and outflow from floodplains
!> Drainage from floodplains is depending on a averaged conductivity (k_litt) 
!> for saturated infiltration in the 'litter' layer. Flood_drainage will be
!> a component of the total reinfiltration that leaves the routing scheme.
    !-
    IF (do_floodplains) THEN
       IF (dofloodinfilt) THEN
          DO ib=1,nbasmax
             DO ig=1,nbpt
                flood_drainage(ig,ib) = MAX(zero, MIN(flood_reservoir(ig,ib), &
                     & flood_frac(ig)*routing_area(ig,ib)*k_litt(ig)*dt_routing/one_day))
                flood_reservoir(ig,ib) = flood_reservoir(ig,ib) - flood_drainage(ig,ib)
             ENDDO
          ENDDO
       ELSE
          DO ib=1,nbasmax
             DO ig=1,nbpt
                flood_drainage(ig,ib) = zero 
             ENDDO
          ENDDO
       ENDIF
!> Outflow from floodplains is computed depending a delay. This delay is characterized by a time constant
!> function of the surface of the floodplains and the product of topo_resid and flood_tcst. flood_tcst
!> has been calibrated through observations in the Niger Inner Delta (D'Orgeval, 2006).
!
       DO ib=1,nbasmax
          DO ig=1,nbpt
             IF ( route_tobasin(ig,ib) .GT. 0 ) THEN
                IF (flood_frac_bas(ig,ib) .GT. min_sechiba) THEN
                   flow = MIN(flood_reservoir(ig,ib)  &
                        & /((topo_resid(ig,ib)/1000.)*flood_tcst* &
                        & flood_frac_bas(ig,ib)*one_day/dt_routing),&
                        & flood_reservoir(ig,ib))
                ELSE
                   flow = zero
                ENDIF
                flood_flow(ig,ib) = flow
             ELSE
                flood_flow(ig,ib) = zero
             ENDIF
          ENDDO
       ENDDO
    ELSE
       DO ib=1,nbasmax
          DO ig=1,nbpt
             flood_drainage(ig,ib) = zero
             flood_flow(ig,ib) = zero
             flood_reservoir(ig,ib) = zero
          ENDDO
       ENDDO
    ENDIF

    !-
    !- Computing drainage and inflow for ponds
!> Drainage from ponds is computed in the same way than for floodplains.
!> Reinfiltrated fraction from the runoff (i.e. the outflow from the fast reservoir)
!> is the inflow of the pond reservoir.
    !-
    IF (doponds) THEN
       ! If used, the slope coef is not used in hydrol for water2infilt
       DO ib=1,nbasmax
          DO ig=1,nbpt
             pond_inflow(ig,ib) = fast_flow(ig,ib) * reinf_slope(ig)
             pond_drainage(ig,ib) = MIN(pond_reservoir(ig)*routing_area(ig,ib)/totarea(ig), &
                  & pond_frac(ig)*routing_area(ig,ib)*k_litt(ig)*dt_routing/one_day)
             fast_flow(ig,ib) = fast_flow(ig,ib) - pond_inflow(ig,ib) 
          ENDDO
       ENDDO
    ELSE
       DO ib=1,nbasmax
          DO ig=1,nbpt
             pond_inflow(ig,ib) = zero
             pond_drainage(ig,ib) = zero
             pond_reservoir(ig) = zero
          ENDDO
       ENDDO
    ENDIF

!ym cette methode conserve les erreurs d'arrondie
!ym mais n'est pas la plus efficace

    !-
    !- Compute the transport from one basin to another
    !-

    IF (is_root_prc)  THEN
       ALLOCATE( fast_flow_g(nbp_glo, nbasmax), slow_flow_g(nbp_glo, nbasmax), &
            stream_flow_g(nbp_glo, nbasmax), stat=ier)
    ELSE
       ALLOCATE( fast_flow_g(1,1), slow_flow_g(1,1), &
            stream_flow_g(1, 1), stat=ier)
    ENDIF
    IF (ier /= 0) CALL ipslerr_p(3,'routing_flow','Pb in allocate for fast_flow_g','','')
       
    CALL gather(fast_flow,fast_flow_g)
    CALL gather(slow_flow,slow_flow_g)
    CALL gather(stream_flow,stream_flow_g)

    IF (is_root_prc) THEN
       DO ib=1,nbasmax
          DO ig=1,nbp_glo
             !
             rtg = route_togrid_glo(ig,ib)
             rtb = route_tobasin_glo(ig,ib)
             transport_glo(rtg,rtb) = transport_glo(rtg,rtb) + fast_flow_g(ig,ib) + slow_flow_g(ig,ib) + &
                  & stream_flow_g(ig,ib)
             !
          ENDDO
       ENDDO
    ENDIF

    DEALLOCATE( fast_flow_g, slow_flow_g, stream_flow_g )
   
    CALL scatter(transport_glo,transport)

    !-
    !- Do the floodings - First initialize
    !-
    return_swamp(:,:)=zero
    floods(:,:)=zero
    !-
!> Over swamp areas, a fraction of water (return_swamp) is withdrawn from the river depending on the
!> parameter swamp_cst.
!> It will be transferred into soil moisture and thus does not return directly to the river.
    !
    !- 1. Swamps: Take out water from the river to put it to the swamps
    !-
    !
    IF ( doswamps ) THEN
       tobeflooded(:) = swamp(:)
       DO ib=1,nbasmax
          DO ig=1,nbpt
             potflood(ig,ib) = transport(ig,ib) 
             !
             IF ( tobeflooded(ig) > 0. .AND. potflood(ig,ib) > 0. .AND. floodtemp(ig) > tp_00 ) THEN
                !
                IF (routing_area(ig,ib) > tobeflooded(ig)) THEN
                   floodindex = tobeflooded(ig) / routing_area(ig,ib)
                ELSE
                   floodindex = 1.0
                ENDIF
                return_swamp(ig,ib) = swamp_cst * potflood(ig,ib) * floodindex
                !
                tobeflooded(ig) = tobeflooded(ig) - routing_area(ig,ib) 
                !
             ENDIF
          ENDDO
       ENDDO
    ENDIF
    !-
    !- 2. Floodplains: Update the reservoir with the flux computed above.
    !-
    IF ( do_floodplains ) THEN
       DO ig=1,nbpt
          IF (floodplains(ig) .GT. min_sechiba .AND. floodtemp(ig) .GT. tp_00) THEN
             DO ib=1,nbasmax
                floods(ig,ib) = transport(ig,ib) - return_swamp(ig,ib) 
             ENDDO
          ENDIF
       ENDDO
    ENDIF
    !
    ! Update all reservoirs
!> The slow and deep reservoir (slow_reservoir) collect the deep drainage whereas the
!> fast_reservoir collects the computed surface runoff. Both discharge into a third reservoir
!> (stream_reservoir) of the next sub-basin downstream.
!> Water from the floodplains reservoir (flood_reservoir) flows also into the stream_reservoir of the next sub-basin downstream.
!> Water that flows into the pond_reservoir is withdrawn from the fast_reservoir.
    !
    DO ig=1,nbpt
       DO ib=1,nbasmax
          !
          fast_reservoir(ig,ib) =  fast_reservoir(ig,ib) + runoff(ig)*routing_area(ig,ib) - &
               & fast_flow(ig,ib) - pond_inflow(ig,ib)
          !
          slow_reservoir(ig,ib) = slow_reservoir(ig,ib) + drainage(ig)*routing_area(ig,ib) - &
               & slow_flow(ig,ib)
          !
          stream_reservoir(ig,ib) = stream_reservoir(ig,ib) + flood_flow(ig,ib) + transport(ig,ib) - &
               & stream_flow(ig,ib) - return_swamp(ig,ib) - floods(ig,ib)
          !
          flood_reservoir(ig,ib) = flood_reservoir(ig,ib) + floods(ig,ib) - &
               & flood_flow(ig,ib) 
          !
          pond_reservoir(ig) = pond_reservoir(ig) + pond_inflow(ig,ib) - pond_drainage(ig,ib)
          !
          IF ( flood_reservoir(ig,ib) .LT. zero ) THEN
             IF ( check_reservoir ) THEN
                WRITE(numout,*) "WARNING : negative flood reservoir at :", ig, ib, ". Problem is being corrected."
                WRITE(numout,*) "flood_reservoir, floods, flood_flow : ", flood_reservoir(ig,ib), floods(ig,ib), &
                     & flood_flow(ig,ib) 
             ENDIF
             stream_reservoir(ig,ib) = stream_reservoir(ig,ib) + flood_reservoir(ig,ib)
             flood_reservoir(ig,ib) = zero
          ENDIF
          !
          IF ( stream_reservoir(ig,ib) .LT. zero ) THEN
             IF ( check_reservoir ) THEN
                WRITE(numout,*) "WARNING : negative stream reservoir at :", ig, ib, ". Problem is being corrected."
                WRITE(numout,*) "stream_reservoir, flood_flow, transport : ", stream_reservoir(ig,ib), flood_flow(ig,ib), &
                     &  transport(ig,ib)
                WRITE(numout,*) "stream_flow, return_swamp, floods :", stream_flow(ig,ib), return_swamp(ig,ib), floods(ig,ib)
             ENDIF
             fast_reservoir(ig,ib) =  fast_reservoir(ig,ib) + stream_reservoir(ig,ib)
             stream_reservoir(ig,ib) = zero
          ENDIF
          !
          IF ( fast_reservoir(ig,ib) .LT. zero ) THEN
             IF ( check_reservoir ) THEN
                WRITE(numout,*) "WARNING : negative fast reservoir at :", ig, ib, ". Problem is being corrected."
                WRITE(numout,*) "fast_reservoir, runoff, fast_flow, ponf_inflow  : ", fast_reservoir(ig,ib), &
                     &runoff(ig), fast_flow(ig,ib), pond_inflow(ig,ib)
             ENDIF
             slow_reservoir(ig,ib) =  slow_reservoir(ig,ib) + fast_reservoir(ig,ib)
             fast_reservoir(ig,ib) = zero
          ENDIF

          IF ( slow_reservoir(ig,ib) .LT. - min_sechiba ) THEN
             WRITE(numout,*) 'WARNING : There is a negative reservoir at :', ig, ib,lalo(ig,:)
             WRITE(numout,*) 'WARNING : slowr, slow_flow, drainage', &
                  & slow_reservoir(ig,ib), slow_flow(ig,ib), drainage(ig)
             WRITE(numout,*) 'WARNING : pondr, pond_inflow, pond_drainage', &
                  & pond_reservoir(ig), pond_inflow(ig,ib), pond_drainage(ig,ib)
             CALL ipslerr_p(2, 'routing_flow', 'WARNING negative slow_reservoir.','','')
          ENDIF

       ENDDO
    ENDDO


    totflood(:) = zero
    DO ig=1,nbpt
       DO ib=1,nbasmax
          totflood(ig) = totflood(ig) + flood_reservoir(ig,ib)
       ENDDO
    ENDDO

    !-
    !- Computes the fraction of floodplains and ponds according to their volume
    !-
    IF (do_floodplains .OR. doponds) THEN
       flood_frac(:) = zero
       flood_height(:) = zero
       flood_frac_bas(:,:) = zero
       DO ig=1, nbpt
          IF (totflood(ig) .GT. min_sechiba) THEN
             ! We first compute the total fraction of the grid box which is flooded at optimum repartition
             flood_frac_pot = (totflood(ig) / (totarea(ig)*floodcri/(beta+un)))**(beta/(beta+un))
             flood_frac(ig) = MIN(floodplains(ig) / totarea(ig), flood_frac_pot)
             ! Then we diagnose the fraction for each basin with the size of its flood_reservoir 
             ! (flood_frac_bas may be > 1)
             DO ib=1,nbasmax
                IF (routing_area(ig,ib) .GT. min_sechiba) THEN
                   flood_frac_bas(ig,ib) = flood_frac(ig) * &
                        & (flood_reservoir(ig,ib) / totflood(ig)) / (routing_area(ig,ib) / totarea(ig))
                ENDIF
             ENDDO
             ! We diagnose the maximum height of floodplain
             flood_height(ig) = (beta/(beta+1))*floodcri*(flood_frac(ig))**(un/beta) + totflood(ig)/(totarea(ig)*flood_frac(ig)) 
             ! And finally add the pond surface
             pond_frac(ig) = MIN(un-flood_frac(ig), ((betap+1)*pond_reservoir(ig) / (pondcri*totarea(ig)))**(betap/(betap+1)) ) 
             flood_frac(ig) = flood_frac(ig) + pond_frac(ig)
             !
          ENDIF
       ENDDO
    ELSE
       flood_frac(:) = zero
       flood_height(:) = zero
       flood_frac_bas(:,:) = zero
    ENDIF

    !-
    !- Compute the total reinfiltration and returnflow to the grid box
!> A term of returnflow is computed including the water from the swamps that does not return directly to the river
!> but will be put into soil moisture (see hydrol module).
!> A term of reinfiltration is computed including the water that reinfiltrated from the ponds and floodplains areas.
!> It will be put into soil moisture (see hydrol module).
    !-
    IF (do_floodplains .OR. doswamps .OR. doponds) THEN
       returnflow(:) = zero
       reinfiltration(:) = zero
       !
       DO ib=1,nbasmax
          DO ig=1,nbpt
             returnflow(ig) =  returnflow(ig) + return_swamp(ig,ib)
             reinfiltration(ig) =  reinfiltration(ig) + pond_drainage(ig,ib) + flood_drainage(ig,ib) 
          ENDDO
       ENDDO
       !
       DO ig=1,nbpt
          returnflow(ig) = returnflow(ig)/totarea(ig)
          reinfiltration(ig) = reinfiltration(ig)/totarea(ig)
       ENDDO
    ELSE
       returnflow(:) = zero
       reinfiltration(:) = zero
    ENDIF

    !
    ! Compute the net irrigation requirement from Univ of Kassel
    !
    ! This is a very low priority process and thus only applies if
    ! there is some water left in the reservoirs after all other things.
    !
!> The computation of the irrigation is performed here.
!> * First step
!> In a first time, the water requirements (irrig_netereq) by the crops for their optimal growth are calculated
!> over each irrigated fraction (irrigated(ig)/totarea(ig)). It is the difference
!> between the maximal water loss by the crops (transpot_mean) and the net water amount kept by the soil
!> (precipitation and reinfiltration). Transpot_mean is computed in the routines enerbil and diffuco. It
!> is derived from the effective transpiration parametrization under stress-free conditions, called potential transpiration.
!> Crop_coef was used by a previous parametrization of irrigation in the code. Here, its value is equal to one.
!> The crop coefficient was constant in space and time to represent a mean resistance of the vegetation to the potential evaporation.
!> Now, the term crop_coef*Epot is substituted by transpot_mean (see Guimberteau et al., 2011).
!> * Second step
!> We compute irrigation needs in order to supply Irrig_netereq. Water for irrigation (irrig_actual) is withdrawn
!> from the reservoirs. The amount of water is withdrawn in priority from the stream reservoir.
!> If the irrigation requirement is higher than the water availability of the reservoir, water is withdrawn
!> from the fast reservoir or, in the extreme case, from the slow reservoir.
!> * Third step
!> We compute a deficit in water for irrigation. If it is positive, irrigation (depending on water availibility in the reservoirs)
!> has not supplied the crops requirements.
!
    IF ( do_irrigation ) THEN
       DO ig=1,nbpt
          !
          IF ((vegtot(ig) .GT. min_sechiba) .AND. (humrel(ig) .LT. un-min_sechiba) .AND. &
               & (runoff(ig) .LT. min_sechiba) ) THEN
             
             irrig_netereq(ig) = (irrigated(ig) / totarea(ig) ) * MAX(zero, transpot_mean(ig) - &
                  & (precip(ig)+reinfiltration(ig)) )
             
          ENDIF
          !
          DO ib=1,nbasmax
             IF ( routing_area(ig,ib) .GT. 0 ) THEN
             
                irrig_needs(ig,ib) = irrig_netereq(ig) * routing_area(ig,ib)

                irrig_actual(ig,ib) = MIN(irrig_needs(ig,ib),&
                     &   stream_reservoir(ig,ib) + fast_reservoir(ig,ib) + slow_reservoir(ig,ib) )
                
                slow_reservoir(ig,ib) = MAX(zero, slow_reservoir(ig,ib) + &
                     & MIN(zero, fast_reservoir(ig,ib) + MIN(zero, stream_reservoir(ig,ib)-irrig_actual(ig,ib))))

                fast_reservoir(ig,ib) = MAX( zero, &
                     &  fast_reservoir(ig,ib) + MIN(zero, stream_reservoir(ig,ib)-irrig_actual(ig,ib)))

                stream_reservoir(ig,ib) = MAX(zero, stream_reservoir(ig,ib)-irrig_actual(ig,ib) )

                irrig_deficit(ig,ib) = irrig_needs(ig,ib)-irrig_actual(ig,ib)

             ENDIF
          ENDDO
          !
          ! Check if we cannot find the missing water in another basin of the same grid (stream reservoir only).
          ! If we find that then we create some adduction from that subbasin to the one where we need it for
          ! irrigation.
          !
!> If crops water requirements have not been supplied (irrig_deficit>0), we check if we cannot find the missing water
!> in another basin of the same grid. If there is water in the stream reservoir of this subbasin, we create some adduction
!> from that subbasin to the one where we need it for irrigation.
!> 
          DO ib=1,nbasmax

             stream_tot = SUM(stream_reservoir(ig,:))

             DO WHILE ( irrig_deficit(ig,ib) > min_sechiba .AND. stream_tot > min_sechiba)
                
                fi = MAXLOC(stream_reservoir(ig,:))
                ib2 = fi(1)

                irrig_adduct(ig,ib) = MIN(irrig_deficit(ig,ib), stream_reservoir(ig,ib2))
                stream_reservoir(ig,ib2) = stream_reservoir(ig,ib2)-irrig_adduct(ig,ib)
                irrig_deficit(ig,ib) = irrig_deficit(ig,ib)-irrig_adduct(ig,ib)
             
                stream_tot = SUM(stream_reservoir(ig,:))
                
             ENDDO
             
          ENDDO
          !
       ENDDO
       !
       ! If we are at higher resolution we might need to look at neighboring grid boxes to find the streams
       ! which can feed irrigation
!
!> At higher resolution (grid box smaller than 100x100km), we can import water from neighboring grid boxes
!> to the one where we need it for irrigation.
       !
       IF (is_root_prc) THEN
          ALLOCATE(irrig_deficit_glo(nbp_glo, nbasmax), stream_reservoir_glo(nbp_glo, nbasmax), &
               &        irrig_adduct_glo(nbp_glo, nbasmax), stat=ier)
       ELSE
          ALLOCATE(irrig_deficit_glo(0, 0), stream_reservoir_glo(0, 0), &
               &        irrig_adduct_glo(0, 0), stat=ier)
       ENDIF
       IF (ier /= 0) CALL ipslerr_p(3,'routing_flow','Pb in allocate for irrig_deficit_glo, stream_reservoir_glo,...','','')

       CALL gather(irrig_deficit, irrig_deficit_glo)
       CALL gather(stream_reservoir,  stream_reservoir_glo)
       CALL gather(irrig_adduct, irrig_adduct_glo)

       IF (is_root_prc) THEN
          !
          DO ig=1,nbp_glo
             ! Only work if the grid box is smaller than 100x100km. Else the piplines we build
             ! here would be too long to be reasonable.
             IF ( resolution_g(ig,1) < 100000. .AND. resolution_g(ig,2) < 100000. ) THEN
                DO ib=1,nbasmax
                   !
                   IF ( irrig_deficit_glo(ig,ib)  > min_sechiba ) THEN
                      !
                      streams_around(:,:) = zero
                      !
                      DO in=1,NbNeighb
                         ig2 = neighbours_g(ig,in)
                         IF (ig2 .GT. 0 ) THEN
                            streams_around(in,:) = stream_reservoir_glo(ig2,:)
                            igrd(in) = ig2
                         ENDIF
                      ENDDO
                      !
                      IF ( MAXVAL(streams_around) .GT. zero ) THEN
                         !
                         ff=MAXLOC(streams_around)
                         ig2=igrd(ff(1))
                         ib2=ff(2)
                         !
                         IF ( routing_area_glo(ig2,ib2) .GT. 0 .AND. stream_reservoir_glo(ig2,ib2) > zero ) THEN
                            adduction = MIN(irrig_deficit_glo(ig,ib), stream_reservoir_glo(ig2,ib2))
                            stream_reservoir_glo(ig2,ib2) = stream_reservoir_glo(ig2,ib2) - adduction
                            irrig_deficit_glo(ig,ib) = irrig_deficit_glo(ig,ib) - adduction
                            irrig_adduct_glo(ig,ib) = irrig_adduct_glo(ig,ib) + adduction
                         ENDIF
                         !
                      ENDIF
                      !
                   ENDIF
                   !
                ENDDO
             ENDIF
          ENDDO
          !
       ENDIF
       !

       CALL scatter(irrig_deficit_glo, irrig_deficit)
       CALL scatter(stream_reservoir_glo,  stream_reservoir)
       CALL scatter(irrig_adduct_glo, irrig_adduct)

       DEALLOCATE(irrig_deficit_glo, stream_reservoir_glo, irrig_adduct_glo)

    ENDIF

    !! Calculate the net water flow to each routing reservoir (in kg/dt)
    !! to further diagnose the corresponding water budget residu
    !! in routing_main

    netflow_fast_diag(:) = zero
    netflow_slow_diag(:) = zero
    netflow_stream_diag(:) = zero

    DO ib=1,nbasmax
       DO ig=1,nbpt
          netflow_fast_diag(ig) = netflow_fast_diag(ig) + runoff(ig)*routing_area(ig,ib) &
               - fast_flow(ig,ib) - pond_inflow(ig,ib)
          netflow_slow_diag(ig) = netflow_slow_diag(ig) + drainage(ig)*routing_area(ig,ib) &
               - slow_flow(ig,ib)
          netflow_stream_diag(ig) = netflow_stream_diag(ig) + flood_flow(ig,ib) + transport(ig,ib) &
               - stream_flow(ig,ib) - return_swamp(ig,ib) - floods(ig,ib)
       ENDDO
    ENDDO

    !! Grid cell averaging
    DO ig=1,nbpt
       netflow_fast_diag(ig) = netflow_fast_diag(ig)/totarea(ig)
       netflow_slow_diag(ig) = netflow_slow_diag(ig)/totarea(ig)
       netflow_stream_diag(ig) = netflow_stream_diag(ig)/totarea(ig)
    ENDDO

    !
    !
    ! Compute the fluxes which leave the routing scheme
    !
    ! Lakeinflow is in Kg/dt
    ! returnflow is in Kg/m^2/dt
    !
    hydrographs(:) = zero
    slowflow_diag(:) = zero
    fast_diag(:) = zero
    slow_diag(:) = zero
    stream_diag(:) = zero
    flood_diag(:) =  zero
    pond_diag(:) =  zero
    irrigation(:) = zero
    !
    !
    DO ib=1,nbasmax
       !
       DO ig=1,nbpt
          IF (hydrodiag(ig,ib) > 0 ) THEN
             hydrographs(ig) = hydrographs(ig) + fast_flow(ig,ib) + slow_flow(ig,ib) + & 
                  &  stream_flow(ig,ib) 
             slowflow_diag(ig) = slowflow_diag(ig) + slow_flow(ig,ib)
          ENDIF
          fast_diag(ig) = fast_diag(ig) + fast_reservoir(ig,ib)
          slow_diag(ig) = slow_diag(ig) + slow_reservoir(ig,ib)
          stream_diag(ig) = stream_diag(ig) + stream_reservoir(ig,ib)
          flood_diag(ig) = flood_diag(ig) + flood_reservoir(ig,ib)
          irrigation (ig) = irrigation (ig) + irrig_actual(ig,ib) + irrig_adduct(ig,ib)
       ENDDO
    ENDDO
    !
    DO ig=1,nbpt
       fast_diag(ig) = fast_diag(ig)/totarea(ig)
       slow_diag(ig) = slow_diag(ig)/totarea(ig)
       stream_diag(ig) = stream_diag(ig)/totarea(ig)
       flood_diag(ig) = flood_diag(ig)/totarea(ig)
       pond_diag(ig) = pond_reservoir(ig)/totarea(ig)
       !
       irrigation(ig) = irrigation(ig)/totarea(ig)
       !
       ! The three output types for the routing : endoheric basins,, rivers and 
       ! diffuse coastal flow.
       !
       lakeinflow(ig) = transport(ig,nbasmax+1)
       coastalflow(ig) = transport(ig,nbasmax+2)
       riverflow(ig) = transport(ig,nbasmax+3)
       !
    ENDDO
    !
    flood_res = flood_diag + pond_diag
    

    !! Remove water from lake reservoir if it exceeds the maximum limit and distribute it 
    !! uniformly over all possible the coastflow gridcells
    
    ! Calculate lake_overflow and remove it from lake_reservoir
    DO ig=1,nbpt
       lake_overflow(ig) = MAX(0., lake_reservoir(ig) - max_lake_reservoir*totarea(ig))
       lake_reservoir(ig) = lake_reservoir(ig) - lake_overflow(ig)
    END DO
    ! Transform lake_overflow from kg/grid-cell/dt_routing into kg/m^2/s
    CALL xios_orchidee_send_field("lake_overflow",lake_overflow(:)/totarea(:)/dt_routing)

    ! Calculate the sum of the lake_overflow and distribute it uniformly over all gridboxes
    CALL gather(lake_overflow,lake_overflow_g)
    IF (is_root_prc) THEN
       total_lake_overflow=SUM(lake_overflow_g)
    END IF
    CALL bcast(total_lake_overflow)

    ! Distribute the lake_overflow uniformly over all coastal gridcells
    ! lake_overflow_coast is only calculated to be used as diagnostics if needed
    DO ig=1,nbpt
       coastalflow(ig) = coastalflow(ig) + total_lake_overflow/nb_coast_gridcells * mask_coast(ig)
       lake_overflow_coast(ig) = total_lake_overflow/nb_coast_gridcells * mask_coast(ig)
    END DO
    ! Transform from kg/grid-cell/dt_routing into m^3/grid-cell/s to match output unit of coastalflow
    CALL xios_orchidee_send_field("lake_overflow_coast",lake_overflow_coast/mille/dt_routing)
   

  END SUBROUTINE routing_flow
  !
!! ================================================================================================================================
!! SUBROUTINE   : routing_lake
!!
!>\BRIEF        : This subroutine stores water in lakes so that it does not cycle through the runoff.
!!                For the moment it only works for endoheric lakes but I can be extended in the future.
!!
!! DESCRIPTION (definitions, functional, design, flags): The return flow to the soil moisture reservoir
!! is based on a maximum lake evaporation rate (maxevap_lake). \n
!!
!! RECENT CHANGE(S): None
!!
!! MAIN OUTPUT VARIABLE(S):
!!
!! REFERENCES   : None
!!
!! FLOWCHART    :None
!! \n
!_ ================================================================================================================================

  SUBROUTINE routing_lake(nbpt, dt_routing, lakeinflow, humrel, return_lakes)
    !
    IMPLICIT NONE
    !
!! INPUT VARIABLES
    INTEGER(i_std), INTENT(in) :: nbpt               !! Domain size (unitless)
    REAL(r_std), INTENT (in)   :: dt_routing         !! Routing time step (s)
    REAL(r_std), INTENT(out)    :: lakeinflow(nbpt)   !! Water inflow to the lakes (kg/dt)
    REAL(r_std), INTENT(in)    :: humrel(nbpt)       !! Soil moisture stress, root extraction potential (unitless)
    !
!! OUTPUT VARIABLES
    REAL(r_std), INTENT(out)   :: return_lakes(nbpt) !! Water from lakes flowing back into soil moisture (kg/m^2/dt)
    !
!! LOCAL VARIABLES
    INTEGER(i_std)             :: ig                 !! Indices (unitless)
    REAL(r_std)                :: refill             !!
    REAL(r_std)                :: total_area         !! Sum of all the surfaces of the basins (m^2)

!_ ================================================================================================================================
    !
    !
    DO ig=1,nbpt
       !
       total_area = SUM(routing_area(ig,:))
       !
       lake_reservoir(ig) = lake_reservoir(ig) + lakeinflow(ig)
       
       IF ( doswamps ) THEN
          ! Calculate a return flow that will be extracted from the lake reservoir and reinserted in the soil in hydrol
          ! Uptake in Kg/dt
          refill = MAX(zero, maxevap_lake * (un - humrel(ig)) * dt_routing * total_area)
          return_lakes(ig) = MIN(refill, lake_reservoir(ig))
          lake_reservoir(ig) = lake_reservoir(ig) - return_lakes(ig)
          ! Return in Kg/m^2/dt
          return_lakes(ig) = return_lakes(ig)/total_area
       ELSE
          return_lakes(ig) = zero
       ENDIF

       ! This is the volume of the lake scaled to the entire grid.
       ! It would be better to scale it to the size of the lake
       ! but this information is not yet available.
       lake_diag(ig) = lake_reservoir(ig)/total_area

       lakeinflow(ig) = lakeinflow(ig)/total_area

    ENDDO
    !
  END SUBROUTINE routing_lake
  !

!! ================================================================================================================================
!! SUBROUTINE   : routing_diagnostic_p
!!
!>\BRIEF         This parallelized subroutine gives a diagnostic of the basins used
!!
!! DESCRIPTION (definitions, functional, design, flags) : None
!!
!! RECENT CHANGE(S): None
!!
!! MAIN OUTPUT VARIABLE(S):
!!
!! REFERENCES   : None
!!
!! FLOWCHART    : None
!! \n
!_ ================================================================================================================================

  SUBROUTINE routing_diagnostic_p(nbpt, index, lalo, resolution, contfrac, hist_id, hist2_id)
    !
    IMPLICIT NONE
    
!! INPUT VARIABLES
    INTEGER(i_std), INTENT(in)      :: nbpt               !! Domain size (unitless)
    INTEGER(i_std), INTENT(in)      :: index(nbpt)        !! Indices of the points on the map (unitless)
    REAL(r_std), INTENT(in)         :: lalo(nbpt,2)       !! Vector of latitude and longitudes (beware of the order !)
    REAL(r_std), INTENT(in)         :: resolution(nbpt,2) !! The size of each grid box in X and Y (m)
    REAL(r_std), INTENT(in)         :: contfrac(nbpt)     !! Fraction of land in each grid box (unitless;0-1)
    INTEGER(i_std),INTENT (in)      :: hist_id            !! Access to history file (unitless)
    INTEGER(i_std),INTENT (in)      :: hist2_id           !! Access to history file 2 (unitless)
    !
!! LOCAL VARIABLES
    REAL(r_std), DIMENSION(nbpt)    :: nbrivers           !! Number of rivers in the grid (unitless)
    REAL(r_std), DIMENSION(nbpt)    :: basinmap           !! Map of basins (unitless)
    REAL(r_std), DIMENSION(nbp_glo) :: nbrivers_g         !! Number of rivers in the grid (unitless)
    REAL(r_std), DIMENSION(nbp_glo) :: basinmap_g         !! Map of basins (unitless)

!_ ================================================================================================================================
    routing_area => routing_area_glo  
    topo_resid => topo_resid_glo
    route_togrid => route_togrid_glo
    route_tobasin => route_tobasin_glo
    route_nbintobas => route_nbintobas_glo
    global_basinid => global_basinid_glo
    hydrodiag=>hydrodiag_glo
    hydroupbasin=>hydroupbasin_glo
    
    IF (is_root_prc) CALL routing_diagnostic(nbp_glo, index_g, lalo_g, resolution_g, contfrac_g, nbrivers_g,basinmap_g)

    routing_area => routing_area_loc  
    topo_resid => topo_resid_loc
    route_togrid => route_togrid_loc
    route_tobasin => route_tobasin_loc
    route_nbintobas => route_nbintobas_loc
    global_basinid => global_basinid_loc
    hydrodiag=>hydrodiag_loc
    hydroupbasin=>hydroupbasin_loc
    
    CALL scatter(nbrivers_g,nbrivers)
    CALL scatter(basinmap_g,basinmap)
    CALL scatter(hydrodiag_glo,hydrodiag_loc)
    CALL scatter(hydroupbasin_glo,hydroupbasin_loc)
       
    CALL xios_orchidee_send_field("basinmap",basinmap)
    CALL xios_orchidee_send_field("nbrivers",nbrivers)

    IF ( .NOT. almaoutput ) THEN
       CALL histwrite_p(hist_id, 'basinmap', 1, basinmap, nbpt, index)
       CALL histwrite_p(hist_id, 'nbrivers', 1, nbrivers, nbpt, index)
    ELSE
    ENDIF
    IF ( hist2_id > 0 ) THEN
       IF ( .NOT. almaoutput ) THEN
          CALL histwrite_p(hist2_id, 'basinmap', 1, basinmap, nbpt, index)
          CALL histwrite_p(hist2_id, 'nbrivers', 1, nbrivers, nbpt, index)
       ELSE
       ENDIF
    ENDIF
    
        
  END SUBROUTINE routing_diagnostic_p

!! ================================================================================================================================
!! SUBROUTINE   : routing_diagnostic
!!
!>\BRIEF         This non-parallelized subroutine gives a diagnostic of the basins used. This produces some information 
!!               on the rivers which are being diagnosed.
!!
!! DESCRIPTION (definitions, functional, design, flags) : As not all rivers can be monitored in the model, we will only
!! archive num_largest rivers. In this routine we will diagnose the num_largest largest rivers and print to the standard
!! output the names of these basins and their area. The list of names of these largest rivers are taken from a list coded in the 
!! routine routing_names. As this standard output is not sufficient, we will also write it to a netCDF file with the routine 
!! routing_diagncfile. It is important to keep for diagnostic the fraction of the largest basins in each grid box and keep information
!! how they are linked one to the other.
!!
!! RECENT CHANGE(S): None
!!
!! MAIN OUTPUT VARIABLE(S): No output variables.
!!
!! REFERENCES   : None
!!
!! FLOWCHART    :None
!! \n
!_ ================================================================================================================================

  SUBROUTINE routing_diagnostic(nbpt, l_index, lalo, resolution, contfrac, nbrivers, basinmap)
    !
    IMPLICIT NONE
    !
!! INPUT VARIABLES
    INTEGER(i_std), INTENT(in)                   :: nbpt                !! Domain size  (unitless)
    INTEGER(i_std), INTENT(in)                   :: l_index(nbpt)       !! Indices of the points on the map (unitless)
    REAL(r_std), INTENT(in)                      :: lalo(nbpt,2)        !! Vector of latitude and longitudes (beware of the order !) 
    REAL(r_std), INTENT(in)                      :: resolution(nbpt,2)  !! The size of each grid box in X and Y (m)
    REAL(r_std), INTENT(in)                      :: contfrac(nbpt)      !! Fraction of land in each grid box (unitless;0-1)
    !
!! OUTPUT VARIABLES
    REAL(r_std), DIMENSION(nbpt), INTENT(out)    :: nbrivers            !! Number of rivers in the grid (unitless)
    REAL(r_std), DIMENSION(nbpt), INTENT(out)    :: basinmap            !! Map of basins (unitless)
    !
!! LOCAL VARIABLES
    INTEGER(i_std), DIMENSION(nbpt,nbasmax)      :: outids              !! IDs of river to which this basin contributes (unitless)
    INTEGER(i_std), ALLOCATABLE, DIMENSION(:,:)  :: pts                 !! List the points belonging to the basin (unitless)
    INTEGER(i_std), ALLOCATABLE, DIMENSION(:,:)  :: ptbas               !! List the basin number for this point (unitless)
    INTEGER(i_std), ALLOCATABLE, DIMENSION(:,:)  :: outpt               !! Outflow point for each basin (unitless)
    INTEGER(i_std), ALLOCATABLE, DIMENSION(:)    :: nb_pts              !! Number of points in the basin (unitless)
    REAL(r_std), ALLOCATABLE, DIMENSION(:)       :: totarea             !! Total area of basin (m^2)
    REAL(r_std), ALLOCATABLE, DIMENSION(:)       :: tmparea             !! 
    INTEGER(i_std), ALLOCATABLE, DIMENSION(:)    :: topids              !! The IDs of the first num_largest basins (unitless)
    CHARACTER(LEN=25), ALLOCATABLE, DIMENSION(:) :: basin_names         !! Names of the rivers (unitless)
    CHARACTER(LEN=25)                            :: name_str            !!
    !
    LOGICAL                                      :: river_file          !! Choose to write a description of the rivers (true/false)
    CHARACTER(LEN=80)                            :: river_file_name     !! Filename in which we write the description of the rivers (unitless)
    !
    CHARACTER(LEN=25), ALLOCATABLE, DIMENSION(:)  :: sorted_names       !!
    INTEGER(i_std), ALLOCATABLE, DIMENSION(:)     :: streams_nb         !! Number of streams in basin (unitless)
    INTEGER(i_std), ALLOCATABLE, DIMENSION(:)     :: streams_avehops    !! Average number of hops in streams (unitless)
    INTEGER(i_std), ALLOCATABLE, DIMENSION(:)     :: streams_minhops    !! Minimum number of hops in streams (unitless)
    INTEGER(i_std), ALLOCATABLE, DIMENSION(:)     :: streams_maxhops    !! Minimum number of hops in streams (unitless)
    REAL(r_std), ALLOCATABLE, DIMENSION(:)        :: streams_resid      !! Average residence time
    !
    REAL(r_std), ALLOCATABLE, DIMENSION(:,:)      :: lbasin_area        !!
    REAL(r_std), ALLOCATABLE, DIMENSION(:,:)      :: lbasin_uparea      !!
    INTEGER(i_std), ALLOCATABLE, DIMENSION(:,:)   :: lrivercode         !!
    !
    INTEGER(i_std)                                :: ig, ib, og, ob, ign, ibn, ff(1), ic, icc, nb_small, idbas, slen, ii !! Indices (unitless)
    INTEGER(i_std)                                :: ier                !! Error handling
    CHARACTER(LEN=3)                              :: nn                 !!
    INTEGER(i_std)                                :: name_found         !!
    !
    REAL(r_std)                                   :: averesid           !!
    REAL(r_std), DIMENSION(nbasmax)               :: tmpbas             !!
    REAL(r_std), DIMENSION(nbpt,nbasmax)          :: areaupbasin        !!
    INTEGER(i_std), ALLOCATABLE, DIMENSION(:)     :: sortedrivs         !!
    !
    ! Variables for the river coding
    !
    INTEGER(i_std)                               :: longest_river       !!
    INTEGER(i_std)                               :: nbmax               !!
    INTEGER(i_std), ALLOCATABLE, DIMENSION(:,:)  :: allstreams          !!
    REAL(r_std), ALLOCATABLE, DIMENSION(:,:)     :: upstreamchange      !!
    INTEGER(i_std), ALLOCATABLE, DIMENSION(:)    :: tstreams, tslen, tpts, tptbas, tcode !!
    REAL(r_std), ALLOCATABLE, DIMENSION(:)       :: tuparea             !!
    REAL(r_std), ALLOCATABLE, DIMENSION(:)       :: tupstreamchange     !!
    !
    LOGICAL                                      :: err_nbpt_grid_basin !! (true/false)
    LOGICAL                                      :: err_basin_number    !! (true/false)

!_ ================================================================================================================================
    !
    !
    ALLOCATE(pts(num_largest, nbpt), stat=ier)
    IF (ier /= 0) CALL ipslerr_p(3,'routing_diagnostic','Pb in allocate for pts','','')

    ALLOCATE(ptbas(num_largest, nbpt), stat=ier)
    IF (ier /= 0) CALL ipslerr_p(3,'routing_diagnostic','Pb in allocate for ptbas','','')

    ALLOCATE(outpt(num_largest, 2), stat=ier)
    IF (ier /= 0) CALL ipslerr_p(3,'routing_diagnostic','Pb in allocate for outpt','','')

    ALLOCATE(nb_pts(num_largest), stat=ier)
    IF (ier /= 0) CALL ipslerr_p(3,'routing_diagnostic','Pb in allocate for nb_pts','','')

    ALLOCATE(totarea(num_largest), tmparea(num_largest), stat=ier)
    IF (ier /= 0) CALL ipslerr_p(3,'routing_diagnostic','Pb in allocate for totarea','','')

    ALLOCATE(topids(num_largest), stat=ier)
    IF (ier /= 0) CALL ipslerr_p(3,'routing_diagnostic','Pb in allocate for topids','','')

    ALLOCATE(sortedrivs(num_largest), stat=ier)
    IF (ier /= 0) CALL ipslerr_p(3,'routing_diagnostic','Pb in allocate for sortedrivs','','')

    ALLOCATE(sorted_names(num_largest), stat=ier)
    IF (ier /= 0) CALL ipslerr_p(3,'routing_diagnostic','Pb in allocate for sorted_names','','')

    ALLOCATE(streams_nb(num_largest), streams_avehops(num_largest), streams_minhops(num_largest), stat=ier)
    IF (ier /= 0) CALL ipslerr_p(3,'routing_diagnostic','Pb in allocate for streams_nb','','')

    ALLOCATE(streams_maxhops(num_largest), stat=ier)
    IF (ier /= 0) CALL ipslerr_p(3,'routing_diagnostic','Pb in allocate for streams_maxhops','','')

    ALLOCATE(streams_resid(num_largest), stat=ier)
    IF (ier /= 0) CALL ipslerr_p(3,'routing_diagnostic','Pb in allocate for streams_resid','','')
    
    ALLOCATE(lbasin_area(num_largest,nbpt), lbasin_uparea(num_largest,nbpt), lrivercode(num_largest,nbpt), stat=ier)
    IF (ier /= 0) CALL ipslerr_p(3,'routing_diagnostic','Pb in allocate for lbasin_area','','')
    
    IF ( .NOT. is_root_prc) THEN
       WRITE(numout,*) "routing_diagnostic is not suitable for running in parallel"
       WRITE(numout,*) "We are here on a non root processor. is_root_prc = ", is_root_prc
       WRITE(numout,*) "STOP from routing_diagnostic"
       CALL ipslerr_p(3,'routing_diagnostic','This routine is not suitable for running in parallel','','')
    ENDIF
    
    
    !Config Key   = RIVER_DESC
    !Config Desc  = Writes out a description of the rivers
    !Config If    = RIVER_ROUTING
    !Config Def   = n
    !Config Help  = This flag allows to write out a file containing the list of 
    !Config         rivers which are beeing simulated. It provides location of outflow
    !Config         drainage area, name and ID.
    !Config Units = [FLAG]
    !
    river_file=.FALSE.
    CALL getin('RIVER_DESC', river_file)
    !
    !Config Key   = RIVER_DESC_FILE
    !Config Desc  = Filename in which we write the description of the rivers. If suffix is ".nc" a netCDF file is created
    !Config If    = RIVER_DESC
    !Config Def   = river_desc.nc
    !Config Help  = File name where we will write the information. If the suffix is ".nc" a netCDF file is generated. Else
    !Config         a simple text file will contain some information. The netCDF file is valuable for post-processing the
    !               data as it will contain the fraction of the large basins in each grid box.
    !Config Units = [FILE]
    !
    river_file_name="river_desc.nc"
    CALL getin('RIVER_DESC_FILE', river_file_name)
    !
    !
    ! First we get the list of all river outflow points
    ! We work under the assumption that we only have num_largest basins finishing with
    ! nbasmax+3. This is checked in routing_truncate.
    !
    nb_small = 1
    outpt(:,:) = -1
    ic = 0
    DO ig=1,nbpt
       DO ib=1,nbasmax
          ign = route_togrid(ig, ib)
          ibn = route_tobasin(ig, ib)
          IF ( ibn .EQ. nbasmax+3) THEN
             ic = ic + 1
             outpt(ic,1) = ig
             outpt(ic,2) = ib
             !
             ! Get the largest id of the basins we call a river. This is
             ! to extract the names of all rivers.
             !
             IF ( global_basinid(ig,ib) > nb_small ) THEN
                nb_small = global_basinid(ig,ib)
             ENDIF
          ENDIF
       ENDDO
    ENDDO
    
    nb_small = MIN(nb_small, 349)
    
    ALLOCATE(basin_names(nb_small), stat=ier)
    IF (ier /= 0) CALL ipslerr_p(3,'routing_diagnostic','Pb in allocate for basins_names','','')

    CALL routing_names(nb_small, basin_names)
    !
    ! Go through all points and basins to see if they outflow as a river and store the
    ! information needed in the various arrays.
    !
    nb_pts(:) = 0
    totarea(:) = zero
    hydrodiag(:,:) = 0
    areaupbasin(:,:) = zero
    outids(:,:) = -1
    ob = -1
    og = -1
    lbasin_area(:,:) = zero
    lbasin_uparea(:,:) = zero
    longest_river = 0
    !
    err_nbpt_grid_basin = .FALSE.
    loopgridbasin : DO ig=1,nbpt
       !
       DO ib=1,nbasmax
          IF ( routing_area(ig,ib) .GT. zero ) THEN
             ic = 0
             ign = ig
             ibn = ib
             ! Locate outflow point
             DO WHILE (ibn .GT. 0 .AND. ibn .LE. nbasmax .AND. ic .LT. nbasmax*nbpt)
                ic = ic + 1
                og = ign
                ob = ibn
                ign = route_togrid(og, ob)
                ibn = route_tobasin(og, ob)
                areaupbasin(og, ob) = areaupbasin(og, ob) + routing_area(ig,ib)
             ENDDO
             !
             longest_river = MAX(longest_river, ic)
             !
             ! Now that we have an outflow check if it is one of the num_largest rivers. 
             ! In this case we keeps the location so we diagnose it.
             !
             IF ( ibn .EQ. nbasmax + 3) THEN
                DO icc = 1,num_largest
                   IF ( outpt(icc,1) .EQ. og .AND. outpt(icc,2) .EQ. ob ) THEN
                      !
                      ! We only keep this point for our map if it is large enough.
                      !
                      nb_pts(icc) = nb_pts(icc) + 1
                      !
                      !
                      IF ( nb_pts(icc) > nbpt ) THEN
                         err_nbpt_grid_basin = .TRUE.
                         EXIT loopgridbasin
                      ENDIF
                      !
                      pts(icc, nb_pts(icc)) = ig
                      ptbas(icc, nb_pts(icc)) = ib
                      totarea(icc) = totarea(icc) + routing_area(ig,ib)
                      !
                      lbasin_area(icc,nb_pts(icc)) = routing_area(ig,ib)
                      !
                      ! ID of the river is taken from the last point before the outflow.
                      topids(icc) = global_basinid(og,ob)
                      outids(ig,ib) = global_basinid(og,ob)
                      !
                      ! On this gridbox and basin we will diagnose the hydrograph
                      !
                      hydrodiag(ig, ib) = 1
                      !
                   ENDIF
                ENDDO
             ENDIF
          ENDIF
          !
       ENDDO
       !
    ENDDO loopgridbasin
    !
    IF ( err_nbpt_grid_basin ) THEN
       WRITE(numout, *) "routing_diagnostic : The number of grid points in basin ", icc
       WRITE(numout, *) "routing_diagnostic : is larger than anticiped. "
       CALL ipslerr_p(3, 'routing_diagnostic', 'We are heading for a out of bounds in arrays pts, ptsbas and lbasin_area.',&
                     & 'Increase the last dimension of these arrays.','')
    ENDIF
    !
    ! Now we decide which points we will keep from the largest basins
    !
    ! Temporary fix
    route_nbintobas(:,:) = 0
    !
    basinmap(:) = zero
    DO ig=1,nbpt
       !
       ! Look for the dominant basin in this grid. This information only affects some
       ! diagnostics : hydrographs and saved area upstream.
       !
       icc = 0
       idbas = -1
       !
       DO ib=1,nbasmax
          IF ( outids(ig,ib) > 0 ) THEN
             IF ( COUNT(outids(ig,:) == outids(ig,ib)) > icc ) THEN
                icc = COUNT(outids(ig,:) == outids(ig,ib))
                idbas = outids(ig,ib)
             ENDIF
          ENDIF
       ENDDO
       !
       ! If we have found a point from the large basins and decided which one
       ! takes over this grid then we note it on the map.
       ! Clean-up a little the hydrodiag array
       !
       IF ( idbas > 0 ) THEN
          basinmap(ig) = REAL(idbas, r_std)
       ENDIF
       !
       ! Now place the hydrograph diagnostic on the point closest to the
       ! ocean.
       !
       tmpbas(:) = zero
       DO ib=1,nbasmax
          IF ( outids(ig,ib) .EQ. idbas) THEN
             tmpbas(ib) = areaupbasin(ig,ib)
          ENDIF
       ENDDO
       hydrodiag(ig,:) = 0
       ff=MAXLOC(tmpbas)
       hydrodiag(ig,ff(1)) = 1
       hydroupbasin(ig) = areaupbasin(ig,ff(1))
       !
    ENDDO
    !
    !
    !
    tmparea(:) = totarea(:)
    DO icc = 1, num_largest
       ff = MAXLOC(tmparea)
       sortedrivs(icc) = ff(1)
       tmparea(ff(1)) = 0.0
    ENDDO
    !
    ! Diagnose the complexity of the basins obtained and determine their code in the Pfafstetter system
    !
    nbmax=MAXVAL(nb_pts)
    ALLOCATE(allstreams(nbmax, longest_river), upstreamchange(nbmax, longest_river), stat=ier)
    IF (ier /= 0) CALL ipslerr_p(3,'routing_diagnostic','Pb in allocate for allstreams','','')

    ALLOCATE(tstreams(longest_river), tupstreamchange(longest_river), stat=ier)
    IF (ier /= 0) CALL ipslerr_p(3,'routing_diagnostic','Pb in allocate for tstreams','','')

    ALLOCATE(tslen(nbmax), tpts(nbmax), tptbas(nbmax), tuparea(nbmax), stat=ier)
    IF (ier /= 0) CALL ipslerr_p(3,'routing_diagnostic','Pb in allocate for tslen','','')

    ALLOCATE(tcode(nbmax), stat=ier)
    IF (ier /= 0) CALL ipslerr_p(3,'routing_diagnostic','Pb in allocate for tcode','','')

    DO icc = 1, num_largest
       !
       ! Work through the largest basins
       !
       idbas = sortedrivs(icc)
       !
       streams_nb(idbas) = 0
       streams_avehops(idbas) = 0
       streams_minhops(idbas) = undef_int
       streams_maxhops(idbas) = 0
       streams_resid(idbas) = zero
       tslen(:) = 0
       !
       allstreams(:,:) = 0
       upstreamchange(:,:) = zero
       !
       DO ii=1,nb_pts(idbas)
          !
          ig = pts(idbas, ii)
          ib = ptbas(idbas, ii)
          !
          lbasin_uparea(idbas,ii) = areaupbasin(ig,ib)
          !
          slen = 0
          ign = ig
          ibn = ib
          og = ig
          ob = ib
          !
          averesid = zero
          tupstreamchange(:) = zero
          ! go to outflow point to count the number of hops
          DO WHILE (ibn .GT. 0 .AND. ibn .LE. nbasmax)
             ! Store data
             slen = slen + 1
             tstreams(slen) = ign
             tupstreamchange(slen) = areaupbasin(ign,ibn)-areaupbasin(og,ob)
             ! Move to next point
             og = ign
             ob = ibn
             ign = route_togrid(og, ob)
             ibn = route_tobasin(og, ob)
             averesid = averesid + topo_resid(og, ob)**2
          ENDDO
          !
          allstreams(ii,1:slen) = tstreams(slen:1:-1)
          upstreamchange(ii,1:slen) = tupstreamchange(slen:1:-1)
          tslen(ii) = slen
          !
          ! Save diagnostics
          !
          streams_nb(idbas) = streams_nb(idbas) + 1
          streams_avehops(idbas) = streams_avehops(idbas) + slen
          streams_resid(idbas) = streams_resid(idbas) + SQRT(averesid)
          IF ( slen < streams_minhops(idbas) ) THEN
             streams_minhops(idbas) = slen
          ENDIF
          IF ( slen > streams_maxhops(idbas) ) THEN
             streams_maxhops(idbas) = slen
          ENDIF
          !
       ENDDO
       ! build the average
       IF ( streams_nb(idbas) > 0 ) THEN
          streams_avehops(idbas) = streams_avehops(idbas)/streams_nb(idbas)
          streams_resid(idbas) = streams_resid(idbas)/REAL(streams_nb(idbas), r_std)
       ELSE
          ! River without streams ... very rare but happens
          streams_avehops(idbas) = zero
          streams_resid(idbas) = zero
          streams_maxhops(idbas) = zero
          streams_minhops(idbas) = zero
       ENDIF
       !
       !
       ii=nb_pts(idbas)
       tpts(:) = 0
       tpts(1:ii) = pts(idbas,1:ii)
       tptbas(:) = 0
       tptbas(1:ii) = ptbas(idbas,1:ii)
       tuparea(:) = 0
       tuparea(1:ii) = lbasin_uparea(idbas,1:ii)
       !
       CALL routing_diagcode(ii, tpts, tptbas, tuparea, tslen, MAXVAL(tslen), allstreams, upstreamchange, tcode)  
       !
       lrivercode(idbas,:) = 0
       lrivercode(idbas,1:ii) = tcode(1:ii)
       !
    ENDDO
    !
    ! Create the sorted list of names
    !
    err_basin_number = .FALSE.
    DO icc = 1, num_largest
       !
       ib=sortedrivs(icc)
       !
       IF ( topids(ib) .GT. nb_small ) THEN
          IF (topids(ib) <= 99 ) THEN
             WRITE(sorted_names(icc), '("Nb_",I2.2)') topids(ib)
          ELSE IF (topids(ib) <= 999 ) THEN
             WRITE(sorted_names(icc), '("Nb_",I3.3)') topids(ib)
          ELSE IF (topids(ib) <= 9999 ) THEN
             WRITE(sorted_names(icc), '("Nb_",I4.4)') topids(ib)
          ELSE IF (topids(ib) <= 99999 ) THEN
             WRITE(sorted_names(icc), '("Nb_",I5.5)') topids(ib)
          ELSE IF (topids(ib) <= 999999 ) THEN
             WRITE(sorted_names(icc), '("Nb_",I6.6)') topids(ib)
          ELSE
             err_basin_number = .TRUE.
             EXIT
          ENDIF

       ELSE
          IF (topids(ib) <= -1 ) THEN
             WRITE(sorted_names(icc), '("Ne_",I2.2)') -1*topids(ib)
          ELSE
             IF (printlev >=6) WRITE(numout,*) ">>> nb_small, ib, topids :", nb_small, ib, topids(ib)
             sorted_names(icc) = basin_names(topids(ib))
          ENDIF
       ENDIF
       !
    ENDDO
    !
    IF ( err_basin_number ) THEN
       CALL ipslerr_p(3, 'routing_diagnostic', 'We found a basin number larger than 999999.',&
            & 'This is impossible. Please verify your configuration.','')
    ENDIF
    !
    ! Check for doubles and rename if needed
    !
    DO icc = 1, num_largest
       name_found=0
       DO ic=1, num_largest
          IF ( TRIM(sorted_names(icc)) == TRIM(sorted_names(ic)) ) THEN
             name_found = name_found + 1
          ENDIF
       ENDDO
       
       IF ( name_found > 1 ) THEN
          DO ic=num_largest,1,-1
             IF ( TRIM(sorted_names(icc)) == TRIM(sorted_names(ic)) .AND. name_found > 1 ) THEN
                IF ( name_found < 10 ) THEN
                   WRITE(nn,'(I1)')  name_found
                ELSE IF ( name_found < 100 ) THEN
                   WRITE(nn,'(I2)')  name_found
                ELSE IF ( name_found < 1000 ) THEN
                   WRITE(nn,'(I3)')  name_found
                ELSE
                   ! Make sur to increase nn size when adding more cases
                   CALL ipslerr_p(3, 'routing_diagnostic', &
                        'Non of the previous values can fit in the new char', &
                        'Add a new condition to deal with it', '')
                ENDIF
                sorted_names(ic) = TRIM(sorted_names(ic))//TRIM(nn)
                name_found = name_found - 1
             ENDIF
          ENDDO
       ENDIF
       
    ENDDO
    !
    ! Print to stdout on ROOT_PROC the diagnostics for the largest basins we have found.
    !
    IF (printlev>=1) THEN
       DO icc = 1, num_largest
          IF ( nb_pts(sortedrivs(icc)) .GT. 2 ) THEN
             name_str = sorted_names(icc)
             WRITE(numout,'("Basin ID ", I5," ", A15, " Area [km^2] : ", F13.4, " Nb points : ", I4)')&
                  & topids(sortedrivs(icc)), name_str(1:15), totarea(sortedrivs(icc))/1.e6,  nb_pts(sortedrivs(icc))
          ENDIF
       ENDDO
    END IF
    !
    ! Save some of the basin information into files.
    !
    IF ( river_file ) THEN

       IF ( INDEX(river_file_name,".nc") > 1 ) THEN

          CALL routing_diagncfile(river_file_name, nbpt, lalo, nb_pts, topids, sorted_names, sortedrivs, &
               &                  pts, lbasin_area, lbasin_uparea, lrivercode, outpt, streams_nb, streams_avehops, &
               &                  streams_minhops, streams_maxhops, streams_resid)

       ELSE

          OPEN(diagunit, FILE=river_file_name)
          WRITE(diagunit,'(A)') "Basin ID, Area [km^2], Nb points, Lon and Lat of outflow"
          WRITE(diagunit,'(A)') "Nb streams, total number of hops, min, ave and max number of hops per stream"
          !
          DO icc = 1, num_largest
             !
             IF ( nb_pts(sortedrivs(icc)) .GT. 2 ) THEN
                !
                name_str = sorted_names(icc)
                !
                WRITE(diagunit,'(I5,A25,F14.5,I5,2F9.2)') topids(sortedrivs(icc)), name_str(1:15), totarea(sortedrivs(icc))/1.e6, &
                     &    nb_pts(sortedrivs(icc)), lalo(outpt(sortedrivs(icc),1),2), lalo(outpt(sortedrivs(icc),1),1)
                WRITE(diagunit,'(5I9,F16.4)') streams_nb(sortedrivs(icc)), &
                     & streams_avehops(sortedrivs(icc))*streams_nb(sortedrivs(icc)), &
                     & streams_minhops(sortedrivs(icc)), &
                     & streams_avehops(sortedrivs(icc)), &
                     & streams_maxhops(sortedrivs(icc)), streams_resid(sortedrivs(icc))
                !
             ENDIF
             !
          ENDDO
          !
          CLOSE(diagunit)
          !
       ENDIF
       !
    ENDIF
    !
    !
    nbrivers(:) = zero
    DO ig=1,nbpt
       nbrivers(ig) = COUNT(route_tobasin(ig,1:nbasmax) == nbasmax+3)
    ENDDO
    DO ig=1,nbpt
       IF ( nbrivers(ig) > 1 ) THEN
          WRITE(numout,*) 'Grid box ', ig, ' has ', NINT(nbrivers(ig)), ' outflow points.'
          WRITE(numout,*) 'The rivers which flow into the ocean at this point are :'
          DO icc=1,nbasmax
             IF ( route_tobasin(ig,icc) == nbasmax+3) THEN
                IF ( global_basinid(ig,icc) <= nb_small ) THEN
                   WRITE(numout,*) 'ID = ',global_basinid(ig,icc), ' Name = ', basin_names(global_basinid(ig,icc))
                ELSE
                   WRITE(numout,*) 'ID = ',global_basinid(ig,icc), ' Problem ===== ID is larger than possible'
                ENDIF
             ENDIF
          ENDDO
       ENDIF
    ENDDO
    !
    ic = COUNT(topo_resid .GT. 0.)
    IF (printlev>=1) THEN
       WRITE(numout,*) 'Maximum topographic index :', MAXVAL(topo_resid)
       WRITE(numout,*) 'Mean topographic index :', SUM(topo_resid, MASK=topo_resid .GT. zero)/ic
       WRITE(numout,*) 'Minimum topographic index :', MINVAL(topo_resid, MASK=topo_resid .GT. zero)
    END IF
    
    DEALLOCATE(pts)
    DEALLOCATE(outpt)
    DEALLOCATE(nb_pts)
    DEALLOCATE(totarea, tmparea)
    DEALLOCATE(streams_nb, streams_avehops, streams_minhops, streams_maxhops)
    !
    DEALLOCATE(lbasin_area, lbasin_uparea, lrivercode)
    !
    DEALLOCATE(allstreams)
    DEALLOCATE(tstreams)
    DEALLOCATE(tslen, tpts, tptbas, tuparea)
    DEALLOCATE(tcode)
    !
    ic = COUNT(topo_resid .GT. 0.)
    IF (printlev>=1) THEN
       WRITE(numout,*) 'Maximum topographic index :', MAXVAL(topo_resid)
       WRITE(numout,*) 'Mean topographic index :', SUM(topo_resid, MASK=topo_resid .GT. 0.)/ic
       WRITE(numout,*) 'Minimum topographic index :', MINVAL(topo_resid, MASK=topo_resid .GT. 0.)
    END IF
    
  END SUBROUTINE routing_diagnostic
  !
!! ================================================================================================================================
!! SUBROUTINE   : routing_diagcode
!!
!>\BRIEF       This subroutine determines the code in the Pfafstetter system for all points
!!              within the given catchment.  
!!
!! DESCRIPTION (definitions, functional, design, flags) : None
!!
!! RECENT CHANGE(S): None
!!
!! MAIN OUTPUT VARIABLE(S): streamcode
!!
!! REFERENCES   : None
!!
!! FLOWCHART    :None
!! \n
!_ ================================================================================================================================

  SUBROUTINE routing_diagcode(ip, tpts, tpbas, tuparea, tslen, ls, allstreams, upstreamchange, streamcode)  
    !
    IMPLICIT NONE
    !
!! INPUT VARIABLES
    INTEGER(i_std), INTENT(in)                   :: ip             !!
    INTEGER(i_std), INTENT(in)                   :: ls             !!
    INTEGER(i_std), DIMENSION(ip), INTENT(in)    :: tpts           !!
    INTEGER(i_std), DIMENSION(ip), INTENT(in)    :: tpbas          !!
    REAL(r_std), DIMENSION(ip), INTENT(in)       :: tuparea        !!
    INTEGER(i_std), DIMENSION(ip), INTENT(in)    :: tslen          !!
    INTEGER(i_std), DIMENSION(ip,ls), INTENT(in) :: allstreams     !!
    REAL(r_std), DIMENSION(ip,ls), INTENT(in)    :: upstreamchange !!
    !
!! OUTPUT VARIABLES
    INTEGER(i_std), DIMENSION(ip), INTENT(out)   :: streamcode     !!
    !
!! LOCAL VARIABLES
    INTEGER(i_std)                               :: ilev, cntsubbas, ib, ic, i, it, ilevmax, imaxlen, nbzero !!
    INTEGER(i_std)                               :: tstreamcode(ip)!!
    INTEGER(i_std)                               :: indsubbas(ip)  !!
    INTEGER(i_std)                               :: iw(ip)         !!
    INTEGER(i_std)                               :: tdiff(ip)      !!
    INTEGER(i_std)                               :: tmpjunc(4)     !!
    INTEGER(i_std)                               :: junction(4)    !!
    INTEGER(i_std)                               :: ff(1)          !!
    INTEGER(i_std)                               :: ll             !!
    REAL(r_std)                                  :: chguparea(ip)  !!
    REAL(r_std)                                  :: largest        !!

!_ ================================================================================================================================
    !
    streamcode(:) = 0
    !
    ! If we accept 4 grid boxes per coded basin then per level we need at least
    ! 4*9=36 boxes.
    !
    ilevmax = 0
    it = ip
    DO WHILE (it >= 36)
       ilevmax = ilevmax+1
       it = it/9
    ENDDO
    !
    DO ilev=1,ilevmax
       !
       ! Count number of sub-basins we already have
       !
       cntsubbas=0
       tstreamcode(:) = streamcode(:)
       DO WHILE ( COUNT(tstreamcode(:) >= 0) > 0 )
         cntsubbas=cntsubbas+1
         indsubbas(cntsubbas) = MAXVAL(tstreamcode(:))
         WHERE ( tstreamcode(:) == indsubbas(cntsubbas) ) tstreamcode = -1
       ENDDO
       !
       ! Go through all these basins in order to find the next Pfafstetter numbers
       !
       DO ib=1,cntsubbas
          !
          ! Get all the streams which have the current Pfadstetter number
          !
          it=0
          DO ic=1,ip
             IF ( streamcode(ic) == indsubbas(ib) ) THEN
                it =it+1
                iw(it)=ic 
             ENDIF
          ENDDO
          !
          ! Which is the longest stream in this basin ?
          !
          ff=MAXLOC(tslen(iw(1:it)))
          imaxlen=iw(ff(1))
          chguparea(:) = zero
          chguparea(1:tslen(imaxlen)) = upstreamchange(imaxlen, 1:tslen(imaxlen))
          !
          IF ( COUNT(chguparea(1:tslen(imaxlen)) > 0) < 4 ) THEN
             !
             ! If this subbasin is too small we just set all points to zero
             !
             DO i=1,it
                streamcode(iw(i)) = streamcode(iw(i))*10
             ENDDO
          ELSE
             ! 
             ! Else do the Pfafstetter numbering
             ! 
             !
             ! Where do we have the 4 largest change in upstream area on this stream.
             ! This must be the confluence of 2 rivers and thus a junction point.
             !
             largest=pi*R_Earth*R_Earth
             DO i=1,4
                ff = MAXLOC(chguparea(1:tslen(imaxlen)), MASK = chguparea(1:tslen(imaxlen)) < largest)
                tmpjunc(i) = ff(1)
                largest=chguparea(tmpjunc(i))
             ENDDO
             ! sort junctions to go from the outflow up-stream
             ff(1)=0
             DO i=1,4
                junction(i) = MINVAL(tmpjunc, MASK=tmpjunc > ff(1))
                ff(1) = junction(i)
             ENDDO
             !
             ! Find all streams which are identical up to that junction and increase their code accordingly 
             !
             DO i=1,it
                ll=MIN(tslen(imaxlen),tslen(iw(i)))
                tdiff(1:ll) = allstreams(imaxlen,1:ll)-allstreams(iw(i),1:ll)
                nbzero = COUNT(tdiff(1:ll) == 0)
                IF (nbzero < junction(1) ) THEN
                   ! Before first of the 4 largest basins
                   streamcode(iw(i)) = streamcode(iw(i))*10+1
                ELSE IF (nbzero == junction(1) ) THEN
                   ! Stream part of the first largest basin
                   streamcode(iw(i)) = streamcode(iw(i))*10+2
                ELSE IF (nbzero < junction(2) ) THEN
                   ! Between first and second stream
                   streamcode(iw(i)) = streamcode(iw(i))*10+3
                ELSE IF (nbzero == junction(2) ) THEN
                   ! Stream part of the second basin
                   streamcode(iw(i)) = streamcode(iw(i))*10+4
                ELSE IF (nbzero < junction(3) ) THEN
                   ! In between stream 2 and 3
                   streamcode(iw(i)) = streamcode(iw(i))*10+5
                ELSE IF (nbzero == junction(3) ) THEN
                   ! Part of 3rd basin
                   streamcode(iw(i)) = streamcode(iw(i))*10+6
                ELSE IF (nbzero < junction(4) ) THEN
                   ! In between 3 and 4th basins
                   streamcode(iw(i)) = streamcode(iw(i))*10+7
                ELSE IF (nbzero == junction(4) ) THEN
                   ! Final of the 4 largest basins
                   streamcode(iw(i)) = streamcode(iw(i))*10+8
                ELSE
                   ! The rest of the points and also the basin of the longest stream
                   streamcode(iw(i)) = streamcode(iw(i))*10+9
                ENDIF
             ENDDO
          ENDIF
       ENDDO
       !
    ENDDO
    !
    !
  END SUBROUTINE routing_diagcode
  !
!! ================================================================================================================================
!! SUBROUTINE   : routing_diagncfile
!!
!>\BRIEF         This subroutine creates a netCDF file containing all the informations
!!                on the largest rivers which can be used for a refined analysis. 
!!
!! DESCRIPTION (definitions, functional, design, flags) : None
!!
!! RECENT CHANGE(S): None
!!
!! MAIN OUTPUT VARIABLE(S): None
!!
!! REFERENCES   : None
!!
!! FLOWCHART    : None
!! \n
!_ ================================================================================================================================

  SUBROUTINE routing_diagncfile(river_file_name, nbpt, lalo, nb_pts, topids, sorted_names, sortedrivs, &
       &       lbasin_index, lbasin_area, lbasin_uparea, lrivercode, outpt, streams_nb, streams_avehops, &
       &       streams_minhops, streams_maxhops, streams_resid)
    !
    USE netcdf
    !
    IMPLICIT NONE
    !
    !
!! INPUT VARIABLES
    REAL(r_std), INTENT(in)                     :: lalo(nbpt,2)             !! Vector of latitude and longitudes (beware of the order !)

!! LOCAL VARIABLES
    CHARACTER(LEN=80)                           :: river_file_name          !! Filename in which we write the description of the rivers (1)
    INTEGER(i_std)                              :: nbpt                     !! Domain size  (unitless)
    INTEGER(i_std), DIMENSION(num_largest)      :: nb_pts                   !! Number of points in the basin (unitless)
    INTEGER(i_std), DIMENSION(num_largest)      :: topids                   !! The IDs of the first num_largest basins (unitless)
    CHARACTER(LEN=25), DIMENSION(num_largest)   :: sorted_names             !! Names of the basins to be put into the file (unitless)
    INTEGER(i_std), DIMENSION(num_largest)      :: sortedrivs               !!
    INTEGER(i_std), DIMENSION(num_largest,nbpt) :: lbasin_index             !!
    REAL(r_std), DIMENSION(num_largest,nbpt)    :: lbasin_area              !!
    REAL(r_std), DIMENSION(num_largest,nbpt)    :: lbasin_uparea            !!
    INTEGER(i_std), DIMENSION(num_largest,nbpt) :: lrivercode               !!
    !
    INTEGER(i_std), DIMENSION(num_largest,2)    :: outpt                    !! Outflow point for each basin (unitless)
    INTEGER(i_std), DIMENSION(num_largest)      :: streams_nb               !! Number of streams in basin (unitless)
    INTEGER(i_std), DIMENSION(num_largest)      :: streams_avehops          !! Average number of hops in streams (unitless)
    INTEGER(i_std), DIMENSION(num_largest)      :: streams_minhops          !! Minimum number of hops in streams (unitless)
    INTEGER(i_std), DIMENSION(num_largest)      :: streams_maxhops          !! Minimum number of hops in streams (unitless)
    REAL(r_std), DIMENSION(num_largest)         :: streams_resid            !! Average residence time
    !
    INTEGER(i_std)                              :: icc, fid, iret, ierr_tot, ib, ij, ik, i, j, lcc !! Indices (unitless)
    INTEGER(i_std)                              :: nlonid, nlatid, varid, varid2, varid3
    INTEGER(i_std)                              :: dims(2)                  !!
    REAL(r_std)                                 :: lon_min, lon_max, lat_min, lat_max
    CHARACTER(LEN=80)                           :: lon_name, lat_name, var_name, long_name, nc_name, att_str

    REAL(r_std)                                 :: basinfrac(iim_g,jjm_g)   !!
    REAL(r_std)                                 :: basinuparea(iim_g,jjm_g) !!
    INTEGER(i_std)                              :: basincode(iim_g,jjm_g)   !!
    !
    LOGICAL                                     :: check=.FALSE.            !! (true/false)
    !
!! PARAMETERS
    INTEGER(i_std),PARAMETER                    :: kind_r_diag=NF90_REAL8   !!
    INTEGER(i_std),PARAMETER                    :: kind_i_diag=NF90_INT     !!

!_ ================================================================================================================================
    !
    !
    ! 1.0 Create the NETCDF file and store the coordinates.
    !
    iret = NF90_CREATE(TRIM(river_file_name), NF90_CLOBBER, fid)
    IF (iret /= NF90_NOERR) THEN
       CALL ipslerr_p (3,'routing_diagncfile', 'Could not create file :', &
            & TRIM(river_file_name), '(Problem with disk place or filename ?)')
    ENDIF
    !
    ! 1.1 Define dimensions
    !
    IF ( grid_type == regular_lonlat ) THEN
       !
       ! 1.1.1 regular grid
       !
       iret = NF90_DEF_DIM(fid, 'lon', iim_g, dims(1))
       IF (iret /= NF90_NOERR) THEN
          CALL ipslerr_p (3,'routing_diagncfile', 'Dimension "x" can not be defined for the file : ', &
               &         TRIM(river_file_name),'(Solution ?)')
       ENDIF
       iret = NF90_DEF_DIM(fid, 'lat', jjm_g, dims(2))
       IF (iret /= NF90_NOERR) THEN
          CALL ipslerr_p (3,'routing_diagncfile', 'Dimension "y" can not be defined for the file : ', &
               &         TRIM(river_file_name),'(Solution ?)')
       ENDIF
    ELSE
       !
       ! 1.1.2 irregular grid
       !
       iret = NF90_DEF_DIM(fid, 'x', iim_g, dims(1))
       IF (iret /= NF90_NOERR) THEN
          CALL ipslerr_p (3,'routing_diagncfile', 'Dimension "x" can not be defined for the file : ', &
               &         TRIM(river_file_name),'(Solution ?)')
       ENDIF
       
       iret = NF90_DEF_DIM(fid, 'y', jjm_g, dims(2))
       IF (iret /= NF90_NOERR) THEN
          CALL ipslerr_p (3,'routing_diagncfile', 'Dimension "y" can not be defined for the file : ', &
               &         TRIM(river_file_name),'(Solution ?)')
       ENDIF
    ENDIF
    !
    !
    ! 1.2 Define variables and attributes
    !
    IF ( grid_type == regular_lonlat ) THEN
       !
       ! 1.2.1 regular grid
       !
       lon_name = 'lon'
       !
       iret = NF90_DEF_VAR(fid, lon_name, kind_r_diag, dims(1), nlonid)
       IF (iret /= NF90_NOERR) THEN
          CALL ipslerr_p (3,'routing_diagncfile', 'Variable '//lon_name//' can not be defined for the file : ', &
               &         TRIM(river_file_name),'(Solution ?)')
       ENDIF
       !
       lat_name = 'lat'
       iret = NF90_DEF_VAR(fid, lat_name, kind_r_diag, dims(2), nlatid)
       IF (iret /= NF90_NOERR) THEN
          CALL ipslerr_p (3,'routing_diagncfile', 'Variable '//lat_name//' can not be defined for the file : ', &
               &         TRIM(river_file_name),'(Solution ?)')
       ENDIF
       !
    ELSE
       !
       ! 1.2.2 irregular grid
       !
       lon_name = 'nav_lon'
       !
       iret = NF90_DEF_VAR(fid, lon_name, kind_r_diag, dims, nlonid)
       IF (iret /= NF90_NOERR) THEN
          CALL ipslerr_p (3,'routing_diagncfile', 'Variable '//lon_name//' can not be defined for the file : ', &
               &         TRIM(river_file_name),'(Solution ?)')
       ENDIF
       !
       lat_name = 'nav_lat'
       iret = NF90_DEF_VAR(fid, lat_name, kind_r_diag, dims, nlatid)
       IF (iret /= NF90_NOERR) THEN
          CALL ipslerr_p (3,'routing_diagncfile', 'Variable '//lat_name//' can not be defined for the file : ', &
               &         TRIM(river_file_name),'(Solution ?)')
       ENDIF
       !
    ENDIF
    !
    ! 1.3 Add attributes to the coordinate variables
    !
    iret = NF90_PUT_ATT(fid, nlonid, 'units', "degrees_east") 
    IF (iret /= NF90_NOERR) THEN
       CALL ipslerr_p (3,'routing_diagncfile', 'Could not add attribut to variable '//lon_name//' for the file :', &
            &          TRIM(river_file_name),'(Solution ?)')
    ENDIF
    !
    lon_min = -180.
    lon_max = 180.
    !
    iret = NF90_PUT_ATT(fid, nlonid, 'valid_min', lon_min)
    IF (iret /= NF90_NOERR) THEN
       CALL ipslerr_p (3,'routing_diagncfile', 'Could not add attribut to variable '//lon_name//' for the file :', &
            &          TRIM(river_file_name),'(Solution ?)')
    ENDIF
    iret = NF90_PUT_ATT(fid, nlonid, 'valid_max', lon_max)
    IF (iret /= NF90_NOERR) THEN
       CALL ipslerr_p (3,'routing_diagncfile', 'Could not add attribut to variable '//lon_name//' for the file :', &
            &          TRIM(river_file_name),'(Solution ?)')
    ENDIF
    !
    iret = NF90_PUT_ATT(fid, nlonid, 'long_name', "Longitude")
    IF (iret /= NF90_NOERR) THEN
       CALL ipslerr_p (3,'routing_diagncfile', 'Could not add attribut to variable '//lon_name//' for the file :', &
            &          TRIM(river_file_name),'(Solution ?)')
    ENDIF
    iret = NF90_PUT_ATT(fid, nlatid, 'units', "degrees_north")
    IF (iret /= NF90_NOERR) THEN
       CALL ipslerr_p (3,'routing_diagncfile', 'Could not add attribut to variable '//lat_name//' for the file :', &
            &          TRIM(river_file_name),'(Solution ?)')
    ENDIF
    !
    lat_max = 90.
    lat_min = -90.
    !
    iret = NF90_PUT_ATT(fid, nlatid, 'valid_min', lat_min)
    IF (iret /= NF90_NOERR) THEN
       CALL ipslerr_p (3,'routing_diagncfile', 'Could not add attribut to variable '//lat_name//' for the file :', &
            &          TRIM(river_file_name),'(Solution ?)')
    ENDIF
    iret = NF90_PUT_ATT(fid, nlatid, 'valid_max', lat_max)
    IF (iret /= NF90_NOERR) THEN
       CALL ipslerr_p (3,'routing_diagncfile', 'Could not add attribut to variable '//lat_name//' for the file :', &
            &          TRIM(river_file_name),'(Solution ?)')
    ENDIF
    iret = NF90_PUT_ATT(fid, nlatid, 'long_name', "Latitude")
    IF (iret /= NF90_NOERR) THEN
       CALL ipslerr_p (3,'routing_diagncfile', 'Could not add attribut to variable '//lat_name//' for the file :', &
            &          TRIM(river_file_name),'(Solution ?)')
    ENDIF
    !
    iret = NF90_ENDDEF(fid)
    IF (iret /= NF90_NOERR) THEN
       CALL ipslerr_p (3,'routing_diagncfile', 'Could not end definitions in the file : ', &
 &          TRIM(river_file_name),'(Solution ?)')
    ENDIF
    !
    !  1.4 Write coordinates
    !
    IF ( grid_type == regular_lonlat ) THEN
       !
       ! 1.4.1 regular grid
       !
       iret = NF90_PUT_VAR(fid, nlonid, lon_g(1:iim_g,1))
       IF (iret /= NF90_NOERR) THEN
          CALL ipslerr_p (3,'routing_diagncfile', 'Could not put variable nav_lon  in the file : ', &
               &          TRIM(river_file_name),'(Solution ?)')
       ENDIF
       !
       iret = NF90_PUT_VAR(fid, nlatid, lat_g(1,1:jjm_g))
       IF (iret /= NF90_NOERR) THEN
          CALL ipslerr_p (3,'routing_diagncfile', 'Could not put variable nav_lat  in the file : ', &
               &          TRIM(river_file_name),'(Solution ?)')
       ENDIF
    ELSE
       !
       ! 1.4.2 irregular grid
       !
       iret = NF90_PUT_VAR(fid, nlonid, lon_g)
       IF (iret /= NF90_NOERR) THEN
          CALL ipslerr_p (3,'routing_diagncfile', 'Could not put variable nav_lon  in the file : ', &
               &          TRIM(river_file_name),'(Solution ?)')
       ENDIF
       !
       iret = NF90_PUT_VAR(fid, nlatid, lat_g)
       IF (iret /= NF90_NOERR) THEN
          CALL ipslerr_p (3,'routing_diagncfile', 'Could not put variable nav_lat  in the file : ', &
               &          TRIM(river_file_name),'(Solution ?)')
       ENDIF
    ENDIF
    !
    ! 2.0 Go through all basins and wirte the information into the netCDF file.
    !
    DO icc = 1, num_largest
       !
       ! 2.1 Compute the fields to be saved in the file
       !
       ib=sortedrivs(icc)
       !
       !
       IF ( nb_pts(ib) > 2 ) THEN
          !
          basinfrac(:,:) = zero
          basinuparea(:,:) = zero
          basincode(:,:) = zero
          !
          DO ij=1, nb_pts(ib)

             ik=lbasin_index(ib,ij)

             j = ((index_g(ik)-1)/iim_g) + 1
             i = (index_g(ik)-(j-1)*iim_g)

             basinfrac(i,j) = basinfrac(i,j) + lbasin_area(ib,ij)/(resolution_g(ik,1)*resolution_g(ik,2))
             basinuparea(i,j) = MAX(basinuparea(i,j), lbasin_uparea(ib,ij))
             basincode(i,j) = lrivercode(ib,ij)

          ENDDO
          !
          DO i=1,iim_g
             DO j=1,jjm_g
                IF ( basinfrac(i,j) <= EPSILON(zero) ) THEN
                   basinfrac(i,j) = undef_sechiba
                   basinuparea(i,j)  = undef_sechiba
                   basincode(i,j)  = undef_int
                ELSE
                   basinfrac(i,j) = MIN(basinfrac(i,j), un)
                ENDIF 
             ENDDO
          ENDDO
          !
          ! 
          ! 2.2 Define the variables in the netCDF file
          !
          iret = NF90_REDEF(fid)
          IF (iret /= NF90_NOERR) THEN
             CALL ipslerr_p (3,'routing_diagncfile', &
                  &          'Could not restart definitions in the file : ', &
                  &          TRIM(river_file_name),'(Solution ?)')
          ENDIF
          !
          ! Create a name more suitable for a variable in a netCDF file
          !
          nc_name =  TRIM(sorted_names(icc))
          ! Take out all character which could cause problems
          lcc=LEN_TRIM(nc_name)
          DO ij=1,lcc
             IF ( nc_name(ij:ij) == " " ) nc_name(ij:ij) = "_"
             IF ( nc_name(ij:ij) == "(" ) nc_name(ij:ij) = "_"
             IF ( nc_name(ij:ij) == ")" ) nc_name(ij:ij) = "_"
          ENDDO
          ! reduce redundant "__"
          DO ij=1,lcc
             IF ( nc_name(ij:ij+1) == "__" ) nc_name(ij+1:)=nc_name(ij+2:lcc)
          ENDDO
          lcc=LEN_TRIM(nc_name)
          IF ( nc_name(lcc:lcc) == "_" ) nc_name(lcc:lcc) = " "
          !
          !
          ! 2.3 Fraction variable
          !
          IF (check) WRITE(numout,*) "Define Fraction variable and add attributes"
          !
          var_name =  TRIM(nc_name)//"_frac"
          !
          iret = NF90_DEF_VAR(fid, TRIM(var_name), kind_r_diag, dims, varid)
          IF (iret /= NF90_NOERR) THEN
             CALL ipslerr_p (3,'routing_diagncfile', 'Variable '//TRIM(var_name)//' can not be defined for the file : ', &
                  &         TRIM(river_file_name),'(Solution ?)')
          ENDIF
          !
          ierr_tot = 0
          ! Units
          iret = NF90_PUT_ATT(fid, varid, 'units', "-")
          IF (iret /= NF90_NOERR) THEN
             WRITE(numout,*) 'Units',  iret
             WRITE(numout,*) TRIM(NF90_STRERROR(iret))
             ierr_tot = ierr_tot + 1
          ENDIF
          ! Long name
          long_name = "Fraction of basin "//TRIM(sorted_names(icc))//" per grid box"
          iret = NF90_PUT_ATT(fid, varid, 'long_name', long_name)
          IF (iret /= NF90_NOERR) THEN
             WRITE(numout,*) 'Long_Name', long_name, iret
             WRITE(numout,*) TRIM(NF90_STRERROR(iret))
             ierr_tot = ierr_tot + 1
          ENDIF
          ! Missing value
          iret = NF90_PUT_ATT(fid, varid, 'missing_value', undef_sechiba)
          IF (iret /= NF90_NOERR) THEN
             WRITE(numout,*) 'Missing value', undef_sechiba, iret
             WRITE(numout,*) TRIM(NF90_STRERROR(iret))
             ierr_tot = ierr_tot + 1
          ENDIF
          !
          ib=sortedrivs(icc)
          IF ( check ) WRITE(numout,*) "Doing basin ", icc," corrsdponding to index = ", ib, "num_largest : ", num_largest
          !
          ! Nb of grid points in basin
          att_str='Nb_of_grid_points_in_basin'
          iret = NF90_PUT_ATT(fid, varid, att_str, nb_pts(ib))
          IF (iret /= NF90_NOERR) THEN
             WRITE(numout,*) 'Nb of grid points in basin', nb_pts(ib), iret
             WRITE(numout,*) TRIM(NF90_STRERROR(iret))
             ierr_tot = ierr_tot + 1
          ENDIF
          !
          ! Longitude of outflow point 
          att_str='Longitude_of_outflow_point'
          iret = NF90_PUT_ATT(fid, varid, att_str, lalo(outpt(ib,1),2))
          IF (iret /= NF90_NOERR) THEN
             WRITE(numout,*) 'Longitude of outflow point', lalo(outpt(ib,1),2), iret
             WRITE(numout,*) TRIM(NF90_STRERROR(iret))
             ierr_tot = ierr_tot + 1
          ENDIF
          !
          ! Latitide of outflow point
          att_str='Latitude_of_outflow_point'
          iret = NF90_PUT_ATT(fid, varid, att_str, lalo(outpt(ib,1),1))
          IF (iret /= NF90_NOERR) THEN
             WRITE(numout,*) 'Latitude of outflow point',  lalo(outpt(ib,1),1), iret
             WRITE(numout,*) TRIM(NF90_STRERROR(iret))
             ierr_tot = ierr_tot + 1
          ENDIF
          !
          ! Number of streams
          att_str= 'Number_of_streams'
          iret = NF90_PUT_ATT(fid, varid, att_str, streams_nb(ib))
          IF (iret /= NF90_NOERR) THEN
             WRITE(numout,*) 'Number of streams', streams_nb(ib), iret
             WRITE(numout,*) TRIM(NF90_STRERROR(iret))
             ierr_tot = ierr_tot + 1
          ENDIF
          !
          ! Total number of hops to go to the oceans
          att_str='Total_number_of_hops_to_ocean'
          iret = NF90_PUT_ATT(fid, varid, att_str, streams_avehops(ib)*streams_nb(ib))
          IF (iret /= NF90_NOERR) THEN
             WRITE(numout,*) 'Total number of hops to go to the oceans ', streams_avehops(ib)*streams_nb(ib), iret
             ierr_tot = ierr_tot + 1
          ENDIF
          !
          ! Minimum number of hops to go to the ocean for any stream
          att_str='Minimum_number_of_hops_to_ocean_for_any_stream'
          iret = NF90_PUT_ATT(fid, varid, att_str, streams_minhops(ib))
          IF (iret /= NF90_NOERR) THEN
             WRITE(numout,*) 'Minimum number of hops to go tp the ocean for any stream', streams_minhops(ib), iret
             ierr_tot = ierr_tot + 1
          ENDIF
          !
          ! Average number of hops to go to the ocean for any stream 
          att_str='Average_number_of_hops_to_ocean_for_any_stream'
          iret = NF90_PUT_ATT(fid, varid, att_str, streams_avehops(ib))
          IF (iret /= NF90_NOERR) THEN
             WRITE(numout,*) 'Average number of hops to go tp the ocean for any stream', streams_avehops(ib), iret
             ierr_tot = ierr_tot + 1
          ENDIF
          !
          ! Maximum number of hops to go to the ocean for any stream 
          att_str='Maximum_number_of_hops_to_ocean_for_any_stream'
          iret = NF90_PUT_ATT(fid, varid, att_str, streams_maxhops(ib))
          IF (iret /= NF90_NOERR) THEN
             WRITE(numout,*) 'Maximum number of hops to go tp the ocean for any stream', streams_maxhops(ib), iret
             ierr_tot = ierr_tot + 1
          ENDIF
          !
          ! Average residence time in the basin
          att_str='Average_residence_time_in_basin'
          iret = NF90_PUT_ATT(fid, varid, att_str, streams_resid(ib))
          IF (iret /= NF90_NOERR) THEN
             WRITE(numout,*) 'Average residence time in the basin', streams_resid(ib), iret
             ierr_tot = ierr_tot + 1
          ENDIF
          !
          IF (ierr_tot > 0 ) THEN
             CALL ipslerr_p (3,'routing_diagncfile', 'Could not add some attributes to variable '//var_name//' for the file :', &
                  &          TRIM(river_file_name),'(Solution ?)')
          ENDIF
          !
          ! 2.4 Upstream area variable variable
          !
          IF (check) WRITE(numout,*) "Define Upstream variable and add attributes"
          !
          ! Create a name more suitable for a variable in a netCDF file
          !
          var_name =  TRIM(nc_name)//"_upstream"
          DO ij=1,LEN_TRIM(var_name)
             IF ( var_name(ij:ij) == " " ) var_name(ij:ij) = "_"
          ENDDO
          !
          iret = NF90_DEF_VAR(fid, TRIM(var_name), kind_r_diag, dims, varid2)
          IF (iret /= NF90_NOERR) THEN
             CALL ipslerr_p (3,'routing_diagncfile', 'Variable '//TRIM(var_name)//' can not be defined for the file : ', &
                  &         TRIM(river_file_name),'(Solution ?)')
          ENDIF
          !
          ierr_tot = 0
          ! Units
          iret = NF90_PUT_ATT(fid, varid2, 'units', "m^2")
          IF (iret /= NF90_NOERR) ierr_tot = ierr_tot + 1
          ! Long name
          long_name = "Upstream area of basin "//TRIM(sorted_names(icc))//" in the grid box"
          iret = NF90_PUT_ATT(fid, varid2, 'long_name', long_name)
          IF (iret /= NF90_NOERR) ierr_tot = ierr_tot + 1
          ! Missing value
          iret = NF90_PUT_ATT(fid, varid2, 'missing_value', undef_sechiba)
          IF (iret /= NF90_NOERR) ierr_tot = ierr_tot + 1
          !
          IF (ierr_tot > 0 ) THEN
             CALL ipslerr_p (3,'routing_diagncfile', 'Could not add some attributes to variable '//var_name//' for the file :', &
                  &          TRIM(river_file_name),'(Solution ?)')
          ENDIF
          !
          ! 2.5 Pfafstetter codes for basins
          !
          IF (check) WRITE(numout,*) "Define Pfafstetter codes variable and add attributes"
          !
          var_name =  TRIM(nc_name)//"_coding"
          DO ij=1,LEN_TRIM(var_name)
             IF ( var_name(ij:ij) == " " ) var_name(ij:ij) = "_"
          ENDDO
          !
          iret = NF90_DEF_VAR(fid, TRIM(var_name), kind_i_diag, dims, varid3)
          IF (iret /= NF90_NOERR) THEN
             CALL ipslerr_p (3,'routing_diagncfile', 'Variable '//TRIM(var_name)//' can not be defined for the file : ', &
                  &         TRIM(river_file_name),'(Solution ?)')
          ENDIF
          !
          ierr_tot = 0
          ! Units
          iret = NF90_PUT_ATT(fid, varid3, 'units', "-")
          IF (iret /= NF90_NOERR) ierr_tot = ierr_tot + 1
          ! Long name
          long_name = "Pfafstetter codes of grid boxes in basin "//TRIM(sorted_names(icc))
          iret = NF90_PUT_ATT(fid, varid3, 'long_name', long_name)
          IF (iret /= NF90_NOERR) ierr_tot = ierr_tot + 1
          ! Missing value
          iret = NF90_PUT_ATT(fid, varid3, 'missing_value', undef_int)
          IF (iret /= NF90_NOERR) ierr_tot = ierr_tot + 1
          !
          IF (ierr_tot > 0 ) THEN
             CALL ipslerr_p (3,'routing_diagncfile', 'Could not add some attributes to variable '//var_name//' for the file :', &
                  &          TRIM(river_file_name),'(Solution ?)')
          ENDIF
          !
          ! 2.6 ENDDEF of netCDF file
          !
          IF (check) WRITE(numout,*) "END define"
          !
          iret = NF90_ENDDEF(fid)
          IF (iret /= NF90_NOERR) THEN
             CALL ipslerr_p (3,'routing_diagncfile', &
                  &          'Could not end definitions in the file : ', &
                  &          TRIM(river_file_name),'(Solution ?)')
          ENDIF
          !
          ! 2.7 Write the data to the file
          !
          IF (check) WRITE(numout,*) "Put basinfrac"
          iret = NF90_PUT_VAR(fid, varid, basinfrac)
          IF (iret /= NF90_NOERR) THEN
             CALL ipslerr_p (3,'routing_diagncfile', 'Could not put variable basinfrac in the file : ', &
                  &          TRIM(river_file_name),'(Solution ?)')
          ENDIF

          IF (check) WRITE(numout,*) "Put basinuparea"
          iret = NF90_PUT_VAR(fid, varid2, basinuparea)
          IF (iret /= NF90_NOERR) THEN
             CALL ipslerr_p (3,'routing_diagncfile', 'Could not put variable basinuparea in the file : ', &
                  &          TRIM(river_file_name),'(Solution ?)')
          ENDIF

          IF (check) WRITE(numout,*) "Put basincode"
          iret = NF90_PUT_VAR(fid, varid3, basincode)
          IF (iret /= NF90_NOERR) THEN
             CALL ipslerr_p (3,'routing_diagfile', 'Could not put variable basincode in the file : ', &
                  &          TRIM(river_file_name),'(Solution ?)')
          ENDIF
          !
       ENDIF
       !
    ENDDO
    !
    IF (check) WRITE(numout,*) "Close file"
    !
    ! Close netCDF file and do some memory management.
    !
    iret = NF90_CLOSE(fid)
    IF (iret /= NF90_NOERR) THEN
       CALL ipslerr_p (3,'routing_diagncfile', &
            &          'Could not end definitions in the file : ', &
            &          TRIM(river_file_name),'(Solution ?)')
    ENDIF
    !
    !
  END SUBROUTINE routing_diagncfile
  !
!! ================================================================================================================================
!! SUBROUTINE   : routing_basins_p
!!
!>\BRIEF        This parallelized subroutine computes the routing map if needed. 
!!
!! DESCRIPTION (definitions, functional, design, flags) : None
!!
!! RECENT CHANGE(S): None
!!
!! MAIN OUTPUT VARIABLE(S):
!!
!! REFERENCES   : None
!!
!! FLOWCHART    : None
!! \n
!_ ================================================================================================================================

  SUBROUTINE routing_basins_p(nbpt, lalo, neighbours, resolution, contfrac)
    !
    IMPLICIT NONE
    !
!! INPUT VARIABLES
    INTEGER(i_std), INTENT(in) :: nbpt               !! Domain size (unitless)
    REAL(r_std), INTENT(in)    :: lalo(nbpt,2)       !! Vector of latitude and longitudes (beware of the order !)
    INTEGER(i_std), INTENT(in) :: neighbours(nbpt,NbNeighb) !! Vector of neighbours for each grid point (1=North and then clockwise) (unitless)
    REAL(r_std), INTENT(in)    :: resolution(nbpt,2) !! The size of each grid box in X and Y (m)
    REAL(r_std), INTENT(in)    :: contfrac(nbpt)     !! Fraction of land in each grid box (unitless;0-1)

!_ ================================================================================================================================

!    INTEGER(i_std)    :: neighbours_tmp(nbpt,8)
!    INTEGER(i_std) :: i,j
    
!    DO i=1,nbp_loc
!      DO j=1,NbNeighb
!       IF (neighbours(i,j)==-1) THEN
!         neighbours_tmp(i,j)=neighbours(i,j)
!       ELSE
!         neighbours_tmp(i,j)=neighbours(i,j)+nbp_para_begin(mpi_rank)-1
!       ENDIF  
!      ENDDO
!    ENDDO

    routing_area => routing_area_glo  
    topo_resid => topo_resid_glo
    route_togrid => route_togrid_glo
    route_tobasin => route_tobasin_glo
    route_nbintobas => route_nbintobas_glo
    global_basinid => global_basinid_glo
 
    IF (is_root_prc) CALL routing_basins(nbp_glo,lalo_g, neighbours_g, resolution_g, contfrac_g)

    routing_area => routing_area_loc  
    topo_resid => topo_resid_loc
    route_togrid => route_togrid_loc
    route_tobasin => route_tobasin_loc
    route_nbintobas => route_nbintobas_loc
    global_basinid => global_basinid_loc

    CALL scatter(routing_area_glo,routing_area_loc)
    CALL scatter(topo_resid_glo,topo_resid_loc)
    CALL scatter(route_togrid_glo,route_togrid_loc)
    CALL scatter(route_tobasin_glo,route_tobasin_loc)
    CALL scatter(route_nbintobas_glo,route_nbintobas_loc)
    CALL scatter(global_basinid_glo,global_basinid_loc)
    
  END SUBROUTINE routing_basins_p
  ! 
 
!! ================================================================================================================================
!! SUBROUTINE   : routing_basins
!!
!>\BRIEF        This non-parallelized subroutine reads in the map of basins and flow direction to construct
!!              the catchments of each grid box. 
!!
!! DESCRIPTION (definitions, functional, design, flags) :
!! The work is done in a number of steps which are performed locally on the 
!! GCM grid:
!!  1) First we find the grid-points of the high resolution routing grid which are
!!     within the coarser grid of the GCM.
!!  2) When we have these grid points we decompose them into basins in the routine
!!     routing_findbasins. A number of simplifications are done if needed.
!!  3) In the routine routing_globalize we put the basin information of this grid
!!     into the global fields.
!! Then we work on the global grid to perform the following tasks :
!!  1) We link up the basins of the various grid points and check the global consistency.
!!  2) The area of each outflow point is computed.
!!  3) The final step is to reduce the number of basins in order to fit into the truncation.\n
!!
!! RECENT CHANGE(S): None
!!
!! MAIN OUTPUT VARIABLE(S): None, as the routine puts information into the global variables of the module.
!!
!! REFERENCES   : None
!!
!! FLOWCHART    : None
!! \n
!_ ================================================================================================================================

SUBROUTINE routing_basins(nbpt, lalo, neighbours, resolution, contfrac)
    !
    IMPLICIT NONE
    !
!! INPUT VARIABLES
    INTEGER(i_std), INTENT(in)                    :: nbpt                  !! Domain size (unitless)
    REAL(r_std), INTENT(in)                       :: lalo(nbpt,2)          !! Vector of latitude and longitudes (beware of the order !)
    INTEGER(i_std), INTENT(in)                    :: neighbours(nbpt,NbNeighb)!! Vector of neighbours for each grid point 
                                                                           !! (1=North and then cloxkwise)
    REAL(r_std), INTENT(in)                       :: resolution(nbpt,2)    !! The size of each grid box in X and Y (m)
    REAL(r_std), INTENT(in)                       :: contfrac(nbpt)        !! Fraction of land in each grid box (unitless;0-1)
    !
!! LOCAL VARIABLES
    CHARACTER(LEN=80)                             :: filename              !! Name of the netcdf file (unitless)
    INTEGER(i_std)                                :: iml, jml, lml, tml, fid, ib, ip, jp, fopt !! Indices (unitless)
    REAL(r_std)                                   :: lev(1), date, dt, coslat
    INTEGER(i_std)                                :: itau(1)               !!
    REAL(r_std), ALLOCATABLE, DIMENSION(:,:)      :: trip                  !! The trip field (unitless)
    REAL(r_std), ALLOCATABLE, DIMENSION(:,:)      :: basins                !! The basin field (unitless)
    REAL(r_std), ALLOCATABLE, DIMENSION(:,:)      :: topoindex             !! Topographic index of the residence time (m)
    REAL(r_std), ALLOCATABLE, DIMENSION(:,:)      :: hierarchy             !!
    REAL(r_std), ALLOCATABLE, DIMENSION(:,:)      :: lat_rel               !!
    REAL(r_std), ALLOCATABLE, DIMENSION(:,:)      :: lon_rel               !!
    !
    INTEGER(i_std)                                :: nbi, nbj              !! Number of point in x and y within the grid (unitless)
    REAL(r_std)                                   :: min_topoind           !! The current minimum of topographic index (m)
    REAL(r_std)                                   :: max_basins            !!
    REAL(r_std)                                   :: invented_basins       !!
    !
    REAL(r_std), ALLOCATABLE, DIMENSION(:,:)      :: area_bx               !! Area of each small box in the grid box (m^2)
    REAL(r_std), ALLOCATABLE, DIMENSION(:,:)      :: hierarchy_bx          !! Level in the basin of the point
    REAL(r_std), ALLOCATABLE, DIMENSION(:,:)      :: lon_bx                !!
    REAL(r_std), ALLOCATABLE, DIMENSION(:,:)      :: lat_bx                !!
    REAL(r_std), ALLOCATABLE, DIMENSION(:,:)      :: topoind_bx            !! Topographic index of the residence time for each of the smaller boxes (m)
    INTEGER(i_std), ALLOCATABLE, DIMENSION(:,:)   :: trip_bx               !! The trip field for each of the smaller boxes (unitless)
    INTEGER(i_std), ALLOCATABLE, DIMENSION(:,:)   :: basin_bx              !!
    INTEGER(i_std), ALLOCATABLE, DIMENSION(:)     :: coast_pts             !! The coastal flow points (unitless)
    !
    INTEGER(i_std), ALLOCATABLE, DIMENSION(:)     :: basin_count           !!
    INTEGER(i_std), ALLOCATABLE, DIMENSION(:,:)   :: basin_id              !!
    REAL(r_std),  ALLOCATABLE, DIMENSION(:,:)     :: basin_area            !!
    REAL(r_std),  ALLOCATABLE, DIMENSION(:,:)     :: basin_hierarchy       !!
    REAL(r_std),  ALLOCATABLE, DIMENSION(:,:)     :: basin_topoind         !! Topographic index of the residence time for a basin (m)
    REAL(r_std),  ALLOCATABLE, DIMENSION(:,:)     :: fetch_basin           !!
    INTEGER(i_std), ALLOCATABLE, DIMENSION(:,:)   :: basin_flowdir         !! Water flow directions in the basin (unitless)
    INTEGER(i_std), ALLOCATABLE, DIMENSION(:,:)   :: outflow_grid          !! Type of outflow on the grid box (unitless)
    INTEGER(i_std), ALLOCATABLE, DIMENSION(:,:)   :: outflow_basin         !!
    INTEGER(i_std), ALLOCATABLE, DIMENSION(:,:)   :: inflow_number         !!
    INTEGER(i_std), ALLOCATABLE, DIMENSION(:,:,:) :: inflow_basin          !!
    INTEGER(i_std), ALLOCATABLE, DIMENSION(:,:,:) :: inflow_grid           !!
    INTEGER(i_std), ALLOCATABLE, DIMENSION(:)     :: nbcoastal             !!
    INTEGER(i_std), ALLOCATABLE, DIMENSION(:,:)   :: coastal_basin         !!
    !
    ! Interpolation help variables
    !
    INTEGER(i_std)                                :: nix, njx              !!
    CHARACTER(LEN=30)                             :: callsign              !!
    REAL(r_std), ALLOCATABLE, DIMENSION(:,:,:)    :: resol_lu              !! Resolution
    INTEGER(i_std), ALLOCATABLE, DIMENSION(:,:)   :: mask                  !! Mask to exclude some points (unitless)
    REAL(r_std), ALLOCATABLE, DIMENSION(:,:)      :: sub_area              !! Area on the fine grid (m^2)
    INTEGER(i_std), ALLOCATABLE, DIMENSION(:,:,:) :: sub_index             !! Indices of the points we need on the fine grid (unitless)
    INTEGER(i_std), ALLOCATABLE, DIMENSION(:)     :: sub_pts               !! Number of high resolution points on this grid (unitless)
    INTEGER                                       :: ALLOC_ERR             !!
    LOGICAL                                       :: ok_interpol = .FALSE. !! Flag for interpolation (true/false)
    !
    INTEGER(i_std)                                :: nb_basin              !! Number of sub-basins (unitless)
    INTEGER(i_std)                                :: nwbas                 !!
    INTEGER(i_std), ALLOCATABLE, DIMENSION(:)     :: basin_inbxid          !!
    INTEGER(i_std), ALLOCATABLE, DIMENSION(:)     :: basin_sz              !!
    INTEGER(i_std), ALLOCATABLE, DIMENSION(:)     :: basin_bxout           !!
    INTEGER(i_std), ALLOCATABLE, DIMENSION(:,:,:) :: basin_pts             !!
    CHARACTER(LEN=7)                              :: fmt                   !!
    LOGICAL                                       :: debug = .FALSE.       !! (true/false)
    !
    INTEGER(i_std), DIMENSION(2)                  :: diagbox = (/ 1, 2 /)  !!

!_ ================================================================================================================================
    !
    !
    IF ( .NOT. is_root_prc) THEN
       WRITE(numout,*) "is_root_prc = ", is_root_prc
       CALL ipslerr_p (3,'routing_basins', &
            &          'routing_basins is not suitable for running in parallel', &
            &          'We are here on a non root processor. ','(STOP from routing_basins)')
    ENDIF
    !
    ! Test on diagbox and nbpt
    !
    IF (debug) THEN
       IF (ANY(diagbox .GT. nbpt)) THEN 
          WRITE(numout,*) "Debug diganostics : nbpt, diagbox", nbpt, diagbox
          call ipslerr_p(3,'routing_basin', &
               &      'Problem with diagbox in debug mode.', & 
               &      'diagbox values can''t be greater than land points number.', &
               &      '(decrease diagbox wrong value)')
       ENDIF
    ENDIF
    !
    !
    !  Needs to be a configurable variable
    !
    !
    !Config Key   = ROUTING_FILE
    !Config Desc  = Name of file which contains the routing information
    !Config If    = RIVER_ROUTING
    !Config Def   = routing.nc
    !Config Help  = The file provided here should alow the routing module to
    !Config         read the high resolution grid of basins and the flow direction 
    !Config         from one mesh to the other.
    !Config Units = [FILE]
    !
    filename = 'routing.nc'
    CALL getin('ROUTING_FILE',filename)
    !
    CALL flininfo(filename,iml, jml, lml, tml, fid)
    CALL flinclo(fid)
    !
    ! soils_param.nc file is 1° soit texture file.
    !
    ALLOCATE(lat_rel(iml,jml), STAT=ALLOC_ERR)
    IF (ALLOC_ERR /= 0) CALL ipslerr_p(3,'routing_basins','Pb in allocate for lat_rel','','')

    ALLOCATE(lon_rel(iml,jml), STAT=ALLOC_ERR)
    IF (ALLOC_ERR /= 0) CALL ipslerr_p(3,'routing_basins','Pb in allocate for lon_rel','','')

    ALLOCATE (trip(iml,jml), STAT=ALLOC_ERR)
    IF (ALLOC_ERR /= 0) CALL ipslerr_p(3,'routing_basins','Pb in allocate for trip','','')

    ALLOCATE (basins(iml,jml), STAT=ALLOC_ERR)
    IF (ALLOC_ERR /= 0) CALL ipslerr_p(3,'routing_basins','Pb in allocate for basins','','')

    ALLOCATE (topoindex(iml,jml), STAT=ALLOC_ERR)
    IF (ALLOC_ERR /= 0) CALL ipslerr_p(3,'routing_basins','Pb in allocate for topoindex','','')

    ALLOCATE (hierarchy(iml,jml), STAT=ALLOC_ERR)
    IF (ALLOC_ERR /= 0) CALL ipslerr_p(3,'routing_basins','Pb in allocate for hierarchy','','')

    !
    CALL flinopen(filename, .FALSE., iml, jml, lml, lon_rel, lat_rel, lev, tml, itau, date, dt, fid)
    !!
    !! From the basin description data we will read the following variables :
    !!
    !! Trip : Provides the flow direction following the convention :
    !! trip = 1 : flow = N
    !! trip = 2 : flow = NE
    !! trip = 3 : flow = E
    !! trip = 4 : flow = SE
    !! trip = 5 : flow = S
    !! trip = 6 : flow = SW
    !! trip = 7 : flow = W
    !! trip = 8 : flow = NW
    !! trip = 97 : return flow into the ground
    !! trip = 98 : coastal flow (diffuse flow into the oceans)
    !! trip = 99 : river flow into the oceans
    !!
    !! Basins : Provides a uniqe ID for each basin. These IDs are also used to get
    !! the name of the basin from the table in routine routing_names.
    !! 
    !! Topoind :  is the topographic index for the retention time of the water in the
    !! grid box. It has been computed with the following formula : 1000 x sqrt(d^3/Dz) 
    !! where d is the distance of the river from the current grid box to the next one
    !! as indicated by the variable trip.
    !! Dz the hight difference between between the two grid boxes.
    !! All these variables are in meters.
    !! Furthermore  we have to limit the height difference to 5m in order to avoid any unpleasant
    !! surprises. If dz < 5m then dz=5.
    !!
    !
    CALL flinget(fid, 'trip', iml, jml, lml, tml, 1, 1, trip)
    !
    CALL flinget(fid, 'basins', iml, jml, lml, tml, 1, 1, basins)
    !
    CALL flinget(fid, 'topoind', iml, jml, lml, tml, 1, 1, topoindex)
    !
    CALL flinclo(fid)
    !
    min_topoind = MINVAL(topoindex, MASK=topoindex .LT. undef_sechiba-un)
    !
    DO ip=1,iml
       DO jp=1,jml
          IF ( trip(ip,jp) < 1.e10 .AND. topoindex(ip,jp) > 1.e10) THEN
             WRITE(numout,*) 'trip exists but not topoind :'
             WRITE(numout,*) 'ip, jp :', ip, jp
             WRITE(numout,*) 'trip, topoind : ', trip(ip,jp), topoindex(ip,jp)
             CALL ipslerr_p(3,'routing_basins','trip exists but not topoind','','')
          ENDIF
       ENDDO
    ENDDO

    ALLOCATE(resol_lu(iml,jml,2), STAT=ALLOC_ERR)
    IF (ALLOC_ERR /= 0) CALL ipslerr_p(3,'routing_basins','Pb in allocate for resol_lu','','')

    ALLOCATE(mask(iml,jml), STAT=ALLOC_ERR)
    IF (ALLOC_ERR /= 0) CALL ipslerr_p(3,'routing_basins','Pb in allocate for mask','','')
    !
    ! Consider all points a priori
    !
    mask(:,:) = 0
    !
    DO ip=1,iml
       DO jp=1,jml
          !
          ! Determine the land mask of the basin map read from the file ROUTING_FILE
          !
          IF ( trip(ip,jp) < 1.e10 ) THEN
             mask(ip,jp) = 1
          ENDIF
          !
          ! Resolution in longitude
          !
          coslat = MAX( COS( lat_rel(ip,jp) * pi/180. ), mincos )     
          IF ( ip .EQ. 1 ) THEN
             resol_lu(ip,jp,1) = ABS( lon_rel(ip+1,jp) - lon_rel(ip,jp) ) * pi/180. * R_Earth * coslat
          ELSEIF ( ip .EQ. iml ) THEN
             resol_lu(ip,jp,1) = ABS( lon_rel(ip,jp) - lon_rel(ip-1,jp) ) * pi/180. * R_Earth * coslat
          ELSE
             resol_lu(ip,jp,1) = ABS( lon_rel(ip+1,jp) - lon_rel(ip-1,jp) )/2. * pi/180. * R_Earth * coslat
          ENDIF
          !
          ! Resolution in latitude
          !
          IF ( jp .EQ. 1 ) THEN
             resol_lu(ip,jp,2) = ABS( lat_rel(ip,jp) - lat_rel(ip,jp+1) ) * pi/180. * R_Earth
          ELSEIF ( jp .EQ. jml ) THEN
             resol_lu(ip,jp,2) = ABS( lat_rel(ip,jp-1) - lat_rel(ip,jp) ) * pi/180. * R_Earth
          ELSE
             resol_lu(ip,jp,2) =  ABS( lat_rel(ip,jp-1) - lat_rel(ip,jp+1) )/2. * pi/180. * R_Earth
          ENDIF
          !
       ENDDO
    ENDDO
    !
    ! The maximum number of points of the source map (basin description here) which can fit into
    ! any grid point of the ORCHIDEE grid is stimated here.
    ! Some margin is taken.
    !
    callsign = "routing_basins"
    ok_interpol = .FALSE.
    !  
    nix=INT(MAXVAL(resolution_g(:,1))/MAXVAL(resol_lu(:,:,1)))+2
    njx=INT(MAXVAL(resolution_g(:,2))/MAXVAL(resol_lu(:,:,2)))+2
    nbvmax = nix*njx*2
    !
    ! We are on the root processor here as this routine is not in parallel. So no need to broadcast.
    !
    IF (printlev >=1) THEN
       WRITE(numout,*) "Projection arrays for ",callsign," : "
       WRITE(numout,*) "Routing : nbvmax = ", nbvmax
    END IF

    ALLOCATE (sub_area(nbpt,nbvmax), STAT=ALLOC_ERR)
    IF (ALLOC_ERR /= 0) CALL ipslerr_p(3,'routing_basins','Pb in allocate for sub_area','','')
    sub_area(:,:)=zero

    ALLOCATE (sub_index(nbpt,nbvmax,2), STAT=ALLOC_ERR)
    IF (ALLOC_ERR /= 0) CALL ipslerr_p(3,'routing_basins','Pb in allocate for sub_index','','')
    sub_index(:,:,:)=0

    ALLOCATE (sub_pts(nbpt), STAT=ALLOC_ERR)
    IF (ALLOC_ERR /= 0) CALL ipslerr_p(3,'routing_basins','Pb in allocate for sub_pts','','')
    sub_pts(:)=0
    !
    ! routine aggregate will for each point of the ORCHIDEE grid determine which points
    ! of the source grid (basin definitions here) fit in there and which fraction of
    ! of the ORCHIDEE grid it represents.
    !
    CALL aggregate(nbpt, lalo, neighbours, resolution, contfrac, &
         &                iml, jml, lon_rel, lat_rel, mask, callsign, &
         &                nbvmax, sub_index, sub_area, ok_interpol)
    !
    WHERE (sub_area < 0) sub_area=zero
    !
    ! Some verifications
    !
    DO ib=1,nbpt
       sub_pts(ib) = COUNT(sub_area(ib,:) > zero)
       DO fopt=1,sub_pts(ib)
          IF (sub_area(ib, fopt) == 0 ) THEN
             WRITE(numout,*) "Zero Area - Sub_area > 0 : ", ib, fopt
             WRITE(numout,*) "Zero Area - lon : ",lalo(ib,2)
             WRITE(numout,*) "Zero Area - lon_rel : ", lon_rel(sub_index(ib, fopt, 1),sub_index(ib, fopt, 2))
             WRITE(numout,*) "Zero Area - lat : ",lalo(ib,1)
             WRITE(numout,*) "Zero Area - lat_rel : ", lat_rel(sub_index(ib, fopt, 1),sub_index(ib, fopt, 2))
          ENDIF
       ENDDO
    ENDDO
    !
    ! Do some memory management.
    !
    nwbas = MAX(MAXVAL(sub_pts), NbNeighb+1)
    !
    ALLOCATE (area_bx(nbvmax,nbvmax), stat=ALLOC_ERR)
    IF (ALLOC_ERR /= 0) CALL ipslerr_p(3,'routing_basins','Pb in allocate for area_bx','','')
    ALLOCATE (hierarchy_bx(nbvmax,nbvmax), stat=ALLOC_ERR)
    IF (ALLOC_ERR /= 0) CALL ipslerr_p(3,'routing_basins','Pb in allocate for hierarchy_bx','','')
    ALLOCATE (lon_bx(nbvmax,nbvmax), stat=ALLOC_ERR)
    IF (ALLOC_ERR /= 0) CALL ipslerr_p(3,'routing_basins','Pb in allocate for lon_bx','','')
    ALLOCATE (lat_bx(nbvmax,nbvmax), stat=ALLOC_ERR)
    IF (ALLOC_ERR /= 0) CALL ipslerr_p(3,'routing_basins','Pb in allocate for lat_bx','','')
    ALLOCATE (topoind_bx(nbvmax,nbvmax), stat=ALLOC_ERR)
    IF (ALLOC_ERR /= 0) CALL ipslerr_p(3,'routing_basins','Pb in allocate for topoind_bx','','')
    ALLOCATE (trip_bx(nbvmax,nbvmax), stat=ALLOC_ERR)
    IF (ALLOC_ERR /= 0) CALL ipslerr_p(3,'routing_basins','Pb in allocate for trip_bx','','')
    ALLOCATE (basin_bx(nbvmax,nbvmax), stat=ALLOC_ERR)
    IF (ALLOC_ERR /= 0) CALL ipslerr_p(3,'routing_basins','Pb in allocate for basin_bx','','')
    ALLOCATE (coast_pts(nbvmax), stat=ALLOC_ERR)
    IF (ALLOC_ERR /= 0) CALL ipslerr_p(3,'routing_basins','Pb in allocate for coast_pts','','')
    ALLOCATE (basin_inbxid(nbvmax), stat=ALLOC_ERR)
    IF (ALLOC_ERR /= 0) CALL ipslerr_p(3,'routing_basins','Pb in allocate for basin_inbxid','','')
    ALLOCATE (basin_sz(nbvmax), stat=ALLOC_ERR)
    IF (ALLOC_ERR /= 0) CALL ipslerr_p(3,'routing_basins','Pb in allocate for basin_sz','','')
    ALLOCATE (basin_pts(nbvmax,nbvmax,2), stat=ALLOC_ERR)
    IF (ALLOC_ERR /= 0) CALL ipslerr_p(3,'routing_basins','Pb in allocate for basin_pts','','')
    ALLOCATE (basin_bxout(nbvmax), stat=ALLOC_ERR)
    IF (ALLOC_ERR /= 0) CALL ipslerr_p(3,'routing_basins','Pb in allocate for basin_bxout','','')
    ALLOCATE (basin_count(nbpt), stat=ALLOC_ERR)
    IF (ALLOC_ERR /= 0) CALL ipslerr_p(3,'routing_basins','Pb in allocate for basin_count','','')
    ALLOCATE (basin_area(nbpt,nwbas), basin_hierarchy(nbpt,nwbas), basin_topoind(nbpt,nwbas), stat=ALLOC_ERR)
    IF (ALLOC_ERR /= 0) CALL ipslerr_p(3,'routing_basins','Pb in allocate for basin_area','','')
    ALLOCATE (fetch_basin(nbpt,nwbas), stat=ALLOC_ERR)
    IF (ALLOC_ERR /= 0) CALL ipslerr_p(3,'routing_basins','Pb in allocate for fetch_basin','','')
    ALLOCATE (basin_id(nbpt,nwbas),  basin_flowdir(nbpt,nwbas), stat=ALLOC_ERR)
    IF (ALLOC_ERR /= 0) CALL ipslerr_p(3,'routing_basins','Pb in allocate for basin_id','','')
    ALLOCATE (outflow_grid(nbpt,nwbas),outflow_basin(nbpt,nwbas), stat=ALLOC_ERR)
    IF (ALLOC_ERR /= 0) CALL ipslerr_p(3,'routing_basins','Pb in allocate for outflow_grid','','')
    ALLOCATE (inflow_number(nbpt,nwbas), stat=ALLOC_ERR)
    IF (ALLOC_ERR /= 0) CALL ipslerr_p(3,'routing_basins','Pb in allocate for inflow_number','','')
    ALLOCATE (inflow_basin(nbpt,nwbas,nbvmax), inflow_grid(nbpt,nwbas,nbvmax), stat=ALLOC_ERR)
    IF (ALLOC_ERR /= 0) CALL ipslerr_p(3,'routing_basins','Pb in allocate for inflow_basin','','')
    ALLOCATE (nbcoastal(nbpt), coastal_basin(nbpt,nwbas), stat=ALLOC_ERR)
    IF (ALLOC_ERR /= 0) CALL ipslerr_p(3,'routing_basins','Pb in allocate for nbcoastal','','')
    
    !    Order all sub points in each grid_box and find the sub basins
    !
    !    before we start we set the maps to empty
    !
    basin_id(:,:) = undef_int
    basin_count(:) = 0
    hierarchy(:,:) = undef_sechiba
    max_basins = MAXVAL(basins, MASK=basins .LT. 1.e10)
    invented_basins = max_basins
    nbcoastal(:) = 0
    !
    !! Finds,in each grid box, the distance to the outflow point ... this defines the order in which
    !! the water will go through the sub-basins and grid boxes.
    !
    CALL routing_hierarchy(iml, jml, trip, topoindex, hierarchy)
    !
    !
    DO ib =1, nbpt
       !
       !
       !  extract the information for this grid box
       !
       !! Extracts from the global high resolution fields the data for the current grid box.
       !
       CALL routing_getgrid(nbpt, iml, jml, ib, sub_pts, sub_index, sub_area, max_basins, min_topoind, &
            & lon_rel, lat_rel, lalo, resolution, contfrac, trip, basins, topoindex, hierarchy, &
            & nbi, nbj, area_bx, trip_bx, basin_bx, topoind_bx, hierarchy_bx, lon_bx, lat_bx)
       !
       !! Finds the basins: returns the list of all points which are within the same basin of the grid box.
       !
       CALL routing_findbasins(nbi, nbj, trip_bx, basin_bx, hierarchy_bx, topoind_bx,&
            & nb_basin, basin_inbxid, basin_sz, basin_bxout, basin_pts, coast_pts)
       !
       !  Deal with the case where nb_basin=0 for this grid box. In this case all goes into coastal flow.
       !
       IF ( debug .AND. (COUNT(diagbox .EQ. ib) .GT. 0) ) THEN
          WRITE(numout,*) '===================== IB = :', ib
          WRITE(numout,*) "sub_pts(ib) :", sub_pts(ib), "sub_area(ib,:) :",sub_area(ib,1:2)
          WRITE(numout,*) 'LON LAT of GCM :', lalo(ib,2), lalo(ib,1)
          WRITE(numout,*) 'Neighbor options :',  neighbours(ib,1:NbNeighb)
          WRITE(numout,*) 'Resolution :', resolution(ib,1:2)
          WRITE(fmt,"('(',I3,'I6)')") nbi
          WRITE(numout,*) '-------------> trip ', trip_bx(1,1)
          DO jp=1,nbj
             WRITE(numout,fmt) trip_bx(1:nbi,jp)
          ENDDO
          WRITE(numout,*) '-------------> basin ',basin_bx(1,1)
          DO jp=1,nbj
             WRITE(numout,fmt) basin_bx(1:nbi,jp)
          ENDDO
          WRITE(numout,*) '-------------> hierarchy ',hierarchy_bx(1,1)
          DO jp=1,nbj
             WRITE(numout,fmt) INT(hierarchy_bx(1:nbi,jp)/1000.)
          ENDDO
          WRITE(numout,*) '-------------> topoindex ',topoind_bx(1,1)
          DO jp=1,nbj
             WRITE(numout,fmt) INT(topoind_bx(1:nbi,jp)/1000.)
          ENDDO
          !
          WRITE(numout,*) '------------> The basins we retain'
          DO jp=1,nb_basin
             WRITE(numout,*) 'index, size, bxout, coast :', basin_inbxid(jp), basin_sz(jp),&
                  & basin_bxout(jp), coast_pts(jp)
          ENDDO
          !
       ENDIF
       !
       !! Puts the basins found for the current grid box in the context of the global map.
       !
       CALL routing_globalize(nbpt, ib, neighbours, area_bx, trip_bx, hierarchy_bx, topoind_bx, min_topoind,&
            & nb_basin, basin_inbxid, basin_sz, basin_pts, basin_bxout, coast_pts, nwbas, basin_count,&
            & basin_area, basin_hierarchy, basin_topoind, basin_id, basin_flowdir, outflow_grid,&
            & nbcoastal, coastal_basin) 
       !
       !
       IF ( debug .AND. (COUNT(diagbox .EQ. ib) .GT. 0) ) THEN
          WRITE(numout,*) 'GLOBAL information after routing_globalize for grid ', ib
          DO jp=1,basin_count(ib)
             WRITE(numout,*) 'Basin ID : ', basin_id(ib, jp)
             WRITE(numout,*) 'Basin flowdir :', basin_flowdir(ib, jp)
             WRITE(numout,*) 'Basin hierarchy :', basin_hierarchy(ib, jp)
             WRITE(numout,*) 'Basin topoindex :', basin_topoind(ib, jp)
             WRITE(numout,*) 'Basin outflow grid :', outflow_grid(ib,jp)
          ENDDO
       ENDIF
       !
    ENDDO
    !
    !! Makes the connections between the bains and ensures global coherence.
    !
    CALL routing_linkup(nbpt, contfrac, neighbours, nwbas, basin_count, basin_area, basin_id, basin_flowdir, &
         & basin_hierarchy, outflow_grid, outflow_basin, inflow_number, inflow_grid, inflow_basin, &
         & nbcoastal, coastal_basin, invented_basins)
    ! 
    !
    IF (printlev>=1) WRITE(numout,*) 'The maximum number of basins in any grid :', MAXVAL(basin_count)
    !
    IF ( debug ) THEN
       DO ib=1,SIZE(diagbox)
          IF ( diagbox(ib) .GT. 0 ) THEN
             WRITE(numout,*) 'After routing_linkup information for grid ', diagbox(ib)
             DO jp=1,basin_count(diagbox(ib))
                WRITE(numout,*) 'Basin ID : ', basin_id(diagbox(ib), jp)
                WRITE(numout,*) 'Basin outflow_grid :', outflow_grid(diagbox(ib), jp)
                WRITE(numout,*) 'Basin outflow_basin:', outflow_basin(diagbox(ib), jp)
                WRITE(numout,*) 'Basin hierarchy :', basin_hierarchy(diagbox(ib), jp)
             ENDDO
          ENDIF
       ENDDO
    ENDIF
    !
    !! Computes the fetch of each basin, upstream area in known.
    !
    CALL routing_fetch(nbpt, resolution, contfrac, nwbas, basin_count, basin_area, basin_id, outflow_grid, &
         & outflow_basin, fetch_basin)
    !
    !
    IF (printlev >=3) WRITE(numout,*) "Start reducing the number of basins per grid to meet the required truncation."
    !
    !! Reduces the number of basins per grid to the value chosen by the user.
    !
    CALL routing_truncate(nbpt, resolution, contfrac, nwbas, basin_count, basin_area, basin_topoind,&
         & fetch_basin, basin_id, basin_flowdir, outflow_grid, outflow_basin, inflow_number,&
         & inflow_grid, inflow_basin)
    !
    DEALLOCATE (lat_rel)
    DEALLOCATE (lon_rel)
    !
    DEALLOCATE (trip)
    DEALLOCATE (basins)
    DEALLOCATE (topoindex)
    DEALLOCATE (hierarchy)
    !
    DEALLOCATE (sub_area)
    DEALLOCATE (sub_index)
    DEALLOCATE (sub_pts)
    !
    DEALLOCATE (mask)
    DEALLOCATE (resol_lu)
    !
    DEALLOCATE (basin_count)
    DEALLOCATE (basin_area, basin_hierarchy, basin_topoind, fetch_basin)
    DEALLOCATE (basin_id,  basin_flowdir)
    DEALLOCATE (outflow_grid,outflow_basin)
    DEALLOCATE (inflow_number)
    DEALLOCATE (inflow_basin, inflow_grid)
    DEALLOCATE (nbcoastal, coastal_basin)

  END SUBROUTINE routing_basins


!! ================================================================================================================================
!! SUBROUTINE   : routing_getgrid
!!
!>\BRIEF         This subroutine extracts from the global high resolution fields
!!               the data for the current grid box we are dealing with.
!!
!! DESCRIPTION (definitions, functional, design, flags) :
!! Convention for trip on the input :
!! The trip field follows the following convention for the flow of the water :
!! trip = 1 : flow = N
!! trip = 2 : flow = NE
!! trip = 3 : flow = E
!! trip = 4 : flow = SE
!! trip = 5 : flow = S
!! trip = 6 : flow = SW
!! trip = 7 : flow = W
!! trip = 8 : flow = NW
!! trip = 97 : return flow into the ground
!! trip = 98 : coastal flow (diffuse flow into the oceans) These values are created here
!! trip = 99 : river flow into the oceans
!!
!! On output, the grid boxes of the basin map which flow out of the GCM grid are identified
!! by numbers larger than 100 :
!! trip = 101 : flow = N out of the coarse grid
!! trip = 102 : flow = NE out of the coarse grid
!! trip = 103 : flow = E out of the coarse grid
!! trip = 104 : flow = SE out of the coarse grid
!! trip = 105 : flow = S out of the coarse grid
!! trip = 106 : flow = SW out of the coarse grid
!! trip = 107 : flow = W out of the coarse grid
!! trip = 108 : flow = NW out of the coarse grid
!! Inside the grid the convention remains the same as above (ie between 1 and 99).:\n
!!
!! RECENT CHANGE(S): None
!!
!! MAIN OUTPUT VARIABLE(S):
!!
!! REFERENCES   : None
!!
!! FLOWCHART    : None
!! \n
!_ ================================================================================================================================

  SUBROUTINE routing_getgrid(nbpt, iml, jml, ib, sub_pts, sub_index, sub_area, max_basins, min_topoind, &
       & lon_rel, lat_rel, lalo, resolution, contfrac, trip, basins, topoindex, hierarchy, &
       & nbi, nbj, area_bx, trip_bx, basin_bx, topoind_bx, hierarchy_bx, lon_bx, lat_bx)
    !
    IMPLICIT NONE
    !
!!  INPUT VARIABLES
    INTEGER(i_std), INTENT(in)  :: nbpt                        !! Domain size (unitless)
    INTEGER(i_std), INTENT(in)  :: iml                         !! X resolution of the high resolution grid
    INTEGER(i_std), INTENT(in)  :: jml                         !! Y resolution of the high resolution grid
    INTEGER(i_std), INTENT(in)  :: ib                          !! Current basin (unitless)
    INTEGER(i_std), INTENT(in)  :: sub_pts(nbpt)               !! Number of high resolution points on this grid (unitless)
    INTEGER(i_std), INTENT(in)  :: sub_index(nbpt,nbvmax,2)    !! Indices of the points we need on the fine grid (unitless)
    REAL(r_std), INTENT(inout)  :: max_basins                  !! The current maximum of basins
    REAL(r_std), INTENT(in)     :: min_topoind                 !! The current minimum of topographic index (m)
    REAL(r_std), INTENT(in)     :: sub_area(nbpt,nbvmax)       !! Area on the fine grid (m^2)
    REAL(r_std), INTENT(in)     :: lon_rel(iml,jml)            !!
    REAL(r_std), INTENT(in)     :: lat_rel(iml,jml)            !! coordinates of the fine grid
    REAL(r_std), INTENT(in)     :: lalo(nbpt,2)                !! Vector of latitude and longitudes (beware of the order !)
    REAL(r_std), INTENT(in)     :: resolution(nbpt,2)          !! The size of each grid box in X and Y (m)
    REAL(r_std), INTENT(in)     :: contfrac(nbpt)              !! Fraction of land in each grid box (unitless;0-1)
    REAL(r_std), INTENT(inout)  :: trip(iml,jml)               !! The trip field (unitless)
    REAL(r_std), INTENT(inout)  :: basins(iml,jml)             !! data on the fine grid
    REAL(r_std), INTENT(inout)  :: topoindex(iml,jml)          !! Topographic index of the residence time (m)
    REAL(r_std), INTENT(inout)  :: hierarchy(iml, jml)         !! data on the fine grid
    !
!!  OUTPUT VARIABLES
    INTEGER(i_std), INTENT(out) :: nbi, nbj                    !! Number of point in x and y within the grid (unitless)
    REAL(r_std), INTENT(out)    :: area_bx(nbvmax,nbvmax)      !! Area of each small box in the grid box (m^2)
    REAL(r_std), INTENT(out)    :: hierarchy_bx(nbvmax,nbvmax) !! Level in the basin of the point
    REAL(r_std), INTENT(out)    :: lon_bx(nbvmax,nbvmax)       !!
    REAL(r_std), INTENT(out)    :: lat_bx(nbvmax,nbvmax)       !!
    REAL(r_std), INTENT(out)    :: topoind_bx(nbvmax,nbvmax)   !! Topographic index of the residence time for each of the smaller boxes (m)
    INTEGER(i_std), INTENT(out) :: trip_bx(nbvmax,nbvmax)      !! The trip field for each of the smaller boxes (unitless)
    INTEGER(i_std), INTENT(out) :: basin_bx(nbvmax,nbvmax)     !!
    !
!! LOCAL VARIABLES
    INTEGER(i_std)              :: ip, jp, ll(1), iloc, jloc   !! Indices (unitless)
    REAL(r_std)                 :: lonstr(nbvmax*nbvmax)       !!
    REAL(r_std)                 :: latstr(nbvmax*nbvmax)       !!

!_ ================================================================================================================================

    !
    ! Set everything to undef to locate easily empty points
    !
    trip_bx(:,:) = undef_int
    basin_bx(:,:) = undef_int
    topoind_bx(:,:) = undef_sechiba
    area_bx(:,:) = undef_sechiba
    hierarchy_bx(:,:) = undef_sechiba
    !
    IF ( sub_pts(ib) > 0 ) THEN
       !
       DO ip=1,sub_pts(ib)
          lonstr(ip) = lon_rel(sub_index(ib, ip, 1), sub_index(ib, ip, 2))
          latstr(ip) = lat_rel(sub_index(ib, ip, 1), sub_index(ib, ip, 2))
       ENDDO
       !
       !  Get the size of the area and order the coordinates to go from North to South and West to East
       !
       CALL routing_sortcoord(sub_pts(ib), lonstr, 'WE', nbi)
       CALL routing_sortcoord(sub_pts(ib), latstr, 'NS', nbj)
       !
       ! Transfer the data in such a way that (1,1) is the North Western corner and
       ! (nbi, nbj) the South Eastern.
       !
       DO ip=1,sub_pts(ib)
          ll = MINLOC(ABS(lonstr(1:nbi) - lon_rel(sub_index(ib, ip, 1), sub_index(ib, ip, 2))))
          iloc = ll(1)
          ll = MINLOC(ABS(latstr(1:nbj) - lat_rel(sub_index(ib, ip, 1), sub_index(ib, ip, 2))))
          jloc = ll(1)
          trip_bx(iloc, jloc) = NINT(trip(sub_index(ib, ip, 1), sub_index(ib, ip, 2)))
          basin_bx(iloc, jloc) = NINT(basins(sub_index(ib, ip, 1), sub_index(ib, ip, 2)))
          area_bx(iloc, jloc) = sub_area(ib, ip)
          topoind_bx(iloc, jloc) = topoindex(sub_index(ib, ip, 1), sub_index(ib, ip, 2))
          hierarchy_bx(iloc, jloc) = hierarchy(sub_index(ib, ip, 1), sub_index(ib, ip, 2))
          lon_bx(iloc, jloc) = lon_rel(sub_index(ib, ip, 1), sub_index(ib, ip, 2))
          lat_bx(iloc, jloc) = lat_rel(sub_index(ib, ip, 1), sub_index(ib, ip, 2))
       ENDDO
    ELSE
       !
       ! This is the case where the model invented a continental point
       !
       nbi = 1
       nbj = 1
       iloc = 1
       jloc = 1
       trip_bx(iloc, jloc) = 98
       basin_bx(iloc, jloc) = NINT(max_basins + 1)
       max_basins = max_basins + 1
       area_bx(iloc, jloc) = resolution(ib,1)*resolution(ib,2)*contfrac(ib)
       topoind_bx(iloc, jloc) = min_topoind
       hierarchy_bx(iloc, jloc) =  min_topoind
       lon_bx(iloc, jloc) = lalo(ib,2)
       lat_bx(iloc, jloc) = lalo(ib,1)
       !
    ENDIF
    !
    ! Tag in trip all the outflow conditions. The table is thus :
    ! trip = 100+n : Outflow into another grid box
    ! trip = 99    : River outflow into the ocean
    ! trip = 98    : This will be coastal flow (not organized as a basin)
    ! trip = 97    : return flow into the soil (local)
    !
    DO jp=1,nbj
       IF ( trip_bx(1,jp) .EQ. 8 .OR. trip_bx(1,jp) .EQ. 7 .OR. trip_bx(1,jp) .EQ. 6) THEN
          trip_bx(1,jp) = trip_bx(1,jp) + 100
       ENDIF
       IF ( trip_bx(nbi,jp) .EQ. 2 .OR. trip_bx(nbi,jp) .EQ. 3 .OR. trip_bx(nbi,jp) .EQ. 4) THEN
          trip_bx(nbi,jp) = trip_bx(nbi,jp) + 100
       ENDIF
    ENDDO
    DO ip=1,nbi
       IF ( trip_bx(ip,1) .EQ. 8 .OR. trip_bx(ip,1) .EQ. 1 .OR. trip_bx(ip,1) .EQ. 2) THEN
          trip_bx(ip,1) = trip_bx(ip,1) + 100
       ENDIF
       IF ( trip_bx(ip,nbj) .EQ. 6 .OR. trip_bx(ip,nbj) .EQ. 5 .OR. trip_bx(ip,nbj) .EQ. 4) THEN
          trip_bx(ip,nbj) = trip_bx(ip,nbj) + 100
       ENDIF
    ENDDO
    !
    !
    !  We simplify the outflow. We only need the direction normal to the
    !     box boundary and the 4 corners.
    ! 
    ! Northern border
    IF ( trip_bx(1,1) .EQ. 102 ) trip_bx(1,1) = 101
    IF ( trip_bx(nbi,1) .EQ. 108 ) trip_bx(nbi,1) = 101
    DO ip=2,nbi-1
       IF ( trip_bx(ip,1) .EQ. 108 .OR. trip_bx(ip,1) .EQ. 102 ) trip_bx(ip,1) = 101
    ENDDO
    ! Southern border
    IF ( trip_bx(1,nbj) .EQ. 104 ) trip_bx(1,nbj) = 105
    IF ( trip_bx(nbi,nbj) .EQ. 106 ) trip_bx(nbi,nbj) = 105
    DO ip=2,nbi-1
       IF ( trip_bx(ip,nbj) .EQ. 104 .OR. trip_bx(ip,nbj) .EQ. 106 ) trip_bx(ip,nbj) = 105
    ENDDO
    ! Eastern border
    IF ( trip_bx(nbi,1) .EQ. 104) trip_bx(nbi,1) = 103
    IF ( trip_bx(nbi,nbj) .EQ. 102) trip_bx(nbi,nbj) = 103
    DO jp=2,nbj-1
       IF ( trip_bx(nbi,jp) .EQ. 104 .OR. trip_bx(nbi,jp) .EQ. 102 ) trip_bx(nbi,jp) = 103
    ENDDO
    ! Western border
    IF ( trip_bx(1,1) .EQ. 106) trip_bx(1,1) = 107
    IF ( trip_bx(1,nbj) .EQ. 108) trip_bx(1,nbj) = 107
    DO jp=2,nbj-1
       IF ( trip_bx(1,jp) .EQ. 106 .OR. trip_bx(1,jp) .EQ. 108 ) trip_bx(1,jp) = 107
    ENDDO       
    !
    !
  END SUBROUTINE routing_getgrid
!
!! ================================================================================================================================
!! SUBROUTINE   : routing_sortcoord
!!
!>\BRIEF         This subroutines orders the coordinates to go from North to South and West to East.
!!
!! DESCRIPTION (definitions, functional, design, flags) : None
!!
!! RECENT CHANGE(S): None
!!
!! MAIN OUTPUT VARIABLE(S):
!!
!! REFERENCES   : None
!!
!! FLOWCHART    : None
!! \n
!_ ================================================================================================================================

  SUBROUTINE routing_sortcoord(nb_in, coords, direction, nb_out)
    !
    IMPLICIT NONE
    !
!! INPUT VARIABLES
    INTEGER(i_std), INTENT(in)   :: nb_in             !!
    REAL(r_std), INTENT(inout)   :: coords(nb_in)     !!
    !
!! OUTPUT VARIABLES
    INTEGER(i_std), INTENT(out)  :: nb_out            !!
    !
!! LOCAL VARIABLES
    CHARACTER(LEN=2)             :: direction         !!
    INTEGER(i_std)               :: ipos              !!
    REAL(r_std)                  :: coords_tmp(nb_in) !!
    INTEGER(i_std), DIMENSION(1) :: ll                !!
    INTEGER(i_std)               :: ind(nb_in)        !!

!_ ================================================================================================================================
    !
    ipos = 1
    nb_out = nb_in
    !
    ! Compress the coordinates array
    !
    DO WHILE ( ipos < nb_in )
       IF ( coords(ipos+1) /= undef_sechiba) THEN
         IF ( COUNT(coords(ipos:nb_out) == coords(ipos)) > 1 ) THEN
            coords(ipos:nb_out-1) = coords(ipos+1:nb_out) 
            coords(nb_out:nb_in) = undef_sechiba
            nb_out = nb_out - 1
         ELSE
            ipos = ipos + 1
         ENDIF
      ELSE
         EXIT
      ENDIF
    ENDDO
    !
    ! Sort it now
    !
    ! First we get ready and adjust for the periodicity in longitude
    !
    coords_tmp(:) = undef_sechiba
    IF ( INDEX(direction, 'WE') == 1 .OR.  INDEX(direction, 'EW') == 1) THEN
       IF ( MAXVAL(ABS(coords(1:nb_out))) .GT. 160 ) THEN
          coords_tmp(1:nb_out) = MOD(coords(1:nb_out) + 360.0, 360.0)
       ELSE
          coords_tmp(1:nb_out) = coords(1:nb_out)
       ENDIF
    ELSE IF ( INDEX(direction, 'NS') == 1 .OR.  INDEX(direction, 'SN') == 1) THEN
       coords_tmp(1:nb_out) = coords(1:nb_out)
    ELSE
       WRITE(numout,*) 'The chosen direction (', direction,') is not recognized'
       CALL ipslerr_p(3,'routing_sortcoord','The chosen direction is not recognized','First section','')
    ENDIF
    !
    ! Get it sorted out now
    !
    ipos = 1
    !
    IF ( INDEX(direction, 'WE') == 1 .OR. INDEX(direction, 'SN') == 1) THEN
       DO WHILE (COUNT(ABS(coords_tmp(:)-undef_sechiba) > EPSILON(undef_sechiba)*10.) >= 1)
          ll = MINLOC(coords_tmp(:), coords_tmp /= undef_sechiba)
          ind(ipos) = ll(1) 
          coords_tmp(ll(1)) = undef_sechiba
          ipos = ipos + 1
       ENDDO
    ELSE IF ( INDEX(direction, 'EW') == 1 .OR. INDEX(direction, 'NS') == 1) THEN
       DO WHILE (COUNT(ABS(coords_tmp(:)-undef_sechiba) > EPSILON(undef_sechiba)*10.) >= 1)
          ll = MAXLOC(coords_tmp(:), coords_tmp /= undef_sechiba)
          ind(ipos) = ll(1) 
          coords_tmp(ll(1)) = undef_sechiba
          ipos = ipos + 1
       ENDDO
    ELSE
       WRITE(numout,*) 'The chosen direction (', direction,') is not recognized (second)'
       CALL ipslerr_p(3,'routing_sortcoord','The chosen direction is not recognized','Second section','')
    ENDIF
    !
    coords(1:nb_out) = coords(ind(1:nb_out))
    IF (nb_out < nb_in) THEN
       coords(nb_out+1:nb_in) = zero
    ENDIF
    !
  END SUBROUTINE routing_sortcoord
  !

!! ================================================================================================================================
!! SUBROUTINE   : routing_findbasins
!!
!>\BRIEF         This subroutine finds the basins and does some clean up.
!!               The aim is to return the list off all points which are within the
!!               same basin of the grid box.
!!
!! DESCRIPTION (definitions, functional, design, flags) :
!!  We will also collect all points which directly flow into the ocean in one basin
!!  Make sure that we do not have a basin with two outflows and other exceptions.
!!  At this stage no effort is made to come down to the truncation of the model.
!!
!! Convention for trip    \n
!! -------------------    \n
!! Inside of the box :    \n
!! trip = 1 : flow = N    \n
!! trip = 2 : flow = NE    \n
!! trip = 3 : flow = E    \n
!! trip = 4 : flow = SE    \n
!! trip = 5 : flow = S    \n
!! trip = 6 : flow = SW    \n
!! trip = 7 : flow = W    \n
!! trip = 8 : flow = NW    \n
!! trip = 97 : return flow into the ground    \n
!! trip = 98 : coastal flow (diffuse flow into the oceans) These values are created here    \n
!! trip = 99 : river flow into the oceans    \n
!!
!! Out flow from the grid :    \n
!! trip = 101 : flow = N out of the coarse grid    \n
!! trip = 102 : flow = NE out of the coarse grid    \n
!! trip = 103 : flow = E out of the coarse grid    \n
!! trip = 104 : flow = SE out of the coarse grid    \n
!! trip = 105 : flow = S out of the coarse grid    \n
!! trip = 106 : flow = SW out of the coarse grid    \n
!! trip = 107 : flow = W out of the coarse grid    \n
!! trip = 108 : flow = NW out of the coarse grid!    \n
!! RECENT CHANGE(S): None
!!
!! MAIN OUTPUT VARIABLE(S):
!!
!! REFERENCES   : None
!!
!! FLOWCHART    : None
!! \n
!_ ================================================================================================================================

  SUBROUTINE routing_findbasins(nbi, nbj, trip, basin, hierarchy, topoind, nb_basin, basin_inbxid, basin_sz,&
       & basin_bxout, basin_pts, coast_pts)
    !
    IMPLICIT NONE
    !
!! INPUT VARIABLES
    INTEGER(i_std), INTENT(in)    :: nbi                          !! Number of point in x within the grid (unitless)
    INTEGER(i_std), INTENT(in)    :: nbj                          !! Number of point in y within the grid (unitless)
    REAL(r_std), INTENT(in)       :: hierarchy(:,:)               !!
    REAL(r_std), INTENT(in)       :: topoind(:,:)                 !! Topographic index of the residence time (m)
    !
    !  Modified
    INTEGER(i_std), INTENT(inout) :: trip(:,:)                    !! The trip field (unitless)
    INTEGER(i_std), INTENT(inout) :: basin(:,:)                   !!
    !
!! OUTPUT VARIABLES
    INTEGER(i_std), INTENT(out)   :: nb_basin                     !! Number of sub-basins (unitless)
    INTEGER(i_std), INTENT(out)   :: basin_inbxid(nbvmax)         !!
    INTEGER(i_std), INTENT(out)   :: basin_sz(nbvmax)             !!
    INTEGER(i_std), INTENT(out)   :: basin_bxout(nbvmax)          !!
    INTEGER(i_std), INTENT(out)   :: basin_pts(nbvmax, nbvmax, 2) !!
    INTEGER(i_std), INTENT(out)   :: coast_pts(nbvmax)            !! The coastal flow points (unitless)
    !
!! LOCAL VARIABLES
    INTEGER(i_std)                :: ibas, ilf, nbb, nb_in        !!
    INTEGER(i_std)                :: bname(nbvmax)                !!
    INTEGER(i_std)                :: sz(nbvmax)                   !!
    INTEGER(i_std)                :: pts(nbvmax,nbvmax,2)         !!
    INTEGER(i_std)                :: nbout(nbvmax)                !!
    INTEGER(i_std)                :: new_nb                       !!
    INTEGER(i_std)                :: new_bname(nbvmax)            !!
    INTEGER(i_std)                :: new_sz(nbvmax)               !!
    INTEGER(i_std)                :: new_pts(nbvmax,nbvmax,2)     !!
    INTEGER(i_std)                :: itrans                       !!
    INTEGER(i_std)                :: trans(nbvmax)                !!
    INTEGER(i_std)                :: outdir(nbvmax)               !!
    INTEGER(i_std)                :: tmpsz(nbvmax)                !!
    INTEGER(i_std)                :: ip, jp, jpp(1), ipb          !!
    INTEGER(i_std)                :: sortind(nbvmax)              !!
    CHARACTER(LEN=7)              :: fmt                          !!

!_ ================================================================================================================================
    !
    nbb = 0
    ibas = -1
    bname(:) = undef_int
    sz(:) = 0
    nbout(:) = 0
    new_pts(:,:,:) = 0
    !
    ! 1.0 Find all basins within this grid box
    !     Sort the variables per basin so that we can more easily
    !     access data from the same basin (The variables are :
    !     bname, sz, pts, nbout)
    !
    DO ip=1,nbi
       DO jp=1,nbj
          IF ( basin(ip,jp) .LT. undef_int) THEN
             IF ( COUNT(basin(ip,jp) .EQ. bname(:)) .EQ. 0 ) THEN
                nbb = nbb + 1
                IF ( nbb .GT. nbvmax ) CALL ipslerr_p(3,'routing_findbasins','nbvmax too small','first section','')
                bname(nbb) = basin(ip,jp)
                sz(nbb) = 0
             ENDIF
             !
             DO ilf=1,nbb
                IF ( basin(ip,jp) .EQ. bname(ilf) ) THEN
                   ibas = ilf
                ENDIF
             ENDDO
             !
             sz(ibas) = sz(ibas) + 1
             IF ( sz(ibas) .GT. nbvmax ) CALL ipslerr_p(3,'routing_findbasins','nbvmax too small','second section','')
             pts(ibas, sz(ibas), 1) = ip
             pts(ibas, sz(ibas), 2) = jp
             ! We deal only with outflow and leave flow back into the grid box for later.
             IF ( trip(ip,jp) .GE. 97 ) THEN
                nbout(ibas) = nbout(ibas) + 1
             ENDIF
             !
          ENDIF
          !
       ENDDO
    ENDDO
    !
    ! 2.0 All basins which have size 1 and flow to the ocean are put together.
    !
    itrans = 0
    coast_pts(:) = undef_int
    ! Get all the points we can collect
    DO ip=1,nbb
       IF ( sz(ip) .EQ. 1 .AND. trip(pts(ip,1,1),pts(ip,1,2)) .EQ. 99) THEN
          itrans = itrans + 1
          trans(itrans) = ip
          trip(pts(ip,1,1),pts(ip,1,2)) = 98
       ENDIF
    ENDDO
    ! put everything in the first basin
    IF ( itrans .GT. 1) THEN
       ipb = trans(1)
       coast_pts(sz(ipb)) = bname(ipb)
       bname(ipb) = -1
       DO ip=2,itrans
          sz(ipb) = sz(ipb) + 1
          coast_pts(sz(ipb)) = bname(trans(ip))
          sz(trans(ip)) = 0
          pts(ipb, sz(ipb), 1) = pts(trans(ip), 1, 1) 
          pts(ipb, sz(ipb), 2) = pts(trans(ip), 1, 2) 
       ENDDO
    ENDIF
    !
    ! 3.0 Make sure that we have only one outflow point in each basin
    !
    ! nbb is the number of basins on this grid box.
    new_nb = 0
    DO ip=1,nbb
       ! We only do this for grid-points which have more than one outflow
       IF ( sz(ip) .GT. 1 .AND. nbout(ip) .GT. 1) THEN
          !
          ! Pick up all points needed and store them in trans
          !
          itrans = 0
          DO jp=1,sz(ip)
             IF ( trip(pts(ip,jp,1),pts(ip,jp,2)) .GE. 97) THEN
                itrans = itrans + 1
                trans(itrans) = trip(pts(ip,jp,1),pts(ip,jp,2))
             ENDIF
          ENDDO
          !
          ! First issue : We have more than one point of the basin which flows into
          ! the ocean. In this case we put everything into coastal flow. It will go into
          ! a separate basin in the routing_globalize routine.
          !
          IF ( (COUNT(trans(1:itrans) .EQ. 99) + COUNT(trans(1:itrans) .EQ. 98)) .GT. 1) THEN
             DO jp=1,sz(ip)
                IF ( trip(pts(ip,jp,1),pts(ip,jp,2)) .EQ. 99 ) THEN
                   trip(pts(ip,jp,1),pts(ip,jp,2)) = 98
                   trans(itrans) = trip(pts(ip,jp,1),pts(ip,jp,2))
                ENDIF
             ENDDO
          ENDIF
          !
          ! Second issue : We have redundant outflows at the boundaries. That is two small grid
          ! boxes flowing into the same GCM grid box.
          !
          IF ( COUNT(trans(1:itrans) .GT. 100) .GE. 1) THEN
             CALL routing_simplify(nbi, nbj, trip, basin, hierarchy, bname(ip))
             itrans = 0
             DO jp=1,sz(ip)
                IF ( trip(pts(ip,jp,1),pts(ip,jp,2)) .GE. 9) THEN
                   itrans = itrans + 1
                   trans(itrans) = trip(pts(ip,jp,1),pts(ip,jp,2))
                ENDIF
             ENDDO
          ENDIF
          !
          ! Third issue : we have more than one outflow from the boxes. This could be 
          !             - flow into 2 or more neighboring GCM grids
          !             - flow into a neighboring GCM grids and into the ocean or be a return flow (=97. =98, =99)
          !             - flow into a neighboring GCM grids or ocean and back into the same GCM grid box
          ! The only solution is to cut the basin up in as many parts.
          !
          IF ( COUNT(trans(1:itrans) .GE. 97) .GT. 1) THEN
             !
             nb_in =  new_nb
             CALL routing_cutbasin(nbi, nbj, nbb, trip, basin, bname(ip), new_nb, new_bname, new_sz, new_pts)
             !
             ! If we have split the basin then we need to cancel the old one
             !
             IF ( nb_in .NE. new_nb) THEN
                sz(ip) = 0
             ENDIF
             !
          ENDIF
          !
       ENDIF
    ENDDO
    !
    !  Add the new basins to the end of the list
    !
    If ( nbb+new_nb .LE. nbvmax) THEN
       DO ip=1,new_nb
          bname(nbb+ip) = new_bname(ip)
          sz(nbb+ip) = new_sz(ip)
          pts(nbb+ip,:,:) = new_pts(ip,:,:)
       ENDDO
       nbb = nbb+new_nb
    ELSE
       WRITE(numout,*) 'Increase nbvmax. It is too small to contain all the basins (routing_findbasins)'
       CALL ipslerr_p(3,'routing_findbasins','Increase nbvmax.','It is too small to contain all the basins','')
    ENDIF
    !
    ! Keep the output direction
    !
    DO ip=1,nbb
       IF ( sz(ip) .GT. 0 ) THEN
          trans(:) = 0
          DO jp=1,sz(ip)
             trans(jp) = trip(pts(ip,jp,1),pts(ip,jp,2))
          ENDDO
          outdir(ip) = MAXVAL(trans(1:sz(ip)))
          IF ( outdir(ip) .GE. 97 ) THEN
             outdir(ip) = outdir(ip) - 100
          ELSE
             WRITE(numout,*) 'Why are we here and can not find a trip larger than 96'
             WRITE(numout,*) 'Does this mean that the basin does not have any outflow ', ip, bname(ip)
             WRITE(fmt,"('(',I3,'I9)')") nbi
             WRITE(numout,*) '-----------------------> trip'
             DO jp=1,nbj
                WRITE(numout,fmt) trip(1:nbi,jp)
             ENDDO
             WRITE(numout,*) '-----------------------> basin'
             DO jp=1,nbj
                WRITE(numout,fmt) basin(1:nbi,jp)
             ENDDO
             CALL ipslerr_p(3,'routing_findbasins','Probleme finding trip','','')
          ENDIF
       ENDIF
    ENDDO
    !
    !
    ! Sort the output by size of the various basins. 
    !
    nb_basin = COUNT(sz(1:nbb) .GT. 0)
    tmpsz(:) = -1
    tmpsz(1:nbb) = sz(1:nbb)
    DO ip=1,nbb
       jpp = MAXLOC(tmpsz(:))
       IF ( sz(jpp(1)) .GT. 0) THEN
          sortind(ip) = jpp(1)
          tmpsz(jpp(1)) = -1
       ENDIF
    ENDDO
    basin_inbxid(1:nb_basin) = bname(sortind(1:nb_basin))
    basin_sz(1:nb_basin) = sz(sortind(1:nb_basin))
    basin_pts(1:nb_basin,:,:) = pts(sortind(1:nb_basin),:,:)
    basin_bxout(1:nb_basin) = outdir(sortind(1:nb_basin))
    !
    ! We can only check if we have at least as many outflows as basins
    !
    ip = COUNT(trip(1:nbi,1:nbj) .GE. 97 .AND. trip(1:nbi,1:nbj) .LT. undef_int)
!!    ip = ip + COUNT(trip(1:nbi,1:nbj) .EQ. 97)
!!    IF ( COUNT(trip(1:nbi,1:nbj) .EQ. 98) .GT. 0) ip = ip + 1
    IF ( ip .LT. nb_basin ) THEN
       WRITE(numout,*) 'We have less outflow points than basins :', ip
       WRITE(fmt,"('(',I3,'I9)')") nbi
       WRITE(numout,*) '-----------------------> trip'
       DO jp=1,nbj
          WRITE(numout,fmt) trip(1:nbi,jp)
       ENDDO
       WRITE(numout,*) '-----------------------> basin'
       DO jp=1,nbj
          WRITE(numout,fmt) basin(1:nbi,jp)
       ENDDO
       WRITE(numout,*) 'nb_basin :', nb_basin
       WRITE(numout,*) 'Basin sized :', basin_sz(1:nb_basin)
       CALL ipslerr_p(3,'routing_findbasins','Probleme less outflow points than basins','','')
    ENDIF
    
  END SUBROUTINE routing_findbasins
  !
!! ================================================================================================================================
!! SUBROUTINE   : routing_simplify
!!
!>\BRIEF         This subroutine symplifies the routing out of each basin by taking 
!!               out redundancies at the borders of the GCM box.
!!               The aim is to have only one outflow point per basin and grid box.
!!               But here we will not change the direction of the outflow.  
!!
!! DESCRIPTION (definitions, functional, design, flags) : None
!!
!! RECENT CHANGE(S): None
!!
!! MAIN OUTPUT VARIABLE(S):
!!
!! REFERENCES   : None
!!
!! FLOWCHART    : None
!! \n
!_ ================================================================================================================================

SUBROUTINE routing_simplify(nbi, nbj, trip, basin, hierarchy, basin_inbxid)
    !
    IMPLICIT NONE
    !
!! LOCAL VARIABLES
    INTEGER(i_std)                             :: nbi                        !! Number of point in x within the grid (unitless)
    INTEGER(i_std)                             :: nbj                        !! Number of point in y within the grid (unitless)
    INTEGER(i_std)                             :: trip(:,:)                  !! The trip field (unitless)
    INTEGER(i_std)                             :: basin(:,:)                 !!
    REAL(r_std)                                :: hierarchy(:,:)             !!
    INTEGER(i_std)                             :: basin_inbxid               !!
    !
    INTEGER(i_std)                             :: ip, jp, nbout, basin_sz, iborder !!
    INTEGER(i_std), DIMENSION(nbvmax,nbvmax)   :: trip_tmp                   !! Temporary trip field which only contains the values for the basin on which we currently work (1)
    INTEGER(i_std), DIMENSION(nbvmax,nbvmax,2) :: trip_flow                  !!
    INTEGER(i_std), DIMENSION(nbvmax,2)        :: outflow                    !!
    INTEGER(i_std), DIMENSION(nbvmax)          :: outsz                      !!
    CHARACTER(LEN=7)                           :: fmt                        !!
    !
    INTEGER(i_std), DIMENSION(8,2)             :: inc                        !!
    INTEGER(i_std)                             :: itodo, ill(1), icc, ismall, ibas, iip, jjp, ib, id !! Indices (unitless)
    INTEGER(i_std), DIMENSION(nbvmax)          :: todopt                     !!
!!$, todosz
    REAL(r_std), DIMENSION(nbvmax)             :: todohi                     !!
    LOGICAL                                    :: not_found, debug = .FALSE. !! (true/false)

!_ ================================================================================================================================
    !
    !
    !  The routing code (i=1, j=2)
    !
    inc(1,1) = 0
    inc(1,2) = -1
    inc(2,1) = 1
    inc(2,2) = -1
    inc(3,1) = 1
    inc(3,2) = 0
    inc(4,1) = 1
    inc(4,2) = 1
    inc(5,1) = 0
    inc(5,2) = 1
    inc(6,1) = -1
    inc(6,2) = 1
    inc(7,1) = -1
    inc(7,2) = 0
    inc(8,1) = -1
    inc(8,2) = -1
    !
    !
    !  Symplify the outflow conditions first. We are only interested in the
    !  outflows which go to different GCM grid boxes.
    !
    IF ( debug ) THEN
       WRITE(numout,*) '+++++++++++++++++++ BEFORE ANYTHING ++++++++++++++++++++'
       WRITE(fmt,"('(',I3,'I6)')") nbi
       DO jp=1,nbj
          WRITE(numout,fmt) trip_tmp(1:nbi,jp)
       ENDDO
    ENDIF
    !
    !  transfer the trips into an array which only contains the basin we are interested in
    !
    trip_tmp(:,:) = -1
    basin_sz = 0
    DO ip=1,nbi
       DO jp=1,nbj
          IF ( basin(ip,jp) .EQ. basin_inbxid) THEN
             trip_tmp(ip,jp) = trip(ip,jp)
             basin_sz = basin_sz + 1
          ENDIF
       ENDDO
    ENDDO
    !
    ! Determine for each point where it flows to
    !
    CALL routing_findrout(nbi, nbj, trip_tmp, basin_sz, basin_inbxid, nbout, outflow, trip_flow, outsz)
    !
    !
    !
    !
    ! Over the width of a GCM grid box we can have many outflows but we are interested
    ! in only one for each basin. Thus we wish to collect them all to form only one outflow
    ! to the neighboring grid box.
    !
    DO iborder = 101,107,2
       !
       ! If we have more than one of these outflows then we need to merge the sub-basins
       !
       icc = COUNT(trip_tmp .EQ. iborder)-1
       DO WHILE ( icc .GT. 0)
          ! Pick out all the points we will have to do
          itodo = 0
          DO ip=1,nbout
             IF (trip_tmp(outflow(ip,1),outflow(ip,2)) .EQ. iborder) THEN
                itodo = itodo + 1
                todopt(itodo) = ip
!!$                todosz(itodo) = outsz(ip)
                ! We take the hierarchy of the outflow point as we will try to
                ! minimize if for the outflow of the entire basin.
                todohi(itodo) = hierarchy(outflow(ip,1),outflow(ip,2))
             ENDIF
          ENDDO
          !
          ! We change the direction of the smallest basin.
          !
          ill=MAXLOC(todohi(1:itodo))
          ismall = todopt(ill(1))
          !
          DO ip=1,nbi
             DO jp=1,nbj
                IF ( trip_flow(ip,jp,1) .EQ. outflow(ismall,1) .AND.&
                     & trip_flow(ip,jp,2) .EQ. outflow(ismall,2) ) THEN
                   ! Now that we have found a point of the smallest sub-basin we 
                   ! look around for another sub-basin
                   ib = 1
                   not_found = .TRUE.
                   DO WHILE ( not_found .AND. ib .LE. itodo ) 
                      IF ( ib .NE. ill(1) ) THEN
                         ibas = todopt(ib)
                         DO id=1,8
                            iip = ip + inc(id,1)
                            jjp = jp + inc(id,2)
                            ! Can we look at this points or is there any need to ?
                            IF ( iip .GE. 1 .AND. iip .LE. nbi .AND. &
                                 & jjp .GE. 1 .AND. jjp .LE. nbj .AND. not_found) THEN
                               ! Is this point the one we look for ?
                               IF ( trip_flow(iip,jjp,1) .EQ. outflow(ibas,1) .AND. &
                                    & trip_flow(iip,jjp,2) .EQ. outflow(ibas,2)) THEN
                                  trip_flow(ip,jp,1) = outflow(ibas,1)
                                  trip_flow(ip,jp,2) = outflow(ibas,2)
                                  trip_tmp(ip,jp) = id
                                  ! This last line ensures that we do not come back to this point
                                  ! and that in the end the outer while will stop
                                  not_found = .FALSE.
                               ENDIF
                            ENDIF
                         ENDDO
                      ENDIF
                      ib = ib + 1
                   ENDDO
                ENDIF
             ENDDO
          ENDDO
          !
          icc = icc - 1
       ENDDO
       !
       !
    ENDDO
    !
    IF ( debug ) THEN
       WRITE(numout,*) '+++++++++++++++++++ AFTER +++++++++++++++++++++++++++++'
       WRITE(fmt,"('(',I3,'I6)')") nbi
       DO jp=1,nbj
          WRITE(numout,fmt) trip_tmp(1:nbi,jp)
       ENDDO
    ENDIF
    !
    !  Put trip_tmp back into trip
    !
    DO ip=1,nbi
       DO jp=1,nbj
          IF ( trip_tmp(ip,jp) .GT. 0) THEN
             trip(ip,jp) = trip_tmp(ip,jp)
          ENDIF
       ENDDO
    ENDDO
    !
  END SUBROUTINE routing_simplify
!
!! ================================================================================================================================
!! SUBROUTINE   : routing_cutbasin
!!
!>\BRIEF        This subroutine cuts the original basin which has more than one outflow
!!              into as many subbasins as outflow directions.  
!!
!! DESCRIPTION (definitions, functional, design, flags) : None
!!
!! RECENT CHANGE(S): None
!!
!! MAIN OUTPUT VARIABLE(S):
!!
!! REFERENCES   : None
!!
!! FLOWCHART    : None
!! \n
!_ ================================================================================================================================

SUBROUTINE routing_cutbasin (nbi, nbj, nbbasins, trip, basin, basin_inbxid, nb, bname, sz, pts)
    !
    IMPLICIT NONE
    !
!! INPUT VARIABLES
    INTEGER(i_std), INTENT(in)                 :: nbi, nbj             !! Number of point in x and y within the grid (unitless)
    INTEGER(i_std), INTENT(in)                 :: nbbasins             !!
    INTEGER(i_std), INTENT(in)                 :: basin_inbxid         !!
    !
    !  Modified
    INTEGER(i_std), INTENT(inout)              :: trip(:,:)            !! The trip field (unitless)
    INTEGER(i_std), INTENT(inout)              :: basin(:,:)           !!
    !
!! OUTPUT VARIABLES
    INTEGER(i_std), INTENT(out)                :: nb                   !!
    INTEGER(i_std), INTENT(out)                :: bname(nbvmax)        !!
    INTEGER(i_std), INTENT(out)                :: sz(nbvmax)           !!
    INTEGER(i_std), INTENT(out)                :: pts(nbvmax,nbvmax,2) !!
    !
!! LOCAL VARIABLES
    INTEGER(i_std)                             :: ip, jp, iip, jjp, ib, ibb, id, nbout !! Indices (unitless)
    INTEGER(i_std)                             :: basin_sz             !!
    INTEGER(i_std)                             :: nb_in                !!
    INTEGER(i_std), DIMENSION(nbvmax,nbvmax)   :: trip_tmp             !! Temporary trip field which only contains the values for the basin on which we currently work (unitless)
    INTEGER(i_std), DIMENSION(nbvmax,nbvmax,2) :: trip_flow            !!
    INTEGER(i_std), DIMENSION(nbvmax,2)        :: outflow              !!
    INTEGER(i_std), DIMENSION(nbvmax)          :: outsz                !!
    CHARACTER(LEN=7)                           :: fmt                  !!
    LOGICAL                                    :: not_found            !! (true/false)
    LOGICAL                                    :: debug=.FALSE.        !! (true/false)
    !
    INTEGER(i_std), DIMENSION(8,2)             :: inc                  !!

!_ ================================================================================================================================
    !
    !
    !  The routing code (i=1, j=2)
    !
    inc(1,1) = 0
    inc(1,2) = -1
    inc(2,1) = 1
    inc(2,2) = -1
    inc(3,1) = 1
    inc(3,2) = 0
    inc(4,1) = 1
    inc(4,2) = 1
    inc(5,1) = 0
    inc(5,2) = 1
    inc(6,1) = -1
    inc(6,2) = 1
    inc(7,1) = -1
    inc(7,2) = 0
    inc(8,1) = -1
    inc(8,2) = -1
    !
    ! Set up a temporary trip field which only contains the values
    ! for the basin on which we currently work.
    !
    trip_tmp(:,:) = -1
    basin_sz = 0
    DO ip=1,nbi
       DO jp=1,nbj
          IF ( basin(ip,jp) .EQ. basin_inbxid) THEN
             trip_tmp(ip,jp) = trip(ip,jp)
             basin_sz = basin_sz + 1
          ENDIF
       ENDDO
    ENDDO
    !
    CALL routing_findrout(nbi, nbj, trip_tmp, basin_sz, basin_inbxid, nbout, outflow, trip_flow, outsz)
    ! 
!    IF ( debug ) THEN
!       DO ib = nb_in+1,nb
!          DO ip=1,sz(ib)
!             trip_tmp(pts(ib, ip, 1),pts(ib, ip, 2)) = ib*(-1)-900
!          ENDDO
!       ENDDO
!       WRITE(fmt,"('(',I3,'I6)')") nbi
!       WRITE(numout,*)  'BEFORE ------------> New basins '
!       WRITE(numout,*) nb, ' sz :', sz(1:nb)
!       DO jp=1,nbj
!          WRITE(numout,fmt) trip_tmp(1:nbi,jp)
!       ENDDO
!    ENDIF
    !
    !  Take out the small sub-basins. That is those which have only one grid box
    !  This is only done if we need to save space in the number of basins. Else we
    !  can take it easy and keep diverging sub-basins for the moment. 
    !
    IF ( nbbasins .GE. nbasmax ) THEN
       DO ib=1,nbout
          ! If the sub-basin is of size one and its larger neighbor is flowing into another
          ! direction then we put them together.
          IF ( outsz(ib) .EQ. 1 .AND. trip(outflow(ib,1), outflow(ib,2)) .GT. 99 ) THEN
             !
             not_found = .TRUE.
             DO id=1,8
                ip = outflow(ib,1)
                jp = outflow(ib,2)
                iip = ip + inc(id,1)
                jjp = jp + inc(id,2)
                ! Can we look at this points ?
                IF ( iip .GE. 1 .AND. iip .LE. nbi .AND. &
                     & jjp .GE. 1 .AND. jjp .LE. nbj .AND. not_found) THEN
                   ! Did we find a direct neighbor which is an outflow point ?
                   IF ( trip_tmp(iip,jjp) .GT. 100 ) THEN
                      ! IF so direct the flow towards it and update the tables.
                      not_found = .FALSE.
                      trip(ip,jp) = id
                      trip_tmp(ip,jp) = id
                      outsz(ib) = 0
                      ! update the table of this basin
                      DO ibb=1,nbout
                         IF ( iip .EQ. outflow(ibb,1) .AND. jjp .EQ. outflow(ibb,2) ) THEN
                            outsz(ibb) = outsz(ibb)+1 
                            trip_flow(ip,jp,1) = outflow(ibb,1)
                            trip_flow(ip,jp,2) = outflow(ibb,2)
                         ENDIF
                      ENDDO
                   ENDIF
                ENDIF
             ENDDO
          ENDIF
       ENDDO
    ENDIF
    !
    !
    !  Cut the basin if we have more than 1 left.
    !
    !
    IF ( COUNT(outsz(1:nbout) .GT. 0) .GT. 1 ) THEN
       !
       nb_in = nb
       !
       DO ib = 1,nbout
          IF ( outsz(ib) .GT. 0) THEN
             nb = nb+1
             IF ( nb .GT. nbvmax) THEN
                WRITE(numout,*) 'nbvmax too small, increase it (routing_cutbasin)'
             ENDIF
             bname(nb) = basin_inbxid
             sz(nb) = 0
             DO ip=1,nbi
                DO jp=1,nbj
                   IF ( (trip_flow(ip,jp,1) + trip_flow(ip,jp,1)) .GT. 0 .AND. &
                      & trip_flow(ip,jp,1) .EQ. outflow(ib,1) .AND. &
                      & trip_flow(ip,jp,2) .EQ. outflow(ib,2) ) THEN
                      sz(nb) = sz(nb) + 1
                      pts(nb, sz(nb), 1) = ip
                      pts(nb, sz(nb), 2) = jp
                   ENDIF
                ENDDO
             ENDDO
          ENDIF
       ENDDO
       ! A short verification 
       IF ( SUM(sz(nb_in+1:nb)) .NE. basin_sz) THEN
          WRITE(numout,*) 'Lost some points while spliting the basin'
          WRITE(numout,*) 'nbout :', nbout
          DO ib = nb_in+1,nb
             WRITE(numout,*) 'ib, SZ :', ib, sz(ib)
          ENDDO
          WRITE(fmt,"('(',I3,'I6)')") nbi
          WRITE(numout,*)  '-------------> trip '
          DO jp=1,nbj
             WRITE(numout,fmt) trip_tmp(1:nbi,jp)
          ENDDO
          CALL ipslerr_p(3,'routing_cutbasin','Lost some points while spliting the basin','','')
       ENDIF
       
       IF ( debug ) THEN
          DO ib = nb_in+1,nb
             DO ip=1,sz(ib)
                trip_tmp(pts(ib, ip, 1),pts(ib, ip, 2)) = ib*(-1)-900
             ENDDO
          ENDDO
          WRITE(fmt,"('(',I3,'I6)')") nbi
          WRITE(numout,*)  'AFTER-------------> New basins '
          WRITE(numout,*) nb, ' sz :', sz(1:nb)
          DO jp=1,nbj
             WRITE(numout,fmt) trip_tmp(1:nbi,jp)
          ENDDO
          IF ( MAXVAl(trip_tmp(1:nbi,1:nbj)) .GT. 0) THEN
             CALL ipslerr_p(3,'routing_cutbasin','Error in debug checking','','')
          ENDIF
       ENDIF
    ENDIF
    !
  END SUBROUTINE routing_cutbasin
  !
!! ================================================================================================================================
!! SUBROUTINE   : routing_hierarchy
!!
!>\BRIEF        This subroutine finds, for each point, the distance to the outflow
!!               point along the flowlines of the basin. 
!!
!! DESCRIPTION (definitions, functional, design, flags) : None
!!
!! RECENT CHANGE(S): None
!!
!! MAIN OUTPUT VARIABLE(S):
!!
!! REFERENCES   : None
!!
!! FLOWCHART    : None
!! \n
!_ ================================================================================================================================

SUBROUTINE routing_hierarchy(iml, jml, trip, topoindex, hierarchy)
    !
    IMPLICIT NONE
    !
!! LOCAL VARIABLES
    INTEGER(i_std)                  :: iml          !! X resolution of the high resolution grid
    INTEGER(i_std)                  :: jml          !! Y resolution of the high resolution grid
    REAL(r_std), DIMENSION(iml,jml) :: trip         !! The trip field (unitless)
    REAL(r_std), DIMENSION(iml,jml) :: hierarchy    !!
    REAL(r_std), DIMENSION(iml,jml) :: topoindex    !! Topographic index of the residence time (m)
    !
    INTEGER(i_std), DIMENSION(8,2)  :: inc          !!
    INTEGER(i_std)                  :: ip, jp, ib, ntripi, ntripj, cnt, trp !!
    REAL(r_std)                     :: topohier     !! The new value of topographically weighted hierarchy (m)
    REAL(r_std)                     :: topohier_old !! The old value of topographically weighted hierarchy (m)
    CHARACTER(LEN=7)                :: fmt          !!

!_ ================================================================================================================================
    !
    !  The routing code (i=1, j=2)
    !
    inc(1,1) = 0
    inc(1,2) = -1
    inc(2,1) = 1
    inc(2,2) = -1
    inc(3,1) = 1
    inc(3,2) = 0
    inc(4,1) = 1
    inc(4,2) = 1
    inc(5,1) = 0
    inc(5,2) = 1
    inc(6,1) = -1
    inc(6,2) = 1
    inc(7,1) = -1
    inc(7,2) = 0
    inc(8,1) = -1
    inc(8,2) = -1
    !
    DO ip=1,iml
       DO jp=1,jml
          IF ( trip(ip,jp) .LT. undef_sechiba ) THEN
             ntripi = ip
             ntripj = jp
             trp = NINT(trip(ip,jp))
             cnt = 1
             ! Warn for extreme numbers
             IF (  topoindex(ip,jp) .GT. 1.e10 ) THEN
                WRITE(numout,*) 'We have a very large topographic index for point ', ip, jp
                WRITE(numout,*) 'This can not be right :', topoindex(ip,jp)
                CALL ipslerr_p(3,'routing_hierarchy','Too large topographic index','','')
             ELSE
                topohier = topoindex(ip,jp)
             ENDIF
             !
             DO WHILE ( trp .GT. 0 .AND. trp .LT. 9 .AND. cnt .LT. iml*jml) 
                cnt = cnt + 1
                ntripi = ntripi + inc(trp,1)
                IF ( ntripi .LT. 1) ntripi = iml
                IF ( ntripi .GT. iml) ntripi = 1
                ntripj = ntripj + inc(trp,2)
                topohier_old = topohier
                topohier = topohier + topoindex(ntripi, ntripj)
                IF ( topohier_old .GT. topohier) THEN
                   WRITE(numout,*) 'Big Problem, how comes we climb up a hill ?'
                   WRITE(numout,*) 'The old value of topographicaly weighted hierarchy was : ', topohier_old
                   WRITE(numout,*) 'The new one is :', topohier
                   CALL ipslerr_p(3,'routing_hierarchy','Big Problem, how comes we climb up a hill ?','','')
                ENDIF
                trp = NINT(trip(ntripi, ntripj))
             ENDDO
             
             IF ( cnt .EQ. iml*jml) THEN
                WRITE(numout,*) 'We could not route point (routing_findrout) :', ip, jp
                WRITE(numout,*) '-------------> trip '
                WRITE(fmt,"('(',I3,'I6)')") iml
                DO ib=1,jml
                   WRITE(numout,fmt) trip(1:iml,ib)
                ENDDO
                CALL ipslerr_p(3,'routing_hierarchy','We could not route point','','')
             ENDIF
             
             hierarchy(ip,jp) = topohier
             
          ENDIF
       ENDDO
    ENDDO
    !
    !
  END SUBROUTINE routing_hierarchy
  !
!! ================================================================================================================================
!! SUBROUTINE   : routing_findrout
!!
!>\BRIEF        This subroutine simply computes the route to each outflow point
!!              and returns the outflow point for each point in the basin.  
!!
!! DESCRIPTION (definitions, functional, design, flags) : None
!!
!! RECENT CHANGE(S): None
!!
!! MAIN OUTPUT VARIABLE(S):
!!
!! REFERENCES   : None
!!
!! FLOWCHART    : None
!! \n
!_ ================================================================================================================================

SUBROUTINE routing_findrout(nbi, nbj, trip, basin_sz, basinid, nbout, outflow, trip_flow, outsz)
    !
    IMPLICIT NONE
    !
!! INPUT VARIABLES
    INTEGER(i_std)                                          :: nbi       !! Number of point in x within the grid (unitless)
    INTEGER(i_std)                                          :: nbj       !! Number of point in y within the grid (unitless)
    INTEGER(i_std), DIMENSION(nbvmax,nbvmax)                :: trip      !! The trip field (unitless)
    INTEGER(i_std)                                          :: basin_sz  !!
    INTEGER(i_std)                                          :: basinid   !!
    !
!! OUTPUT VARIABLES
    INTEGER(i_std), DIMENSION(nbvmax,2), INTENT(out)        :: outflow   !!
    INTEGER(i_std), DIMENSION(nbvmax,nbvmax,2), INTENT(out) :: trip_flow !!
    INTEGER(i_std), INTENT(out)                             :: nbout     !! 
    INTEGER(i_std), DIMENSION(nbvmax), INTENT(out)          :: outsz     !!
    !
!! LOCAL VARIABLES
    INTEGER(i_std), DIMENSION(8,2)                          :: inc       !!
    INTEGER(i_std)                                          :: ip, jp, ib, cnt, trp, totsz !! Indices (unitless)
    CHARACTER(LEN=7)                                        :: fmt       !!

!_ ================================================================================================================================
    !
    !
    !  The routing code (i=1, j=2)
    !
    inc(1,1) = 0
    inc(1,2) = -1
    inc(2,1) = 1
    inc(2,2) = -1
    inc(3,1) = 1
    inc(3,2) = 0
    inc(4,1) = 1
    inc(4,2) = 1
    inc(5,1) = 0
    inc(5,2) = 1
    inc(6,1) = -1
    inc(6,2) = 1
    inc(7,1) = -1
    inc(7,2) = 0
    inc(8,1) = -1
    inc(8,2) = -1
    !
    !
    !  Get the outflows and determine for each point to which outflow point it belong 
    !
    nbout = 0
    trip_flow(:,:,:) = 0
    DO ip=1,nbi
       DO jp=1,nbj
          IF ( trip(ip,jp) .GT. 9) THEN
             nbout = nbout + 1
             outflow(nbout,1) = ip
             outflow(nbout,2) = jp
          ENDIF 
          IF ( trip(ip,jp) .GT. 0) THEN
             trip_flow(ip,jp,1) = ip
             trip_flow(ip,jp,2) = jp
          ENDIF
       ENDDO
    ENDDO
    !
    ! Follow the flow of the water
    !
    DO ip=1,nbi
       DO jp=1,nbj
          IF ( (trip_flow(ip,jp,1) + trip_flow(ip,jp,2)) .GT. 0) THEN
             trp = trip(trip_flow(ip,jp,1), trip_flow(ip,jp,2))
             cnt = 0
             DO WHILE ( trp .GT. 0 .AND. trp .LT. 9 .AND. cnt .LT. nbi*nbj) 
                cnt = cnt + 1
                trip_flow(ip,jp,1) = trip_flow(ip,jp,1) + inc(trp,1)
                trip_flow(ip,jp,2) = trip_flow(ip,jp,2) + inc(trp,2)
                trp = trip(trip_flow(ip,jp,1), trip_flow(ip,jp,2))
             ENDDO
             IF ( cnt .EQ. nbi*nbj) THEN
                WRITE(numout,*) 'We could not route point (routing_findrout) :', ip, jp
                WRITE(numout,*) '-------------> trip '
                WRITE(fmt,"('(',I3,'I6)')") nbi
                DO ib=1,nbj
                   WRITE(numout,fmt) trip(1:nbi,ib)
                ENDDO
                CALL ipslerr_p(3,'routing_findrout','We could not route point','','')
             ENDIF
          ENDIF
       ENDDO
    ENDDO
    !
    !  What is the size of the region behind each outflow point ?
    !
    totsz = 0
    DO ip=1,nbout
       outsz(ip) = COUNT(trip_flow(:,:,1) .EQ. outflow(ip,1) .AND. trip_flow(:,:,2) .EQ. outflow(ip,2))
       totsz = totsz + outsz(ip)
    ENDDO
    IF ( basin_sz .NE. totsz) THEN
       WRITE(numout,*) 'Water got lost while I tried to follow it '
       WRITE(numout,*) basin_sz, totsz
       WRITE(numout,*) 'Basin id :', basinid
       DO ip=1,nbout
          WRITE(numout,*) 'ip :', ip, ' outsz :', outsz(ip), ' outflow :', outflow(ip,1), outflow(ip,2)
       ENDDO
       WRITE(numout,*) '-------------> trip '
       WRITE(fmt,"('(',I3,'I6)')") nbi
       DO jp=1,nbj
          WRITE(numout,fmt) trip(1:nbi,jp)
       ENDDO
       CALL ipslerr_p(3,'routing_findrout','Water got lost while I tried to follow it','','')
    ENDIF
    !
  END SUBROUTINE routing_findrout
  !
!! ================================================================================================================================
!! SUBROUTINE   : routing_globalize
!!
!>\BRIEF        This subroutine puts the basins found for grid box in the global map.
!!               Connection can only be made later when all information is together. 
!!
!! DESCRIPTION (definitions, functional, design, flags) : None
!!
!! RECENT CHANGE(S): None
!!
!! MAIN OUTPUT VARIABLE(S):
!! One of the outputs is basin_flowdir. Its convention is 1-8 for the directions from North to North
!! West going through South. The negative values will be -3 for return flow, -2 for coastal flow
!!
!! REFERENCES   : None
!!
!! FLOWCHART    : None
!! \n
!_ ================================================================================================================================

SUBROUTINE routing_globalize(nbpt, ib, neighbours, area_bx, trip_bx, hierarchy_bx, topoind_bx, min_topoind,&
       & nb_basin, basin_inbxid, basin_sz, basin_pts, basin_bxout, coast_pts, nwbas, basin_count,&
       & basin_area, basin_hierarchy, basin_topoind, basin_id, basin_flowdir, outflow_grid,&
       & nbcoastal, coastal_basin)
    !
    IMPLICIT NONE
    !
!! INPUT VARIABLES
    INTEGER(i_std), INTENT (in)                :: nbpt                   !! Domain size (unitless)
    INTEGER(i_std), INTENT (in)                :: ib                     !! Current basin (unitless)
    INTEGER(i_std), INTENT(in)                 :: neighbours(nbpt,NbNeighb)!! Vector of neighbours for each grid point 
                                                                         !! (1=North and then clockwise)
!! LOCAL VARIABLES 
    REAL(r_std), DIMENSION(nbvmax,nbvmax)      :: area_bx                !! Area of each small box in the grid box (m^2)
    INTEGER(i_std), DIMENSION(nbvmax,nbvmax)   :: trip_bx                !! The trip field for each of the smaller boxes (unitless)
    REAL(r_std), DIMENSION(nbvmax,nbvmax)      :: hierarchy_bx           !! Level in the basin of the point
    REAL(r_std), DIMENSION(nbvmax,nbvmax)      :: topoind_bx             !! Topographic index of the residence time for each of the smaller boxes (m)
    REAL(r_std)                                :: min_topoind            !! The current minimum of topographic index (m)
    INTEGER(i_std)                             :: nb_basin               !! Number of sub-basins (unitless)
    INTEGER(i_std), DIMENSION(nbvmax)          :: basin_inbxid, basin_sz !! ID of basin, number of points in the basin
    INTEGER(i_std), DIMENSION(nbvmax,nbvmax,2) :: basin_pts              !! Points in each basin
    INTEGER(i_std), DIMENSION(nbvmax)          :: basin_bxout            !! outflow direction
    INTEGER(i_std)                             :: coast_pts(nbvmax)      !! The coastal flow points (unitless)
    ! global maps
    INTEGER(i_std)                             :: nwbas                  !!
    INTEGER(i_std), DIMENSION(nbpt)            :: basin_count            !!
    INTEGER(i_std), DIMENSION(nbpt,nwbas)      :: basin_id               !!
    INTEGER(i_std), DIMENSION(nbpt,nwbas)      :: basin_flowdir          !! Water flow directions in the basin (unitless)
    REAL(r_std), DIMENSION(nbpt,nwbas)         :: basin_area             !!
    REAL(r_std), DIMENSION(nbpt,nwbas)         :: basin_hierarchy        !!
    REAL(r_std), DIMENSION(nbpt,nwbas)         :: basin_topoind          !! Topographic index of the residence time for a basin (m)
    INTEGER(i_std), DIMENSION(nbpt,nwbas)      :: outflow_grid           !! Type of outflow on the grid box (unitless)
    INTEGER(i_std), DIMENSION(nbpt)            :: nbcoastal              !!
    INTEGER(i_std), DIMENSION(nbpt,nwbas)      :: coastal_basin          !!
    !
    INTEGER(i_std)                             :: ij, iz                 !! Indices (unitless)
    CHARACTER(LEN=4)                           :: hierar_method = 'OUTP' !!

!_ ================================================================================================================================
    !
    !
    DO ij=1, nb_basin
       !
       ! Count the basins and keep their ID
       !
       basin_count(ib) = basin_count(ib)+1
       if (basin_count(ib) > nwbas) then 
          WRITE(numout,*) 'ib=',ib
          call ipslerr_p(3,'routing_globalize', &
               &      'Problem with basin_count : ', & 
               &      'It is greater than number of allocated basin nwbas.', &
               &      '(stop to count basins)')
       endif 
       basin_id(ib,basin_count(ib)) = basin_inbxid(ij)
       !
       ! Transfer the list of basins which flow into the ocean as coastal flow.
       !
       IF ( basin_id(ib,basin_count(ib)) .LT. 0) THEN
          nbcoastal(ib) = basin_sz(ij)
          coastal_basin(ib,1:nbcoastal(ib)) = coast_pts(1:nbcoastal(ib))
       ENDIF
       !
       !
       ! Compute the area of the basin
       !
       basin_area(ib,ij) = zero
       basin_hierarchy(ib,ij) = zero
       !
       SELECT CASE (hierar_method)
          !
          CASE("MINI")
             basin_hierarchy(ib,ij) = undef_sechiba
          !
       END SELECT
       basin_topoind(ib,ij) = zero
       !
       DO iz=1,basin_sz(ij)
          !
          basin_area(ib,ij) = basin_area(ib,ij) + area_bx(basin_pts(ij,iz,1),basin_pts(ij,iz,2))
          basin_topoind(ib,ij) = basin_topoind(ib,ij) + topoind_bx(basin_pts(ij,iz,1),basin_pts(ij,iz,2))
          !
          ! There are a number of ways to determine the hierarchy of the entire basin.
          ! We allow for three here :
          !     - Take the mean value
          !     - Take the minimum value within the basin
          !     - Take the value at the outflow point
          ! Probably taking the value of the outflow point is the best solution.
          !
          SELECT CASE (hierar_method)
             !
             CASE("MEAN")
                ! Mean hierarchy of the basin
                basin_hierarchy(ib,ij) = basin_hierarchy(ib,ij) + &
                     & hierarchy_bx(basin_pts(ij,iz,1),basin_pts(ij,iz,2))
             CASE("MINI")
                ! The smallest value of the basin
                IF ( hierarchy_bx(basin_pts(ij,iz,1),basin_pts(ij,iz,2)) .LT. basin_hierarchy(ib,ij)) THEN
                   basin_hierarchy(ib,ij) = hierarchy_bx(basin_pts(ij,iz,1),basin_pts(ij,iz,2))
                ENDIF
             CASE("OUTP")
                ! Value at the outflow point
                IF ( trip_bx(basin_pts(ij,iz,1),basin_pts(ij,iz,2)) .GT. 100 ) THEN
                   basin_hierarchy(ib,ij) = hierarchy_bx(basin_pts(ij,iz,1),basin_pts(ij,iz,2))
                ENDIF
             CASE DEFAULT
                WRITE(numout,*) 'Unknown method for computing the hierarchy of the basin'
                CALL ipslerr_p(3,'routing_globalize','Unknown method for computing the hierarchy of the basin','','')
          END SELECT
          !
       ENDDO
       !
       basin_topoind(ib,ij) = basin_topoind(ib,ij)/REAL(basin_sz(ij),r_std)
       !
       SELECT CASE (hierar_method)
          !
          CASE("MEAN")
             basin_hierarchy(ib,ij) = basin_hierarchy(ib,ij)/REAL(basin_sz(ij),r_std)
          !
       END SELECT
       !
       ! To make sure that it has the lowest number if this is an outflow point we reset  basin_hierarchy
       !
       IF (basin_bxout(ij) .LT. 0) THEN
          basin_hierarchy(ib,ij) = min_topoind
          basin_topoind(ib,ij) = min_topoind
       ENDIF
       !
       !
       ! Keep the outflow boxes and basin
       !
       basin_flowdir(ib,ij) = basin_bxout(ij)
       IF (basin_bxout(ij) .GT. 0) THEN
          outflow_grid(ib,ij) = neighbours(ib,basin_bxout(ij))
       ELSE
          outflow_grid(ib,ij) = basin_bxout(ij)
       ENDIF
       !
       !
    ENDDO
    !

    !
  END SUBROUTINE routing_globalize
  !
!! ================================================================================================================================
!! SUBROUTINE   : routing_linkup
!!
!>\BRIEF         This subroutine makes the connections between the basins and ensure global coherence. 
!!
!! DESCRIPTION (definitions, functional, design, flags) :
!! The convention for outflow_grid is :
!! outflow_grid = -1 : River flow
!! outflow_grid = -2 : Coastal flow
!! outflow_grid = -3 : Return flow\n
!!
!! RECENT CHANGE(S): None
!!
!! MAIN OUTPUT VARIABLE(S):
!!
!! REFERENCES   : None
!!
!! FLOWCHART    : None
!! \n
!_ ================================================================================================================================

SUBROUTINE routing_linkup(nbpt, contfrac, neighbours, nwbas, basin_count, basin_area, basin_id, basin_flowdir, &
       & basin_hierarchy, outflow_grid, outflow_basin, inflow_number, inflow_grid, inflow_basin, nbcoastal,&
       & coastal_basin, invented_basins)
    !
    IMPLICIT NONE
    !
!! INPUT VARIABLES
    INTEGER(i_std), INTENT (in)                    :: nbpt                  !! Domain size  (unitless)
    REAL(r_std), DIMENSION(nbpt)                   :: contfrac
    INTEGER(i_std), DIMENSION(nbpt,NbNeighb), INTENT (in) :: neighbours            !!
    REAL(r_std), INTENT(in)                        :: invented_basins       !!
    !
    INTEGER(i_std)                                 :: nwbas                 !!
    INTEGER(i_std), DIMENSION(nbpt)                :: basin_count           !!
    INTEGER(i_std), DIMENSION(nbpt,nwbas)          :: basin_id              !!
    INTEGER(i_std), DIMENSION(nbpt,nwbas)          :: basin_flowdir         !! Water flow directions in the basin (unitless)
    REAL(r_std), DIMENSION(nbpt,nwbas)             :: basin_area            !!
    REAL(r_std), DIMENSION(nbpt,nwbas)             :: basin_hierarchy       !!
    INTEGER(i_std), DIMENSION(nbpt,nwbas)          :: outflow_grid          !! Type of outflow on the grid box (unitless)
    INTEGER(i_std), DIMENSION(nbpt,nwbas)          :: outflow_basin         !!
    INTEGER(i_std), DIMENSION(nbpt,nwbas)          :: inflow_number         !!
    INTEGER(i_std), DIMENSION(nbpt,nwbas,nbvmax)   :: inflow_basin          !!
    INTEGER(i_std), DIMENSION(nbpt,nwbas,nbvmax)   :: inflow_grid           !!
    INTEGER(i_std), DIMENSION(nbpt)                :: nbcoastal             !!
    INTEGER(i_std), DIMENSION(nbpt,nwbas)          :: coastal_basin         !!
    !
!! LOCAL VARIABLES
    INTEGER(i_std)                                 :: sp, sb, sbl, inp, bid, outdm1, outdp1 !! Indices (unitless)
    INTEGER(i_std)                                 :: dp1, dm1, dm1i, dp1i, bp1, bm1 !! Indices (unitless)
    INTEGER(i_std)                                 :: dop, bop              !!
    INTEGER(i_std)                                 :: fbas(nwbas), nbfbas   !!
    REAL(r_std)                                    :: fbas_hierarchy(nwbas) !!
    REAL(r_std)                                    :: angle
    INTEGER(i_std)                                 :: ff(1)                 !!
    !
    ! ERRORS 
    LOGICAL                                        :: error1, error2, error3, error4, error5 !! (true/false)
    !
!! PARAMETERS
    LOGICAL, PARAMETER                             :: check = .TRUE.       !! (true/false)

!_ ================================================================================================================================    
    error1=.FALSE.
    error2=.FALSE.
    error3=.FALSE.
    error4=.FALSE.
    error5=.FALSE.

    outflow_basin(:,:) = undef_int
    inflow_number(:,:) = 0
    !
    DO sp=1,nbpt
       DO sb=1,basin_count(sp)
          !
          inp = outflow_grid(sp,sb)
          bid = basin_id(sp,sb)
          !
          ! We only work on this point if it does not flow into the ocean
          ! At this point any of the outflows is designated by a negative values in
          ! outflow_grid
          !
          IF ( inp .GT. 0 ) THEN
             !
             ! Now find the basin in the onflow point (inp)
             !
             nbfbas = 0
             !
             !
             DO sbl=1,basin_count(inp)
                !
                ! Either it is a standard basin or one aggregated from ocean flow points.
                ! If we flow into a another grid box we have to make sure that its hierarchy in the
                ! basin is lower.
                !
                !
                IF ( basin_id(inp,sbl) .GT. 0 ) THEN
                   IF ( basin_id(inp,sbl) .EQ. bid .OR. basin_id(inp,sbl) .GT. invented_basins) THEN
                      nbfbas =nbfbas + 1
                      fbas(nbfbas) = sbl
                      fbas_hierarchy(nbfbas) = basin_hierarchy(inp,sbl)
                   ENDIF
                ELSE
                   IF ( COUNT(coastal_basin(inp,1:nbcoastal(inp)) .EQ. bid) .GT. 0 ) THEN
                      nbfbas =nbfbas + 1
                      fbas(nbfbas) = sbl
                      fbas_hierarchy(nbfbas) = basin_hierarchy(inp,sbl)
                   ENDIF
                ENDIF
                !
             ENDDO
             ! 
             !  If we have more than one basin we will take the one which is lowest
             !  in the hierarchy.
             !
             IF (nbfbas .GE. 1) THEN
                ff = MINLOC(fbas_hierarchy(1:nbfbas))
                sbl = fbas(ff(1))
                !
                bop = undef_int
                IF ( basin_hierarchy(inp,sbl) .LE. basin_hierarchy(sp,sb) ) THEN
                   IF ( basin_hierarchy(inp,sbl) .LT. basin_hierarchy(sp,sb) ) THEN
                      bop = sbl
                   ELSE
                      ! The same hierarchy is allowed if both grids flow in about 
                      ! the same direction :
                      IF ( ( MOD(basin_flowdir(inp,sbl)+1-1, 8)+1 .EQ. basin_flowdir(sp,sb)).OR. &
                           & ( basin_flowdir(inp,sbl) .EQ. basin_flowdir(sp,sb)).OR. &
                           & ( MOD(basin_flowdir(inp,sbl)+7-1, 8)+1 .EQ. basin_flowdir(sp,sb)) ) THEN
                         bop = sbl
                      ENDIF
                   ENDIF
                ENDIF
                !
                ! If the basin is suitable (bop < undef_int) then take it
                !
                IF ( bop .LT. undef_int ) THEN
                   outflow_basin(sp,sb) = bop
                   inflow_number(inp,bop) =  inflow_number(inp,bop) + 1
                   IF ( inflow_number(inp,bop) .LE. nbvmax ) THEN
                      inflow_grid(inp, bop, inflow_number(inp,bop)) = sp
                      inflow_basin(inp, bop, inflow_number(inp,bop)) = sb
                   ELSE
                      error1=.TRUE.
                      EXIT
                   ENDIF
                ENDIF
             ENDIF
             !
             !
          ENDIF
          !
          !
          !
          ! Did we find it ?
          !
          ! In case the outflow point was ocean or we did not find the correct basin we start to look
          ! around. We find two options for the outflow direction (dp1 & dm1) and the corresponding 
          ! basin index (bp1 & bm1).
          !
          !
          IF ( outflow_basin(sp,sb) .EQ. undef_int &
               & .AND. basin_flowdir(sp,sb) .GT. 0) THEN
             !
             dp1i = MOD(basin_flowdir(sp,sb)+1-1, NbNeighb)+1
             dp1 = neighbours(sp,dp1i)
             dm1i = MOD(basin_flowdir(sp,sb)+7-1, NbNeighb)+1
             IF ( dm1i .LT. 1 ) dm1i = 8
             dm1 = neighbours(sp,dm1i)
             !
             !
             bp1 = -1
             IF ( dp1 .GT. 0 ) THEN
                DO sbl=1,basin_count(dp1)
                   IF (basin_id(dp1,sbl) .EQ. bid .AND.&
                        & basin_hierarchy(sp,sb) .GE. basin_hierarchy(dp1,sbl) .AND. &
                        & bp1 .LT. 0) THEN
                      IF ( basin_hierarchy(sp,sb) .GT. basin_hierarchy(dp1,sbl) ) THEN
                         bp1 = sbl
                      ELSE
                         ! The same hierarchy is allowed if both grids flow in about 
                         ! the same direction :
                         angle=MODULO(basin_flowdir(dp1,sbl)-basin_flowdir(sp,sb)+8,8)
                         IF ( angle >= 4 ) angle = angle-8
                         !
                         IF ( ABS(angle) <= 1 ) THEN
                            bp1 = sbl
                         ENDIF
                      ENDIF
                   ENDIF
                ENDDO
             ENDIF
             !
             bm1 = -1
             IF ( dm1 .GT. 0 ) THEN
                DO sbl=1,basin_count(dm1)
                   IF (basin_id(dm1,sbl) .EQ. bid .AND.&
                        & basin_hierarchy(sp,sb) .GE. basin_hierarchy(dm1,sbl) .AND. &
                        & bm1 .LT. 0) THEN
                      IF ( basin_hierarchy(sp,sb) .GT. basin_hierarchy(dm1,sbl) ) THEN
                         bm1 = sbl
                      ELSE                         
                         ! The same hierarchy is allowed if both grids flow in about 
                         ! the same direction :
                         angle=MODULO(basin_flowdir(dm1,sbl)-basin_flowdir(sp,sb)+8,8)
                         IF ( angle >= 4 ) angle = angle-8
                         !
                         IF ( ABS(angle) <= 1 ) THEN
                            bm1 = sbl
                         ENDIF
                      ENDIF
                   ENDIF
                ENDDO
             ENDIF
             !
             !
             ! First deal with the case on land.
             !
             ! For that we need to check if the water will be able to flow out of the grid dp1 or dm1 
             ! and not return to our current grid. If it is the current grid
             ! then we can not do anything with that neighbour. Thus we set the
             ! value of outdm1 and outdp1 back to -1
             !
             outdp1 = undef_int
             IF ( dp1 .GT. 0 .AND. bp1 .GT. 0 ) THEN
                ! if the outflow is into the ocean then we put something less than undef_int in outdp1!
                IF (basin_flowdir(dp1,bp1) .GT. 0) THEN
                   outdp1 = neighbours(dp1,basin_flowdir(dp1,bp1))
                   IF ( outdp1 .EQ. sp ) outdp1 = undef_int 
                ELSE
                   outdp1 = nbpt + 1
                ENDIF
             ENDIF
             outdm1 = undef_int
             IF ( dm1 .GT. 0 .AND. bm1 .GT. 0 ) THEN
                IF (basin_flowdir(dm1,bm1) .GT. 0) THEN
                   outdm1 = neighbours(dm1,basin_flowdir(dm1,bm1))
                   IF ( outdm1 .EQ. sp )  outdm1 = undef_int
                ELSE
                   outdm1 = nbpt + 1
                ENDIF
             ENDIF
             !
             ! Now that we know our options we need go through them.
             !
             dop = undef_int
             bop = undef_int
             IF ( outdp1 .LT. undef_int .AND. outdm1 .LT. undef_int) THEN
                ! 
                ! In this case we let the current basin flow into the smaller one
                !
                IF ( basin_area(dp1,bp1) .LT.  basin_area(dm1,bm1) ) THEN
                   dop = dp1
                   bop = bp1
                ELSE
                   dop = dm1
                   bop = bm1
                ENDIF
                !
                !
             ELSE IF (  outdp1 .LT. undef_int ) THEN
                ! If only the first one is possible
                dop = dp1
                bop = bp1
             ELSE IF ( outdm1 .LT. undef_int ) THEN
                ! If only the second one is possible
                dop = dm1
                bop = bm1
             ELSE
                !
                ! Now we are at the point where none of the neighboring points is suitable 
                ! or we have a coastal point.
                !
                ! If there is an option to put the water into the ocean go for it.
                !
                IF ( outflow_grid(sp,sb) .LT. 0 .OR. dm1 .LT. 0 .OR. dp1 .LT. 0 ) THEN
                   dop = -1
                ELSE
                   !
                   ! If we are on a land point with only land neighbors but no one suitable to let the 
                   ! water flow into we have to look for a solution in the current grid box.
                   ! 
                   !
                   IF ( bp1 .LT. 0 .AND. bm1 .LT. 0 ) THEN
                      !
                      ! Do we have more than one basin with the same ID ?
                      !
                      IF ( COUNT(basin_id(sp,1:basin_count(sp)) .EQ. bid) .GE. 2) THEN
                         !
                         ! Now we can try the option of flowing into the basin of the same grid box.
                         !
                         DO sbl=1,basin_count(sp)
                            IF (sbl .NE. sb .AND. basin_id(sp,sbl) .EQ. bid) THEN
                               ! In case this basin has a lower hierarchy or flows into a totaly
                               ! different direction we go for it.
                               IF ( (basin_hierarchy(sp,sb) .GE. basin_hierarchy(sp,sbl)) .OR. &
                                    & (basin_flowdir(sp,sbl) .LT. dm1i .AND.&
                                    & basin_flowdir(sp,sbl) .GT. dp1i) ) THEN
                                  dop = sp
                                  bop = sbl
                                  IF (check) THEN
                                     IF (basin_hierarchy(sp,sb) .LT. basin_hierarchy(sp,sbl)) THEN
                                        WRITE(numout,*) '>>>>>>> POINT CORRECTED against hierarchy :',&
                                             & sp, sb, 'into', sbl
                                     ENDIF
                                  ENDIF
                               ENDIF
                               !
                            ENDIF
                         ENDDO
                         !
                      ENDIF
                   ENDIF
                ENDIF
                !
                IF ( dop .EQ. undef_int .AND. bop .EQ. undef_int ) THEN
                   IF (check) THEN
                      WRITE(numout,*) 'Why are we here with point ', sp, sb
                      WRITE(numout,*) 'Coordinates : (lon,lat) = ', lalo_g(sp,2), lalo_g(sp,1)
                      WRITE(numout,*) 'neighbours :', neighbours_g(sp,:)
                      WRITE(numout,*) 'Contfrac : = ', contfrac(sp)
                      WRITE(numout,*) 'Local Basin ID :', basin_id(sp,1:basin_count(sp))
                      WRITE(numout,*) 'Local hierarchies :', basin_hierarchy(sp,1:basin_count(sp))
                      WRITE(numout,*) 'Local basin_flowdir :', basin_flowdir(sp,1:basin_count(sp))
                      WRITE(numout,*) 'Local outflowgrid :', outflow_grid(sp,1:basin_count(sp))
                      WRITE(numout,*) 'outflow_grid :', inp
                      WRITE(numout,*) 'Coodinates outflow : (lon,lat) = ', lalo_g(inp,2), lalo_g(inp,1)
                      WRITE(numout,*) 'Contfrac : = ', contfrac(inp)
                      WRITE(numout,*) 'Outflow Basin ID :', basin_id(inp,1:basin_count(inp))
                      WRITE(numout,*) 'Outflow hierarchies :', basin_hierarchy(inp,1:basin_count(inp))
                      WRITE(numout,*) 'Outflow basin_flowdir :', basin_flowdir(inp,1:basin_count(inp))
                      WRITE(numout,*) 'Explored options +1 :', dp1, bp1, outdp1
                      WRITE(numout,*) 'Explored +1 Basin ID :', basin_id(dp1,1:basin_count(dp1))
                      WRITE(numout,*) 'Explored +1 hierarchies :', basin_hierarchy(dp1,1:basin_count(dp1))
                      WRITE(numout,*) 'Explored +1 basin_flowdir :', basin_flowdir(dp1,1:basin_count(dp1))
                      WRITE(numout,*) 'Explored options -1 :', dm1, bm1, outdm1
                      WRITE(numout,*) 'Explored -1 Basin ID :', basin_id(dm1,1:basin_count(dm1))
                      WRITE(numout,*) 'Explored -1 hierarchies :', basin_hierarchy(dm1,1:basin_count(dm1))
                      WRITE(numout,*) 'Explored -1 basin_flowdir :', basin_flowdir(dm1,1:basin_count(dm1))
                      WRITE(numout,*) '****************************'
                      CALL FLUSH(numout)
                   ENDIF
                   IF ( contfrac(sp) > 0.01 ) THEN
                      error2=.TRUE.
                      EXIT
                   ENDIF
                ENDIF
                !
             ENDIF
             !
             ! Now that we know where we want the water to flow to we write the
             ! the information in the right fields.
             !
             IF ( dop .GT. 0 .AND. dop .NE. undef_int ) THEN
                outflow_grid(sp,sb) = dop
                outflow_basin(sp,sb) = bop
                inflow_number(dop,bop) =  inflow_number(dop,bop) + 1
                IF ( inflow_number(dop,bop) .LE. nbvmax ) THEN
                   inflow_grid(dop, bop, inflow_number(dop,bop)) = sp
                   inflow_basin(dop, bop, inflow_number(dop,bop)) = sb
                ELSE
                   error3=.TRUE.
                   EXIT
                ENDIF
                !
             ELSE
                outflow_grid(sp,sb) = -2
                outflow_basin(sp,sb) = undef_int
             ENDIF
             !
          ENDIF
          !
          !
          ! If we still have not found anything then we have to check that there is not a basin
          ! within the same grid box which has a lower hierarchy.
          !
          !
          IF ( outflow_grid(sp,sb) .GT. 0 .AND. outflow_basin(sp,sb) .EQ. undef_int &
               & .AND. basin_flowdir(sp,sb) .GT. 0) THEN
             !
             
             IF (check) &
                  WRITE(numout,*) 'There is no reason to here, this part of the code should be dead :', sp,sb
             !
             DO sbl=1,basin_count(sp)
                !
                ! Three conditions are needed to let the water flow into another basin of the
                ! same grid :
                ! - another basin than the current one
                ! - same ID
                ! - of lower hierarchy.
                !
                IF ( (sbl .NE. sb) .AND. (basin_id(sp,sbl) .EQ. bid)&
                     & .AND. (basin_hierarchy(sp,sb) .GT. basin_hierarchy(sp,sbl)) ) THEN
                   outflow_basin(sp,sb) = sbl
                   inflow_number(sp,sbl) =  inflow_number(sp,sbl) + 1
                   IF ( inflow_number(sp,sbl) .LE. nbvmax ) THEN
                      IF ( sp .EQ. 42 .AND. sbl .EQ. 1) THEN
                         IF (check) &
                              WRITE(numout,*) 'ADD INFLOW (3):', sp, sb
                      ENDIF
                      inflow_grid(sp, sbl, inflow_number(sp,sbl)) = sp
                      inflow_basin(sp, sbl, inflow_number(sp,sbl)) = sb
                   ELSE
                      error4=.TRUE.
                      EXIT
                   ENDIF
                ENDIF
             ENDDO
          ENDIF
          !
          ! Ok that is it, we give up :-)
          !
          IF ( outflow_grid(sp,sb) .GT. 0 .AND. outflow_basin(sp,sb) .EQ. undef_int &
               & .AND. basin_flowdir(sp,sb) .GT. 0) THEN
             !
             error5=.TRUE.
             EXIT
          ENDIF
       ENDDO
       !
    ENDDO
    IF (error1) THEN
       WRITE(numout,*) " routing_linkup : bop .LT. undef_int",bop
       CALL ipslerr_p(3,'routing_linkup', &
            "bop .LT. undef_int",'Increase nbvmax','stop routing_linkup')
    ENDIF
    IF (error2) THEN
       CALL ipslerr_p(3,'routing_linkup', &
            &      'In the routine which make connections between the basins and ensure global coherence,', & 
            &      'there is a problem with outflow linkup without any valid direction. Try with check=.TRUE.', &
            &      '(Perhaps there is a problem with the grid.)')
    ENDIF
    IF (error3) THEN
       WRITE(numout,*) " routing_linkup : dop .GT. 0 .AND. dop .NE. undef_int",dop
       CALL ipslerr_p(3,'routing_linkup', &
            "dop .GT. 0 .AND. dop .NE. undef_int",'Increase nbvmax. Try with check=.TRUE.','stop routing_linkup')
    ENDIF
    IF (error4) THEN
       WRITE(numout,*) " routing_linkup : (sbl .NE. sb) .AND. (basin_id(sp,sbl) .EQ. bid) ", & 
            &  " .AND. (basin_hierarchy(sp,sb) .GT. basin_hierarchy(sp,sbl))",sbl,sb,basin_id(sp,sbl),bid, & 
            &  basin_hierarchy(sp,sb),basin_hierarchy(sp,sbl)
       CALL ipslerr_p(3,'routing_linkup', &
            "(sbl .NE. sb) .AND. (basin_id(sp,sbl) .EQ. bid) .AND. (basin_hierarchy(sp,sb) .GT. basin_hierarchy(sp,sbl))" &
            ,'Increase nbvmax. Try with check=.TRUE.','stop routing_linkup')
    ENDIF
    IF (error5) THEN
       WRITE(numout,*) 'We could not find the basin into which we need to flow'
       WRITE(numout,*) 'Grid point ', sp, ' and basin ', sb
       WRITE(numout,*) 'Explored neighbours :', dm1, dp1 
       WRITE(numout,*) 'Outflow direction :', basin_flowdir(sp,sb)
       WRITE(numout,*) 'Outlfow grid :', outflow_grid(sp,sb)
       WRITE(numout,*) 'Outlfow basin :',outflow_basin(sp,sb)
       WRITE(numout,*) 'basin ID:',basin_id(sp,sb)
       WRITE(numout,*) 'Hierarchy :', basin_hierarchy(sp,sb)
       CALL ipslerr_p(3,'routing_linkup', &
            "We could not find the basin into which we need to flow",'Try with check=.TRUE.','stop routing_linkup')
    ENDIF
    !
    ! Check for each outflow basin that it exists
    !
    DO sp=1,nbpt
       DO sb=1,basin_count(sp)
          !
          inp = outflow_grid(sp,sb)
          sbl = outflow_basin(sp,sb)
          IF ( inp .GE. 0 ) THEN
             IF ( basin_count(inp) .LT. sbl ) THEN
                WRITE(numout,*) 'point :', sp, ' basin :', sb
                WRITE(numout,*) 'Flows into point :', inp, ' basin :', sbl
                WRITE(numout,*) 'But it flows into now here as basin count = ', basin_count(inp)
                CALL ipslerr_p(3,'routing_linkup','Problem with outflow','','')
             ENDIF
          ENDIF
       ENDDO
    ENDDO
    !
  END SUBROUTINE routing_linkup
  !
!! ================================================================================================================================
!! SUBROUTINE   : routing_fetch
!!
!>\BRIEF        This subroutine computes the fetch of each basin. This means that for each basin we
!!               will know how much area is upstream. It will help decide how to procede with the
!!               the truncation later and allow to set correctly in outflow_grid the distinction
!!               between coastal and river flow. 
!!
!! DESCRIPTION (definitions, functional, design, flags) : None
!!
!! RECENT CHANGE(S): None
!!
!! MAIN OUTPUT VARIABLE(S):
!!
!! REFERENCES   : None
!!
!! FLOWCHART    : None
!! \n
!_ ================================================================================================================================

SUBROUTINE routing_fetch(nbpt, resolution, contfrac, nwbas, basin_count, basin_area, basin_id,&
       & outflow_grid, outflow_basin, fetch_basin)
    !
    IMPLICIT NONE
    !
!! INPUT VARIABLES
    INTEGER(i_std), INTENT(in)                           :: nbpt          !! Domain size  (unitless)
    !
    REAL(r_std), DIMENSION(nbpt,2), INTENT(in)           :: resolution    !! The size of each grid box in X and Y (m)
    REAL(r_std), DIMENSION(nbpt), INTENT(in)             :: contfrac      !! Fraction of land in each grid box (unitless;0-1)
    !
    INTEGER(i_std)                                       :: nwbas         !!
    INTEGER(i_std), DIMENSION(nbpt), INTENT(in)          :: basin_count   !!
    REAL(r_std), DIMENSION(nbpt,nwbas), INTENT(inout)    :: basin_area    !!
    INTEGER(i_std), DIMENSION(nbpt,nwbas), INTENT(in)    :: basin_id      !!
    INTEGER(i_std), DIMENSION(nbpt,nwbas), INTENT(inout) :: outflow_grid  !! Type of outflow on the grid box (unitless)
    INTEGER(i_std), DIMENSION(nbpt,nwbas), INTENT(in)    :: outflow_basin !!
!
!! OUTPUT VARIABLES
    REAL(r_std), DIMENSION(nbpt,nwbas), INTENT(out)      :: fetch_basin   !!
    !
!! LOCAL VARIABLES
    INTEGER(i_std)                                        :: ib, ij, ff(1), it, itt, igrif, ibasf, nboutflow !! Indices (unitless)
    REAL(r_std)                                           :: contarea     !!
    REAL(r_std)                                           :: totbasins    !!
    REAL(r_std), DIMENSION(nbpt*nbvmax)                   :: tmp_area     !!
    INTEGER(i_std), DIMENSION(nbpt*nbvmax,2)              :: tmpindex     !!

!_ ================================================================================================================================
    !
    !
    ! Normalize the area of all basins
    !
    DO ib=1,nbpt
       !
       totbasins = SUM(basin_area(ib,1:basin_count(ib)))
       contarea = resolution(ib,1)*resolution(ib,2)*contfrac(ib)
       !
       DO ij=1,basin_count(ib)
          basin_area(ib,ij) = basin_area(ib,ij)/totbasins*contarea
       ENDDO
       !
    ENDDO
    WRITE(numout,*) 'Normalization done'
    !
    ! Compute the area upstream of each basin
    !
    fetch_basin(:,:) = zero
    !
    !
    DO ib=1,nbpt
       !
       DO ij=1,basin_count(ib)
          !
          fetch_basin(ib, ij) = fetch_basin(ib, ij) + basin_area(ib,ij)
          !
          igrif = outflow_grid(ib,ij)
          ibasf = outflow_basin(ib,ij)
          !
          itt = 0
          DO WHILE (igrif .GT. 0)
             fetch_basin(igrif,ibasf) =  fetch_basin(igrif,ibasf) + basin_area(ib, ij)
             it = outflow_grid(igrif, ibasf)
             ibasf = outflow_basin(igrif, ibasf)
             igrif = it
             itt = itt + 1
             IF ( itt .GT. 500) THEN
                WRITE(numout,&
                     "('Grid ',I5, ' and basin ',I5, 'did not converge after iteration ',I5)") ib, ij, itt
                WRITE(numout,*) 'Basin ID :', basin_id(igrif,ibasf)
                WRITE(numout,&
                     "('We are stuck with the flow into grid ',I5,' and basin ',I5)") igrif, ibasf
                WRITE(numout,*) "Coordinates : ", lalo_g(igrif,2), lalo_g(igrif,1)
                IF ( itt .GT. 510) THEN
                   CALL ipslerr_p(3,'routing_fetch','Problem...','','')
                ENDIF
             ENDIF
          ENDDO
          !
       ENDDO
       !
    ENDDO
    !
    WRITE(numout,*) 'The smallest FETCH :', MINVAL(fetch_basin)
    WRITE(numout,*) 'The largest FETCH :', MAXVAL(fetch_basin)
    !
    ! Now we set for the 'num_largest' largest basins the outflow condition as stream flow 
    ! (i.e. outflow_grid = -1) and all other outflow basins are set to coastal flow 
    ! (i.e. outflow_grid = -2). The return flow is not touched.
    !
    nboutflow = 0
    !
    DO ib=1,nbpt
       !
       DO ij=1,basin_count(ib)
          !
          ! We do not need any more the river flow flag as we are going to reset it.
          !
          IF ( outflow_grid(ib,ij) .EQ. -1) THEN
             outflow_grid(ib,ij) = -2
          ENDIF
          !
          IF ( outflow_grid(ib,ij) .EQ. -2) THEN
             !
             nboutflow = nboutflow + 1
             tmp_area(nboutflow) = fetch_basin(ib,ij)
             tmpindex(nboutflow,1) = ib
             tmpindex(nboutflow,2) = ij
             !
          ENDIF
          !
       ENDDO
    ENDDO
    !
    DO ib=1, num_largest
       ff = MAXLOC(tmp_area(1:nboutflow))
       outflow_grid(tmpindex(ff(1),1), tmpindex(ff(1),2)) = -1
       tmp_area(ff(1)) = zero
    ENDDO
    !
  END SUBROUTINE routing_fetch
  !
!! ================================================================================================================================
!! SUBROUTINE   : routing_truncate
!!
!>\BRIEF         This subroutine reduces the number of basins per grid to the value chosen by the user.
!!               It also computes the final field which will be used to route the water at the
!!               requested truncation.  
!!
!! DESCRIPTION (definitions, functional, design, flags) : 
!! Truncate if needed and find the path closest to the high resolution data.
!!
!! The algorithm :
!! 
!! We only go through this procedure only as many times as there are basins to take out at most.
!! This is important as it allows the simplifications to spread from one grid to the other.
!! The for each step of the iteration and at each grid point we check the following options for 
!! simplifying the pathways of water :
!! 1) If the basin of a grid flows into another basin of the same grid. Kill the one which only
!!    served as a transition
!! 2) If in one grid box we have a number of basins which flow into the ocean as coastal flow. 
!!    We kill the smallest one and put into the largest basin. There is no need to manage many 
!!    basins going into the ocean as coastal flows. 
!! 3) If we have streams run in parallel from one gird box to the others (that is these are 
!!    different basins) we will put the smaller one in the larger one. This may hapen at any
!!    level of the flow but in theory it should propagate downstream.
!! 4) If we have two basins with the same ID but flow into different grid boxes we sacrifice
!!    the smallest one and route it through the largest. 
!!
!! Obviously if any of the options find something then we skip the rest and take out the basin.:\n
!!
!! RECENT CHANGE(S): None
!!
!! MAIN OUTPUT VARIABLE(S):
!!
!! REFERENCES   : None
!!
!! FLOWCHART    : None
!! \n
!_ ================================================================================================================================

SUBROUTINE routing_truncate(nbpt, resolution, contfrac, nwbas, basin_count, basin_area, basin_topoind,&
       & fetch_basin, basin_id, basin_flowdir, outflow_grid, outflow_basin, inflow_number,&
       & inflow_grid, inflow_basin)
    !
    IMPLICIT NONE
    !
!! PARAMETERS
    INTEGER(i_std), PARAMETER                       :: pickmax = 200  !!

!! INPUT VARIABLES
    INTEGER(i_std)                                  :: nbpt           !! Domain size  (unitless)
    !
    REAL(r_std), DIMENSION(nbpt,2)                  :: resolution     !! The size of each grid box in X and Y (m)
    REAL(r_std), DIMENSION(nbpt), INTENT(in)        :: contfrac       !! Fraction of land in each grid box (unitless;0-1)
    !
    INTEGER(i_std)                                  :: nwbas          !!
    INTEGER(i_std), DIMENSION(nbpt)                 :: basin_count    !!
    INTEGER(i_std), DIMENSION(nbpt,nwbas)           :: basin_id       !!
    INTEGER(i_std), DIMENSION(nbpt,nwbas)           :: basin_flowdir  !! Water flow directions in the basin (unitless)
    REAL(r_std), DIMENSION(nbpt,nwbas)              :: basin_area     !!
    REAL(r_std), DIMENSION(nbpt,nwbas)              :: basin_topoind  !! Topographic index of the residence time for a basin (m)
    REAL(r_std), DIMENSION(nbpt,nwbas)              :: fetch_basin    !!
    INTEGER(i_std), DIMENSION(nbpt,nwbas)           :: outflow_grid   !! Type of outflow on the grid box (unitless)
    INTEGER(i_std), DIMENSION(nbpt,nwbas)           :: outflow_basin  !!
    INTEGER(i_std), DIMENSION(nbpt,nwbas)           :: inflow_number  !!
    INTEGER(i_std), DIMENSION(nbpt,nwbas,nwbas)     :: inflow_basin   !!
    INTEGER(i_std), DIMENSION(nbpt,nwbas,nwbas)     :: inflow_grid    !!
    !
!! LOCAL VARIABLES
    INTEGER(i_std)                                  :: ib, ij, ibf, ijf, igrif, ibasf, cnt, pold, bold, ff(2) !! Indices (unitless)
    INTEGER(i_std)                                  :: ii, kbas, sbas, ik, iter, ibt, obj !! Indices (unitless)
    REAL(r_std), DIMENSION(nbpt,nbasmax)            :: floflo         !!
    REAL(r_std), DIMENSION(nbpt)                    :: gridarea       !!
    REAL(r_std), DIMENSION(nbpt)                    :: gridbasinarea  !!
    REAL(r_std)                                     :: ratio          !!
    INTEGER(i_std), DIMENSION(pickmax,2)            :: largest_basins !!
    INTEGER(i_std), DIMENSION(pickmax)              :: tmp_ids        !!
    INTEGER(i_std)                                  :: multbas        !!
    INTEGER(i_std)                                  :: iml(1)         !! X resolution of the high resolution grid
    INTEGER(i_std), DIMENSION(pickmax)              :: multbas_sz     !!
    REAL(r_std), DIMENSION(pickmax)                 :: tmp_area       !!
    INTEGER(i_std), DIMENSION(pickmax,pickmax)      :: multbas_list   !!
    !
    INTEGER(i_std)                                  :: nbtruncate     !!
    INTEGER(i_std), SAVE, ALLOCATABLE, DIMENSION(:) :: indextrunc     !!
!$OMP THREADPRIVATE(indextrunc)

!_ ================================================================================================================================
    !
    !
    IF ( .NOT. ALLOCATED(indextrunc)) THEN
       ALLOCATE(indextrunc(nbpt))
    ENDIF
    !
    ! We have to go through the grid as least as often as we have to reduce the number of basins
    ! For good measure we add 3 more passages.
    !
    !
    DO iter = 1, MAXVAL(basin_count) - nbasmax +3
       !
       ! Get the points over which we wish to truncate
       !
       nbtruncate = 0
       DO ib = 1, nbpt
          IF ( basin_count(ib) .GT. nbasmax ) THEN
             nbtruncate = nbtruncate + 1
             indextrunc(nbtruncate) = ib
          ENDIF
       ENDDO
       !
       ! Go through the basins which need to be truncated.       
       !
       DO ibt=1,nbtruncate
          !
          ib = indextrunc(ibt)
          !
          ! Check if we have basin which flows into a basin in the same grid
          ! kbas = basin we will have to kill
          ! sbas = basin which takes over kbas
          !
          kbas = 0
          sbas = 0
          !
          ! 1) Can we find a basin which flows into a basin of the same grid ?
          !
          DO ij=1,basin_count(ib)
             DO ii=1,basin_count(ib)
                IF ( outflow_grid(ib,ii) .EQ. ib .AND. outflow_basin(ib, ii) .EQ. ij .AND. kbas*sbas .NE. 0) THEN
                   kbas = ii
                   sbas = ij
                ENDIF
             ENDDO
          ENDDO
          !
          ! 2) Merge two basins which flow into the ocean as coastal or return flow 
          ! (outflow_grid = -2 or -3). Well obviously only if we have more than 1 and 
          ! have not found anything yet!
          !
          IF ( (COUNT(outflow_grid(ib,1:basin_count(ib)) .EQ. -2) .GT. 1 .OR.&
               & COUNT(outflow_grid(ib,1:basin_count(ib)) .EQ. -3) .GT. 1) .AND.&
               & kbas*sbas .EQ. 0) THEN
             !
             multbas = 0
             multbas_sz(:) = 0
             !
             IF ( COUNT(outflow_grid(ib,1:basin_count(ib)) .EQ. -2) .GT. 1 ) THEN
                obj = -2
             ELSE
                obj = -3
             ENDIF
             !
             ! First we get the list of all basins which go out as coastal or return flow (obj)
             !
             DO ij=1,basin_count(ib)
                IF ( outflow_grid(ib,ij) .EQ. obj ) THEN
                   multbas = multbas + 1
                   multbas_sz(multbas) = ij
                   tmp_area(multbas) = fetch_basin(ib,ij)
                ENDIF
             ENDDO
             !
             ! Now the take the smallest to be transfered to the largest
             !
             iml = MAXLOC(tmp_area(1:multbas), MASK = tmp_area(1:multbas) .GT. zero)
             sbas = multbas_sz(iml(1))
             iml = MINLOC(tmp_area(1:multbas), MASK = tmp_area(1:multbas) .GT. zero)
             kbas = multbas_sz(iml(1))
             !
          ENDIF
          !
          !   3) If we have basins flowing into the same grid but different basins then we put them 
          !   together. Obviously we first work with the grid which has most streams running into it
          !   and putting the smallest in the largests catchments.
          !
          IF ( kbas*sbas .EQ. 0) THEN
             !
             tmp_ids(1:basin_count(ib)) = outflow_grid(ib,1:basin_count(ib))
             multbas = 0
             multbas_sz(:) = 0
             !
             ! First obtain the list of basins which flow into the same basin
             !
             DO ij=1,basin_count(ib)
                IF ( outflow_grid(ib,ij) .GT. 0 .AND.&
                     & COUNT(tmp_ids(1:basin_count(ib)) .EQ. outflow_grid(ib,ij)) .GT. 1) THEN
                   multbas = multbas + 1
                   DO ii=1,basin_count(ib)
                      IF ( tmp_ids(ii) .EQ. outflow_grid(ib,ij)) THEN
                         multbas_sz(multbas) = multbas_sz(multbas) + 1
                         multbas_list(multbas,multbas_sz(multbas)) = ii
                         tmp_ids(ii) = -99
                      ENDIF
                   ENDDO
                ELSE
                   tmp_ids(ij) = -99
                ENDIF
             ENDDO
             !
             ! Did we come up with any basins to deal with this way ?
             !
             IF ( multbas .GT. 0 ) THEN
                !
                iml = MAXLOC(multbas_sz(1:multbas))
                ik = iml(1)
                !
                ! Take the smallest and largest of these basins !
                !
                DO ii=1,multbas_sz(ik)
                   tmp_area(ii) = fetch_basin(ib, multbas_list(ik,ii))
                ENDDO
                !
                iml = MAXLOC(tmp_area(1:multbas_sz(ik)), MASK = tmp_area(1:multbas_sz(ik)) .GT. zero)
                sbas = multbas_list(ik,iml(1))
                iml = MINLOC(tmp_area(1:multbas_sz(ik)), MASK = tmp_area(1:multbas_sz(ik)) .GT. zero)
                kbas = multbas_list(ik,iml(1))
                !
             ENDIF
             !
          ENDIF
          !
          !   4) If we have twice the same basin we put them together even if they flow into different
          !   directions. If one of them goes to the ocean it takes the advantage.
          !
          IF ( kbas*sbas .EQ. 0) THEN
             !
             tmp_ids(1:basin_count(ib)) = basin_id(ib,1:basin_count(ib))
             multbas = 0
             multbas_sz(:) = 0
             !
             ! First obtain the list of basins which have sub-basins in this grid box.
             ! (these are identified by their IDs)
             !
             DO ij=1,basin_count(ib)
                IF ( COUNT(tmp_ids(1:basin_count(ib)) .EQ. basin_id(ib,ij)) .GT. 1) THEN
                   multbas = multbas + 1
                   DO ii=1,basin_count(ib)
                      IF ( tmp_ids(ii) .EQ. basin_id(ib,ij)) THEN
                         multbas_sz(multbas) = multbas_sz(multbas) + 1
                         multbas_list(multbas,multbas_sz(multbas)) = ii
                         tmp_ids(ii) = -99
                      ENDIF
                   ENDDO
                ELSE
                   tmp_ids(ij) = -99
                ENDIF
             ENDDO
             !
             ! We are going to work on the basin with the largest number of sub-basins.
             ! (IF we have a basin which has subbasins !)
             !
             IF ( multbas .GT. 0 ) THEN
                !
                iml = MAXLOC(multbas_sz(1:multbas))
                ik = iml(1)
                !
                ! If one of the basins goes to the ocean then it is going to have the priority
                !
                tmp_area(:) = zero
                IF ( COUNT(outflow_grid(ib,multbas_list(ik,1:multbas_sz(ik))) .LT. 0) .GT. 0) THEN
                   DO ii=1,multbas_sz(ik)
                      IF ( outflow_grid(ib,multbas_list(ik,ii)) .LT. 0 .AND. sbas .EQ. 0 ) THEN
                         sbas = multbas_list(ik,ii)
                      ELSE
                         tmp_area(ii) = fetch_basin(ib, multbas_list(ik,ii))
                      ENDIF
                   ENDDO
                   ! take the smallest of the subbasins
                   iml = MINLOC(tmp_area(1:multbas_sz(ik)), MASK = tmp_area(1:multbas_sz(ik)) .GT. zero)
                   kbas = multbas_list(ik,iml(1))
                ELSE
                   !
                   ! Else we take simply the largest and smallest
                   !
                   DO ii=1,multbas_sz(ik)
                      tmp_area(ii) = fetch_basin(ib, multbas_list(ik,ii))
                   ENDDO
                   iml = MAXLOC(tmp_area(1:multbas_sz(ik)), MASK = tmp_area(1:multbas_sz(ik)) .GT. zero)
                   sbas = multbas_list(ik,iml(1))
                   iml = MINLOC(tmp_area(1:multbas_sz(ik)), MASK = tmp_area(1:multbas_sz(ik)) .GT. zero)
                   kbas = multbas_list(ik,iml(1))
                   !
                ENDIF
                !
                !
             ENDIF
          ENDIF
          !
          !
          !
          ! Then we call routing_killbas to clean up the basins in this grid
          !
          IF ( kbas .GT. 0 .AND. sbas .GT. 0 ) THEN
             CALL routing_killbas(nbpt, ib, kbas, sbas, nwbas, basin_count, basin_area, basin_topoind,&
                  & fetch_basin, basin_id, basin_flowdir, outflow_grid, outflow_basin, inflow_number,&
                  & inflow_grid, inflow_basin)
          ENDIF
          !
       ENDDO
       !
       !      
    ENDDO
    !
    ! If there are any grids left with too many basins we need to take out the big hammer !
    ! We will only do it if this represents less than 5% of all points.
    !
    IF ( COUNT(basin_count .GT. nbasmax) .GT. 0 ) THEN
       !
       !
       IF ( COUNT(basin_count .GT. nbasmax)/nbpt*100 .GT. 5 ) THEN
          WRITE(numout,*) 'We have ', COUNT(basin_count .GT. nbasmax)/nbpt*100, '% of all points which do not yet'
          WRITE(numout,*) 'have the right trunctaction. That is too much to apply a brutal method'
          DO ib = 1, nbpt
             IF ( basin_count(ib) .GT. nbasmax ) THEN
                !
                WRITE(numout,*) 'We did not find a basin which could be supressed. We will'
                WRITE(numout,*) 'not be able to reduce the truncation in grid ', ib
                DO ij=1,basin_count(ib)
                   WRITE(numout,*) 'grid, basin nb and id :', ib, ij, basin_id(ib,ij)
                   WRITE(numout,*) 'Outflow grid and basin ->', outflow_grid(ib,ij), outflow_basin(ib, ij)
                ENDDO
             ENDIF
          ENDDO
          CALL ipslerr_p(3,'routing_truncate','No basin found which could be supressed.','','')
       ELSE
          !
          !
          DO ib = 1,nbpt
             DO WHILE ( basin_count(ib) .GT. nbasmax )
                !
                IF (printlev>=3) WRITE(numout,*) 'HAMMER, ib, basin_count :', ib, basin_count(ib)
                !
                ! Here we simply put the smallest basins into the largest ones. It is really a brute force
                ! method but it will only be applied if everything has failed.
                !
                DO ii = 1,basin_count(ib)
                   tmp_area(ii) = fetch_basin(ib, ii)
                ENDDO
                !
                iml = MAXLOC(tmp_area(1:basin_count(ib)), MASK = tmp_area(1:basin_count(ib)) .GT. 0.)
                sbas =iml(1)
                iml = MINLOC(tmp_area(1:basin_count(ib)), MASK = tmp_area(1:basin_count(ib)) .GT. 0.)
                kbas = iml(1)
                !
                IF ( kbas .GT. 0 .AND. sbas .GT. 0 ) THEN
                   CALL routing_killbas(nbpt, ib, kbas, sbas, nwbas, basin_count, basin_area, basin_topoind,&
                        & fetch_basin, basin_id, basin_flowdir, outflow_grid, outflow_basin, inflow_number,&
                        & inflow_grid, inflow_basin)
                ENDIF
             ENDDO
          ENDDO
          !
       ENDIF
       !
       !
    ENDIF
    !
    ! Now that we have reached the right truncation (resolution) we will start
    ! to produce the variables we will use to route the water.
    !
    DO ib=1,nbpt
       !
       ! For non existing basins the route_tobasin variable is put to zero. This will allow us
       ! to pick up the number of basin afterwards.
       !
       route_togrid(ib,:) = ib
       route_tobasin(ib,:) = 0
       routing_area(ib,:) = zero
       !
    ENDDO
    !
    ! Transfer the info into the definitive variables
    !
    DO ib=1,nbpt
       DO ij=1,basin_count(ib)
          routing_area(ib,ij) = basin_area(ib,ij)
          topo_resid(ib,ij) = basin_topoind(ib,ij)
          global_basinid(ib,ij) = basin_id(ib,ij)
          route_togrid(ib,ij) = outflow_grid(ib,ij)
          route_tobasin(ib,ij) = outflow_basin(ib,ij)
       ENDDO
    ENDDO
    !
    !
    ! Set the new convention for the outflow conditions
    ! Now it is based in the outflow basin and the outflow grid will
    ! be the same as the current.
    ! returnflow to the grid : nbasmax + 1
    ! coastal flow           : nbasmax + 2
    ! river outflow          : nbasmax + 3
    !
    ! Here we put everything here in coastal flow. It is later where we will
    ! put the largest basins into river outflow.
    !
    DO ib=1,nbpt
       DO ij=1,basin_count(ib)
          ! River flows
          IF ( route_togrid(ib,ij) .EQ. -1 ) THEN
             route_tobasin(ib,ij) = nbasmax + 2
             route_togrid(ib,ij) = ib
          ! Coastal flows
          ELSE IF ( route_togrid(ib,ij) .EQ. -2 ) THEN
             route_tobasin(ib,ij) = nbasmax + 2
             route_togrid(ib,ij) = ib
          ! Return flow
          ELSE IF ( route_togrid(ib,ij) .EQ. -3 ) THEN
             route_tobasin(ib,ij) = nbasmax + 1
             route_togrid(ib,ij) = ib
          ENDIF
       ENDDO
    ENDDO
    !
    ! A second check on the data. Just make sure that each basin flows somewhere.
    !
    DO ib=1,nbpt
       DO ij=1,basin_count(ib)
          ibf = route_togrid(ib,ij)
          ijf = route_tobasin(ib,ij)
          IF ( ijf .GT. basin_count(ibf) .AND.  ijf .LE. nbasmax) THEN
             WRITE(numout,*) 'Second check'
             WRITE(numout,*) 'point :', ib, ' basin :', ij
             WRITE(numout,*) 'Flows into point :', ibf, ' basin :', ijf
             WRITE(numout,*) 'But it flows into now here as basin count = ', basin_count(ibf)
             CALL ipslerr_p(3,'routing_truncate','Problem with routing..','','')
          ENDIF
       ENDDO
    ENDDO
    !
    ! Verify areas of the continents
    !
    floflo(:,:) = zero
    gridarea(:) = contfrac(:)*resolution(:,1)*resolution(:,2)
    DO ib=1,nbpt
       gridbasinarea(ib) = SUM(routing_area(ib,:))
    ENDDO
    !
    DO ib=1,nbpt
       DO ij=1,basin_count(ib)
          cnt = 0
          igrif = ib
          ibasf = ij
          DO WHILE (ibasf .LE. nbasmax .AND. cnt .LT. nbasmax*nbpt)
             cnt = cnt + 1
             pold = igrif
             bold = ibasf
             igrif = route_togrid(pold, bold)
             ibasf = route_tobasin(pold, bold)
             IF ( ibasf .GT. basin_count(igrif)  .AND.  ibasf .LE. nbasmax) THEN
                WRITE(numout,*) 'We should not be here as the basin flows into the pampa'
                WRITE(numout,*) 'Last correct point :', pold, bold
                WRITE(numout,*) 'It pointed to in the new variables :', route_togrid(pold, bold),route_tobasin(pold, bold) 
                WRITE(numout,*) 'The old variables gave :', outflow_grid(pold, bold), outflow_basin(pold, bold) 
                WRITE(numout,*) 'Where we ended up :', igrif,ibasf
                CALL ipslerr_p(3,'routing_truncate','Problem with routing..','','')
             ENDIF
          ENDDO
          !
          IF ( ibasf .GT. nbasmax ) THEN
             floflo(igrif,bold) = floflo(igrif,bold) + routing_area(ib,ij)
          ELSE
             WRITE(numout,*) 'The flow did not end up in the ocean or in the grid cell.'
             WRITE(numout,*) 'For grid ', ib, ' and basin ', ij
             WRITE(numout,*) 'The last grid was ', igrif, ' and basin ', ibasf
             CALL ipslerr_p(3,'routing_truncate','Problem with routing..','','')
          ENDIF
       ENDDO
    ENDDO
    !
    DO ib=1,nbpt
       IF ( gridbasinarea(ib) > zero ) THEN
          ratio = gridarea(ib)/gridbasinarea(ib)
          routing_area(ib,:) = routing_area(ib,:)*ratio
       ELSE
          WRITE(numout,*) 'gridbasinarea(ib) <= zero. We should stop here :', ib
       ENDIF
    ENDDO
    !
    WRITE(numout,*) 'Sum of area of all outflow areas :',SUM(routing_area)
    WRITE(numout,*) 'Surface of all continents :', SUM(gridarea)
    !
    ! Redo the the distinction between river outflow and coastal flow. We can not
    ! take into account the return flow points.
    !
    ibf = 0
    DO ib=1, pickmax
       ff = MAXLOC(floflo)
       ! tdo - To take into account rivers that do not flow to the oceans 
       IF ( route_tobasin(ff(1), ff(2)) .GT. nbasmax ) THEN
!       IF ( route_tobasin(ff(1), ff(2)) .EQ. nbasmax + 2) THEN
          ibf = ibf + 1
          largest_basins(ibf,:) = ff(:)
       ENDIF
       floflo(ff(1), ff(2)) = zero
    ENDDO
    !
    ! Put the largest basins into river flows.
    !
    IF ( ibf .LT.  num_largest) THEN
       WRITE(numout,*) 'Not enough basins to choose the ',  num_largest, 'largest'
       CALL ipslerr_p(3,'routing_truncate','Not enough basins','','')
    ENDIF
    !
    !
    !
    DO ib=1, num_largest
       route_tobasin(largest_basins(ib,1),largest_basins(ib,2)) = nbasmax + 3
    ENDDO
    !
    WRITE(numout,*) 'NUMBER OF RIVERS :', COUNT(route_tobasin .GE. nbasmax + 3)
    !
  END SUBROUTINE  routing_truncate
  !
!! ================================================================================================================================
!! SUBROUTINE   : routing_killbas
!!
!>\BRIEF        The aim of this subroutine is to kill a basin (that is put into another larger one).
!!              When we do this we need to be careful and change all associated variables.  
!!
!! DESCRIPTION (definitions, functional, design, flags) : None
!!
!! RECENT CHANGE(S): None
!!
!! MAIN OUTPUT VARIABLE(S):
!!
!! REFERENCES   : None
!!
!! FLOWCHART    : None
!! \n
!_ ================================================================================================================================

SUBROUTINE routing_killbas(nbpt, ib, tokill, totakeover, nwbas, basin_count, basin_area, basin_topoind,&
       & fetch_basin, basin_id, basin_flowdir, outflow_grid, outflow_basin, inflow_number,&
       & inflow_grid, inflow_basin)
    !
    !
    IMPLICIT NONE
    !
    INTEGER(i_std)                              :: tokill        !!
    INTEGER(i_std)                              :: totakeover    !!
    INTEGER(i_std)                              :: nbpt          !! Domain size  (unitless)
    INTEGER(i_std)                              :: ib            !! Current basin (unitless)
    !
    INTEGER(i_std)                              :: nwbas         !!
    INTEGER(i_std), DIMENSION(nbpt)             :: basin_count   !!
    INTEGER(i_std), DIMENSION(nbpt,nwbas)       :: basin_id      !!
    INTEGER(i_std), DIMENSION(nbpt,nwbas)       :: basin_flowdir !! Water flow directions in the basin (unitless)
    REAL(r_std), DIMENSION(nbpt,nwbas)          :: basin_area    !!
    REAL(r_std), DIMENSION(nbpt,nwbas)          :: basin_topoind !! Topographic index of the residence time for a basin (m)
    REAL(r_std), DIMENSION(nbpt,nwbas)          :: fetch_basin   !!
    INTEGER(i_std), DIMENSION(nbpt,nwbas)       :: outflow_grid  !! Type of outflow on the grid box (unitless)
    INTEGER(i_std), DIMENSION(nbpt,nwbas)       :: outflow_basin !!
    INTEGER(i_std), DIMENSION(nbpt,nwbas)       :: inflow_number !!
    INTEGER(i_std), DIMENSION(nbpt,nwbas,nwbas) :: inflow_basin  !!
    INTEGER(i_std), DIMENSION(nbpt,nwbas,nwbas) :: inflow_grid   !!
    !
!! LOCAL VARIABLES
    INTEGER(i_std)                              :: inf, ibs, ing, inb, ibasf, igrif, it !! Indices (unitless)
    LOGICAL                                     :: doshift       !! (true/false)

!_ ================================================================================================================================
    !
    ! Update the information needed in the basin "totakeover"
    ! For the moment only area
    !
    IF (printlev>=3) THEN
       WRITE(numout,*) 'KILL BASIN :', ib, tokill, totakeover, basin_id(ib,tokill), basin_id(ib,totakeover)
    END IF
    !
    basin_area(ib, totakeover) = basin_area(ib, totakeover) +  basin_area(ib, tokill)
    basin_topoind(ib, totakeover) = (basin_topoind(ib, totakeover) + basin_topoind(ib, tokill))/2.0
    !
    ! Add the fetch of the basin will kill to the one which gets the water
    !
    fetch_basin(ib, totakeover) = fetch_basin(ib, totakeover) + fetch_basin(ib, tokill)
    igrif = outflow_grid(ib,totakeover)
    ibasf = outflow_basin(ib,totakeover)
    !
    inf = 0
    DO WHILE (igrif .GT. 0)
       fetch_basin(igrif,ibasf) =  fetch_basin(igrif,ibasf) + fetch_basin(ib, tokill) 
       it = outflow_grid(igrif, ibasf)
       ibasf = outflow_basin(igrif, ibasf)
       igrif = it
       inf = inf + 1
    ENDDO
    !
    ! Take out the basin we have just rerouted from the fetch of the basins in which it used to flow.
    !
    igrif = outflow_grid(ib,tokill)
    ibasf = outflow_basin(ib,tokill)
    !
    DO WHILE (igrif .GT. 0)
       fetch_basin(igrif,ibasf) =  fetch_basin(igrif,ibasf) - fetch_basin(ib, tokill)
       it = outflow_grid(igrif, ibasf)
       ibasf = outflow_basin(igrif, ibasf)
       igrif = it
    ENDDO   
    !
    !  Redirect the flows which went into the basin to be killed before we change everything
    !
    DO inf = 1, inflow_number(ib, tokill)
       outflow_basin(inflow_grid(ib, tokill, inf), inflow_basin(ib, tokill, inf)) = totakeover
       inflow_number(ib, totakeover) = inflow_number(ib, totakeover) + 1
       inflow_grid(ib, totakeover,  inflow_number(ib, totakeover)) = inflow_grid(ib, tokill, inf)
       inflow_basin(ib, totakeover,  inflow_number(ib, totakeover)) = inflow_basin(ib, tokill, inf)
    ENDDO
    !
    ! Take out the basin to be killed from the list of inflow basins of the downstream basin
    ! (In case the basin does not flow into an ocean or lake)
    !
    IF ( outflow_grid(ib,tokill) .GT. 0) THEN
       !
       ing = outflow_grid(ib, tokill)
       inb = outflow_basin(ib, tokill)
       doshift = .FALSE.
       !
       DO inf = 1, inflow_number(ing, inb)
          IF ( doshift ) THEN
             inflow_grid(ing, inb, inf-1) = inflow_grid(ing, inb, inf)
             inflow_basin(ing, inb, inf-1) = inflow_basin(ing, inb, inf)
          ENDIF
          IF ( inflow_grid(ing, inb, inf) .EQ. ib .AND. inflow_basin(ing, inb, inf) .EQ. tokill) THEN
             doshift = .TRUE.
          ENDIF
       ENDDO
       !
       ! This is only to allow for the last check
       !
       inf = inflow_number(ing, inb)
       IF ( inflow_grid(ing, inb, inf) .EQ. ib .AND. inflow_basin(ing, inb, inf) .EQ. tokill) THEN
          doshift = .TRUE.
       ENDIF
       !
       IF ( .NOT. doshift ) THEN
          WRITE(numout,*) 'Strange we did not find the basin to kill in the downstream basin'
          CALL ipslerr_p(3,'routing_killbas','Basin not found','','')
       ENDIF
       inflow_number(ing, inb) = inflow_number(ing, inb) - 1
       
    ENDIF
    !
    ! Now remove from the arrays the information of basin "tokill"
    !
    basin_id(ib, tokill:basin_count(ib)-1) = basin_id(ib, tokill+1:basin_count(ib))
    basin_flowdir(ib, tokill:basin_count(ib)-1) = basin_flowdir(ib, tokill+1:basin_count(ib))
    basin_area(ib, tokill:basin_count(ib)-1) = basin_area(ib, tokill+1:basin_count(ib))
    basin_area(ib, basin_count(ib):nwbas) = zero
    basin_topoind(ib, tokill:basin_count(ib)-1) = basin_topoind(ib, tokill+1:basin_count(ib))
    basin_topoind(ib, basin_count(ib):nwbas) = zero
    fetch_basin(ib, tokill:basin_count(ib)-1) = fetch_basin(ib, tokill+1:basin_count(ib))
    fetch_basin(ib, basin_count(ib):nwbas) = zero
    !
    ! Before we remove the information from the outflow fields we have to correct the corresponding inflow fields
    ! of the grids into which the flow goes
    !
    DO ibs = tokill+1,basin_count(ib)
       ing = outflow_grid(ib, ibs)
       inb = outflow_basin(ib, ibs)
       IF ( ing .GT. 0 ) THEN
          DO inf = 1, inflow_number(ing, inb)
             IF ( inflow_grid(ing,inb,inf) .EQ. ib .AND. inflow_basin(ing,inb,inf) .EQ. ibs) THEN
                inflow_basin(ing,inb,inf) = ibs - 1
             ENDIF
          ENDDO
       ENDIF
    ENDDO
    outflow_grid(ib, tokill:basin_count(ib)-1) = outflow_grid(ib, tokill+1:basin_count(ib))
    outflow_basin(ib, tokill:basin_count(ib)-1) = outflow_basin(ib, tokill+1:basin_count(ib))
    !
    ! Basins which moved down also need to redirect their incoming flows.
    !
    DO ibs=tokill+1, basin_count(ib)
       DO inf = 1, inflow_number(ib, ibs)
          outflow_basin(inflow_grid(ib, ibs, inf), inflow_basin(ib, ibs, inf)) = ibs-1
       ENDDO
    ENDDO
    !
    ! Shift the inflow basins
    !
    DO it = tokill+1,basin_count(ib)
       inflow_grid(ib, it-1, 1:inflow_number(ib,it)) =  inflow_grid(ib, it, 1:inflow_number(ib,it))
       inflow_basin(ib, it-1, 1:inflow_number(ib,it)) =  inflow_basin(ib, it, 1:inflow_number(ib,it))
       inflow_number(ib,it-1) = inflow_number(ib,it)
    ENDDO
    !
    basin_count(ib) = basin_count(ib) - 1
    !
  END SUBROUTINE routing_killbas 
  !
!! ================================================================================================================================
!! SUBROUTINE   : routing_names
!!
!>\BRIEF         This subroutine lists the name of the largest basins which are explicitly listed in the basin
!!               description file used by ORCHIDEE.
!!
!! DESCRIPTION (definitions, functional, design, flags) : None
!!
!! RECENT CHANGE(S): None
!!
!! MAIN OUTPUT VARIABLE(S):
!!
!! REFERENCES   : None
!!
!! FLOWCHART    : None
!! \n
!_ ================================================================================================================================

SUBROUTINE routing_names(numlar, basin_names)
    !
    IMPLICIT NONE
    !
    ! Arguments
    !
    INTEGER(i_std), INTENT(in)             :: numlar              !!
    CHARACTER(LEN=*), INTENT(inout)        :: basin_names(numlar) !! Name of the basins (unitless)
!! PARAMETERS
    INTEGER(i_std), PARAMETER              :: listleng=349        !!
    !
!! LOCAL VARIABLES
    INTEGER(i_std)                         :: lenstr, i           !!
    CHARACTER(LEN=60), DIMENSION(listleng) :: list_names          !!
    CHARACTER(LEN=60)                      :: tmp_str             !!

!_ ================================================================================================================================
    !

    lenstr = LEN(basin_names(1))
    !
    list_names(1) = "Amazon"
    list_names(2) = "Nile"
    list_names(3) = "Zaire"
    list_names(4) = "Mississippi"
    list_names(5) = "Amur"
    list_names(6) = "Parana"
    list_names(7) = "Yenisei"
    list_names(8) = "Ob"
    list_names(9) = "Lena"
    list_names(10) = "Niger"
    list_names(11) = "Zambezi"
    list_names(12) = "Erg Iguidi (Sahara)"
    list_names(13) = "Chang Jiang (Yangtze)"
    list_names(14) = "Mackenzie"
    list_names(15) = "Ganges"
    list_names(16) = "Chari"
    list_names(17) = "Volga"
    list_names(18) = "St. Lawrence"
    list_names(19) = "Indus"
    list_names(20) = "Syr-Darya"
    list_names(21) = "Nelson"
    list_names(22) = "Orinoco"
    list_names(23) = "Murray"
    list_names(24) = "Great Artesian Basin"
    list_names(25) = "Shatt el Arab"
    list_names(26) = "Orange"
    list_names(27) = "Huang He"
    list_names(28) = "Yukon"
    list_names(29) = "Senegal"
    list_names(30) = "Chott Jerid"
    list_names(31) = "Jubba"
    list_names(32) = "Colorado (Ari)"
    list_names(33) = "Rio Grande (US)"
    list_names(34) = "Danube"
    list_names(35) = "Mekong"
    list_names(36) = "Tocantins"
    list_names(37) = "Wadi al Farigh"
    list_names(38) = "Tarim"
    list_names(39) = "Columbia"
    list_names(40) = "Komadugu Yobe (Tchad)"
    list_names(41) = "Kolyma"
    list_names(42) = "Sao Francisco"
    list_names(43) = "Amu-Darya"
    list_names(44) = "GHAASBasin51"
    list_names(45) = "Dnepr"
    list_names(46) = "GHAASBasin61"
    list_names(47) = "Don"
    list_names(48) = "Colorado (Arg)"
    list_names(49) = "Limpopo"
    list_names(50) = "GHAASBasin50"
    list_names(51) = "Zhujiang"
    list_names(52) = "Irrawaddy"
    list_names(53) = "Volta"
    list_names(54) = "GHAASBasin54"
    list_names(55) = "Farah"
    list_names(56) = "Khatanga"
    list_names(57) = "Dvina"
    list_names(58) = "Urugay"
    list_names(59) = "Qarqan"
    list_names(60) = "GHAASBasin75"
    list_names(61) = "Parnaiba"
    list_names(62) = "GHAASBasin73"
    list_names(63) = "Indigirka"
    list_names(64) = "Churchill (Hud)"
    list_names(65) = "Godavari"
    list_names(66) = "Pur - Taz"
    list_names(67) = "Pechora"
    list_names(68) = "Baker"
    list_names(69) = "Ural"
    list_names(70) = "Neva"
    list_names(71) = "Liao"
    list_names(72) = "Salween"
    list_names(73) = "GHAASBasin73"
    list_names(74) = "Jordan"
    list_names(75) = "GHAASBasin78"
    list_names(76) = "Magdalena"
    list_names(77) = "Krishna"
    list_names(78) = "Salado"
    list_names(79) = "Fraser"
    list_names(80) = "Hai Ho"
    list_names(81) = "Huai"
    list_names(82) = "Yana"
    list_names(83) = "GHAASBasin95"
    list_names(84) = "GHAASBasin105"
    list_names(85) = "Kura"
    list_names(86) = "Olenek"
    list_names(87) = "Ogooue"
    list_names(88) = "Taymyr"
    list_names(89) = "Negro Arg"
    list_names(90) = "Chubut"
    list_names(91) = "GHAASBasin91"
    list_names(92) = "GHAASBasin122"
    list_names(93) = "GHAASBasin120"
    list_names(94) = "Sacramento"
    list_names(95) = "Fitzroy West"
    list_names(96) = "Grande de Santiago"
    list_names(97) = "Rufiji"
    list_names(98) = "Wisla"
    list_names(99) = "GHAASBasin47"
    list_names(100) = "GHAASBasin127"
    list_names(101) = "Hong"
    list_names(102) = "GHAASBasin97"
    list_names(103) = "Swan-Avon"
    list_names(104) = "Rhine"
    list_names(105) = "Cuanza"
    list_names(106) = "GHAASBasin106"
    list_names(107) = "GHAASBasin142"
    list_names(108) = "Roviuna"
    list_names(109) = "Essequibo"
    list_names(110) = "Elbe"
    list_names(111) = "Koksoak"
    list_names(112) = "Chao Phraya"
    list_names(113) = "Brahmani"
    list_names(114) = "GHAASBasin165"
    list_names(115) = "Pyasina"
    list_names(116) = "Fitzroy East"
    list_names(117) = "GHAASBasin173"
    list_names(118) = "Albany"
    list_names(119) = "Sanaga"
    list_names(120) = "GHAASBasin120"
    list_names(121) = "GHAASBasin178"
    list_names(122) = "GHAASBasin148"
    list_names(123) = "Brazos (Tex)"
    list_names(124) = "GHAASBasin124"
    list_names(125) = "Alabama"
    list_names(126) = "GHAASBasin174"
    list_names(127) = "GHAASBasin179"
    list_names(128) = "Balsas"
    list_names(129) = "GHAASBasin172"
    list_names(130) = "Burdekin"
    list_names(131) = "Colorado (Texas)"
    list_names(132) = "GHAASBasin150"
    list_names(133) = "Odra"
    list_names(134) = "Loire"
    list_names(135) = "GHAASBasin98"
    list_names(136) = "Galana"
    list_names(137) = "Kuskowin"
    list_names(138) = "Moose"
    list_names(139) = "Narmada"
    list_names(140) = "GHAASBasin140"
    list_names(141) = "GHAASBasin141"
    list_names(142) = "Flinders"
    list_names(143) = "Kizil Irmak"
    list_names(144) = "GHAASBasin144"
    list_names(145) = "Save"
    list_names(146) = "Roper"
    list_names(147) = "Churchill (Atlantic)"
    list_names(148) = "GHAASBasin148"
    list_names(149) = "Victoria"
    list_names(150) = "Back"
    list_names(151) = "Bandama"
    list_names(152) = "Severn (Can)"
    list_names(153) = "Po"
    list_names(154) = "GHAASBasin154"
    list_names(155) = "GHAASBasin155"
    list_names(156) = "GHAASBasin156"
    list_names(157) = "Rhone"
    list_names(158) = "Tana (Ken)"
    list_names(159) = "La Grande"
    list_names(160) = "GHAASBasin160"
    list_names(161) = "Cunene"
    list_names(162) = "Douro"
    list_names(163) = "GHAASBasin163"
    list_names(164) = "Nemanus"
    list_names(165) = "GHAASBasin165"
    list_names(166) = "Anabar"
    list_names(167) = "Hayes"
    list_names(168) = "Mearim"
    list_names(169) = "GHAASBasin169"
    list_names(170) = "Panuco"
    list_names(171) = "GHAASBasin171"
    list_names(172) = "Doce"
    list_names(173) = "Gasgoyne"
    list_names(174) = "GHAASBasin174"
    list_names(175) = "GHAASBasin175"
    list_names(176) = "Ashburton"
    list_names(177) = "GHAASBasin177"
    list_names(178) = "Peel"
    list_names(179) = "Daugava"
    list_names(180) = "GHAASBasin180"
    list_names(181) = "Ebro"
    list_names(182) = "Comoe"
    list_names(183) = "Jacui"
    list_names(184) = "GHAASBasin184"
    list_names(185) = "Kapuas"
    list_names(186) = "GHAASBasin186"
    list_names(187) = "Penzhina"
    list_names(188) = "Cauweri"
    list_names(189) = "GHAASBasin189"
    list_names(190) = "Mamberamo"
    list_names(191) = "Sepik"
    list_names(192) = "GHAASBasin192"
    list_names(193) = "Sassandra"
    list_names(194) = "GHAASBasin194"
    list_names(195) = "GHAASBasin195"
    list_names(196) = "Nottaway"
    list_names(197) = "Barito"
    list_names(198) = "GHAASBasin198"
    list_names(199) = "Seine"
    list_names(200) = "Tejo"
    list_names(201) = "GHAASBasin201"
    list_names(202) = "Gambia"
    list_names(203) = "Susquehanna"
    list_names(204) = "Dnestr"
    list_names(205) = "Murchinson"
    list_names(206) = "Deseado"
    list_names(207) = "Mitchell"
    list_names(208) = "Mahakam"
    list_names(209) = "GHAASBasin209"
    list_names(210) = "Pangani"
    list_names(211) = "GHAASBasin211"
    list_names(212) = "GHAASBasin212"
    list_names(213) = "GHAASBasin213"
    list_names(214) = "GHAASBasin214"
    list_names(215) = "GHAASBasin215"
    list_names(216) = "Bug"
    list_names(217) = "GHAASBasin217"
    list_names(218) = "Usumacinta"
    list_names(219) = "Jequitinhonha"
    list_names(220) = "GHAASBasin220"
    list_names(221) = "Corantijn"
    list_names(222) = "Fuchun Jiang"
    list_names(223) = "Copper"
    list_names(224) = "Tapti"
    list_names(225) = "Menjiang"
    list_names(226) = "Karun"
    list_names(227) = "Mezen"
    list_names(228) = "Guadiana"
    list_names(229) = "Maroni"
    list_names(230) = "GHAASBasin230"
    list_names(231) = "Uda"
    list_names(232) = "GHAASBasin232"
    list_names(233) = "Kuban"
    list_names(234) = "Colville"
    list_names(235) = "Thaane"
    list_names(236) = "Alazeya"
    list_names(237) = "Paraiba do Sul"
    list_names(238) = "GHAASBasin238"
    list_names(239) = "Fortesque"
    list_names(240) = "GHAASBasin240"
    list_names(241) = "GHAASBasin241"
    list_names(242) = "Winisk"
    list_names(243) = "GHAASBasin243"
    list_names(244) = "GHAASBasin244"
    list_names(245) = "Ikopa"
    list_names(246) = "Gilbert"
    list_names(247) = "Kouilou"
    list_names(248) = "Fly"
    list_names(249) = "GHAASBasin249"
    list_names(250) = "GHAASBasin250"
    list_names(251) = "GHAASBasin251"
    list_names(252) = "Mangoky"
    list_names(253) = "Damodar"
    list_names(254) = "Onega"
    list_names(255) = "Moulouya"
    list_names(256) = "GHAASBasin256"
    list_names(257) = "Ord"
    list_names(258) = "GHAASBasin258"
    list_names(259) = "GHAASBasin259"
    list_names(260) = "GHAASBasin260"
    list_names(261) = "GHAASBasin261"
    list_names(262) = "Narva"
    list_names(263) = "GHAASBasin263"
    list_names(264) = "Seal"
    list_names(265) = "Cheliff"
    list_names(266) = "Garonne"
    list_names(267) = "Rupert"
    list_names(268) = "GHAASBasin268"
    list_names(269) = "Brahmani"
    list_names(270) = "Sakarya"
    list_names(271) = "Gourits"
    list_names(272) = "Sittang"
    list_names(273) = "Rajang"
    list_names(274) = "Evros"
    list_names(275) = "Appalachicola"
    list_names(276) = "Attawapiskat"
    list_names(277) = "Lurio"
    list_names(278) = "Daly"
    list_names(279) = "Penner"
    list_names(280) = "GHAASBasin280"
    list_names(281) = "GHAASBasin281"
    list_names(282) = "Guadalquivir"
    list_names(283) = "Nadym"
    list_names(284) = "GHAASBasin284"
    list_names(285) = "Saint John"
    list_names(286) = "GHAASBasin286"
    list_names(287) = "Cross"
    list_names(288) = "Omoloy"
    list_names(289) = "Oueme"
    list_names(290) = "GHAASBasin290"
    list_names(291) = "Gota"
    list_names(292) = "Nueces"
    list_names(293) = "Stikine"
    list_names(294) = "Yalu"
    list_names(295) = "Arnaud"
    list_names(296) = "GHAASBasin296"
    list_names(297) = "Jequitinhonha"
    list_names(298) = "Kamchatka"
    list_names(299) = "GHAASBasin299"
    list_names(300) = "Grijalva"
    list_names(301) = "GHAASBasin301"
    list_names(302) = "Kemijoki"
    list_names(303) = "Olifants"
    list_names(304) = "GHAASBasin304"
    list_names(305) = "Tsiribihina"
    list_names(306) = "Coppermine"
    list_names(307) = "GHAASBasin307"
    list_names(308) = "GHAASBasin308"
    list_names(309) = "Kovda"
    list_names(310) = "Trinity"
    list_names(311) = "Glama"
    list_names(312) = "GHAASBasin312"
    list_names(313) = "Luan"
    list_names(314) = "Leichhardt"
    list_names(315) = "GHAASBasin315"
    list_names(316) = "Gurupi"
    list_names(317) = "GR Baleine"
    list_names(318) = "Aux Feuilles"
    list_names(319) = "GHAASBasin319"
    list_names(320) = "Weser"
    list_names(321) = "GHAASBasin321"
    list_names(322) = "GHAASBasin322"
    list_names(323) = "Yesil"
    list_names(324) = "Incomati"
    list_names(325) = "GHAASBasin325"
    list_names(326) = "GHAASBasin326"
    list_names(327) = "Pungoe"
    list_names(328) = "GHAASBasin328"
    list_names(329) = "Meuse"
    list_names(330) = "Eastmain"
    list_names(331) = "Araguari"
    list_names(332) = "Hudson"
    list_names(333) = "GHAASBasin333"
    list_names(334) = "GHAASBasin334"
    list_names(335) = "GHAASBasin335"
    list_names(336) = "GHAASBasin336"
    list_names(337) = "Kobuk"
    list_names(338) = "Altamaha"
    list_names(339) = "GHAASBasin339"
    list_names(340) = "Mand"
    list_names(341) = "Santee"
    list_names(342) = "GHAASBasin342"
    list_names(343) = "GHAASBasin343"
    list_names(344) = "GHAASBasin344"
    list_names(345) = "Hari"
    list_names(346) = "GHAASBasin346"
    list_names(347) = "Wami"
    list_names(348) = "GHAASBasin348"
    list_names(349) = "GHAASBasin349"
    !
    basin_names(:) = '    '
    !
    DO i=1,numlar
       tmp_str = list_names(i)
       basin_names(i) = tmp_str(1:MIN(lenstr,LEN_TRIM(tmp_str)))
    ENDDO
    !
  END SUBROUTINE routing_names
  !
!! ================================================================================================================================
!! SUBROUTINE   : routing_irrigmap
!!
!>\BRIEF         This  subroutine interpolates the 0.5x0.5 degree based map of irrigated areas to the resolution of the model.
!!
!! DESCRIPTION (definitions, functional, design, flags) : None
!!
!! RECENT CHANGE(S): None
!!
!! MAIN OUTPUT VARIABLE(S):
!!
!! REFERENCES   : None
!!
!! FLOWCHART    : None
!! \n
!_ ================================================================================================================================

SUBROUTINE routing_irrigmap (nbpt, index, lalo, neighbours, resolution, contfrac, &
       &                       init_irrig, irrigated, init_flood, floodplains, init_swamp, swamp, hist_id, hist2_id)
    !
    IMPLICIT NONE
    !
!! PARAMETERS
    INTEGER(i_std), PARAMETER                      :: ilake = 1             !! Number of type of lakes area (unitless)
    INTEGER(i_std), PARAMETER                      :: idam = 2              !! Number of type of dams area (unitless)
    INTEGER(i_std), PARAMETER                      :: iflood = 3            !! Number of type of floodplains area (unitless)
    INTEGER(i_std), PARAMETER                      :: iswamp = 4            !! Number of type of swamps area (unitless)
    INTEGER(i_std), PARAMETER                      :: isal = 5              !! Number of type of salines area (unitless)
    INTEGER(i_std), PARAMETER                      :: ipond = 6             !! Number of type of ponds area (unitless)
    INTEGER(i_std), PARAMETER                      :: ntype = 6             !! Number of types of flooded surfaces (unitless)

!! INPUT VARIABLES
    INTEGER(i_std), INTENT(in)                     :: nbpt                  !! Domain size  (unitless)
    INTEGER(i_std), INTENT(in)                     :: index(nbpt)           !! Index on the global map.
    REAL(r_std), INTENT(in)                        :: lalo(nbpt,2)          !! Vector of latitude and longitudes (beware of the order !)
    INTEGER(i_std), INTENT(in)                     :: neighbours(nbpt,NbNeighb)!! Vector of neighbours for each grid point
    REAL(r_std), INTENT(in)                        :: resolution(nbpt,2)    !! The size of each grid box in X and Y (m)
    REAL(r_std), INTENT(in)                        :: contfrac(nbpt)        !! Fraction of land in each grid box (unitless;0-1)
    INTEGER(i_std), INTENT(in)                     :: hist_id               !! Access to history file (unitless)
    INTEGER(i_std), INTENT(in)                     :: hist2_id              !! Access to history file 2 (unitless)
    LOGICAL, INTENT(in)                            :: init_irrig            !! Logical to initialize the irrigation (true/false)
    LOGICAL, INTENT(in)                            :: init_flood            !! Logical to initialize the floodplains (true/false)
    LOGICAL, INTENT(in)                            :: init_swamp            !! Logical to initialize the swamps (true/false)
    !
!! OUTPUT VARIABLES
    REAL(r_std), INTENT(out)                       :: irrigated(:)          !! Irrigated surface in each grid box (m^2)
    REAL(r_std), INTENT(out)                       :: floodplains(:)        !! Surface which can be inundated in each grid box (m^2)
    REAL(r_std), INTENT(out)                       :: swamp(:)              !! Surface which can be swamp in each grid box (m^2)
    !
!! LOCAL VARIABLES
    ! Interpolation variables
    ! 
    INTEGER(i_std)                                 :: nbpmax, nix, njx, fopt !!
    CHARACTER(LEN=30)                              :: callsign              !!
    REAL(r_std), ALLOCATABLE, DIMENSION(:,:,:)     :: resol_lu              !! Resolution read on the map
    INTEGER(i_std), ALLOCATABLE, DIMENSION(:,:)    :: mask                  !! Mask to exclude some points (unitless)
    REAL(r_std), ALLOCATABLE, DIMENSION(:,:)       :: irrsub_area           !! Area on the fine grid (m^2)
    INTEGER(i_std), ALLOCATABLE, DIMENSION(:,:,:)  :: irrsub_index          !! Indices of the points we need on the fine grid (unitless)
    INTEGER                                        :: ALLOC_ERR             !!
    LOGICAL                                        :: ok_interpol = .FALSE. !! Flag for interpolation (true/false)
    !
    CHARACTER(LEN=80)                              :: filename              !! Name of the netcdf file (unitless)
    INTEGER(i_std)                                 :: iml, jml, lml, tml, fid, ib, ip, jp, itype !! Indices (unitless)
    REAL(r_std)                                    :: lev(1), date, dt, coslat !!
    INTEGER(i_std)                                 :: itau(1)               !!
    REAL(r_std), ALLOCATABLE, DIMENSION(:,:)       :: latrel                !! Latitude
    REAL(r_std), ALLOCATABLE, DIMENSION(:,:)       :: lonrel                !! Longitude
    REAL(r_std), ALLOCATABLE, DIMENSION(:,:)       :: irrigated_frac        !! Irrigated fraction of the grid box (unitless;0-1)
    REAL(r_std), ALLOCATABLE, DIMENSION(:,:,:)     :: flood_fracmax         !! Maximal flooded fraction of the grid box (unitless;0-1)
    REAL(r_std)                                    :: area_irrig            !! Irrigated surface in the grid box (m^2)
    REAL(r_std)                                    :: area_flood(ntype)     !! Flooded surface in the grid box (m^2)
!!$    REAL(r_std)                                :: irrigmap(nbpt)
!!$    REAL(r_std)                                :: floodmap(nbpt)
!!$    REAL(r_std)                                :: swampmap(nbpt)

!_ ================================================================================================================================

    !
    !Config Key   = IRRIGATION_FILE
    !Config Desc  = Name of file which contains the map of irrigated areas
    !Config Def   = floodplains.nc
    !Config If    = DO_IRRIGATION OR DO_FLOODPLAINS
    !Config Help  = The name of the file to be opened to read the field
    !Config         with the area in m^2 of the area irrigated within each
    !Config         0.5 0.5 deg grid box. The map currently used is the one
    !Config         developed by the Center for Environmental Systems Research 
    !Config         in Kassel (1995).
    !Config Units = [FILE]
    !
    filename = 'floodplains.nc'
    CALL getin_p('IRRIGATION_FILE',filename)
    !
    IF (is_root_prc) THEN
       CALL flininfo(filename,iml, jml, lml, tml, fid)
       CALL flinclo(fid)
    ELSE
       iml = 0
       jml = 0
       lml = 0
       tml = 0
    ENDIF
    !
    CALL bcast(iml)
    CALL bcast(jml)
    CALL bcast(lml)
    CALL bcast(tml)
    !
    !
    !
    ALLOCATE (latrel(iml,jml), STAT=ALLOC_ERR)
    IF (ALLOC_ERR /= 0) CALL ipslerr_p(3,'routing_irrigmap','Pb in allocate for latrel','','')

    ALLOCATE (lonrel(iml,jml), STAT=ALLOC_ERR)
    IF (ALLOC_ERR /= 0) CALL ipslerr_p(3,'routing_irrigmap','Pb in allocate for lonrel','','')

    ALLOCATE (irrigated_frac(iml,jml), STAT=ALLOC_ERR)
    IF (ALLOC_ERR /= 0) CALL ipslerr_p(3,'routing_irrigmap','Pb in allocate for irrigated_frac','','')

    ALLOCATE (flood_fracmax(iml,jml,ntype), STAT=ALLOC_ERR)
    IF (ALLOC_ERR /= 0) CALL ipslerr_p(3,'routing_irrigmap','Pb in allocate for flood_fracmax','','')

    IF (is_root_prc) CALL flinopen(filename, .FALSE., iml, jml, lml, lonrel, latrel, lev, tml, itau, date, dt, fid)

    CALL bcast(lonrel)
    CALL bcast(latrel)
    !
    IF (is_root_prc) CALL flinget(fid, 'irrig', iml, jml, lml, tml, 1, 1, irrigated_frac)
    CALL bcast(irrigated_frac)
    IF (is_root_prc) CALL flinget(fid, 'lake', iml, jml, lml, tml, 1, 1, flood_fracmax(:,:,ilake))
    IF (is_root_prc) CALL flinget(fid, 'dam', iml, jml, lml, tml, 1, 1, flood_fracmax(:,:,idam))
    IF (is_root_prc) CALL flinget(fid, 'flood', iml, jml, lml, tml, 1, 1, flood_fracmax(:,:,iflood))
    IF (is_root_prc) CALL flinget(fid, 'swamp', iml, jml, lml, tml, 1, 1, flood_fracmax(:,:,iswamp))
    IF (is_root_prc) CALL flinget(fid, 'saline', iml, jml, lml, tml, 1, 1, flood_fracmax(:,:,isal))
    IF (is_root_prc) CALL flinget(fid, 'pond', iml, jml, lml, tml, 1, 1, flood_fracmax(:,:,ipond))
    CALL bcast(flood_fracmax)
    !
    IF (is_root_prc) CALL flinclo(fid)
    !
    ! Set to zero all fraction which are less than 0.5%
    !
    DO ip=1,iml
       DO jp=1,jml
          !
          IF ( irrigated_frac(ip,jp) .LT. undef_sechiba-un) THEN
             irrigated_frac(ip,jp) = irrigated_frac(ip,jp)/100.
             IF ( irrigated_frac(ip,jp) < 0.005 ) irrigated_frac(ip,jp) = zero
          ENDIF
          !
          DO itype=1,ntype
             IF ( flood_fracmax(ip,jp,itype) .LT. undef_sechiba-1.) THEN
                flood_fracmax(ip,jp,itype) = flood_fracmax(ip,jp,itype)/100
                IF ( flood_fracmax(ip,jp,itype) < 0.005 )  flood_fracmax(ip,jp,itype) = zero
             ENDIF
          ENDDO
          !
       ENDDO
    ENDDO
    
    IF (printlev>=2) THEN
       WRITE(numout,*) 'lonrel : ', MAXVAL(lonrel), MINVAL(lonrel)
       WRITE(numout,*) 'latrel : ', MAXVAL(latrel), MINVAL(latrel)
       WRITE(numout,*) 'irrigated_frac : ', MINVAL(irrigated_frac, MASK=irrigated_frac .GT. 0), &
            MAXVAL(irrigated_frac, MASK=irrigated_frac .LT. undef_sechiba)
       WRITE(numout,*) 'flood_fracmax : ', MINVAL(flood_fracmax, MASK=flood_fracmax .GT. 0), &
            MAXVAL(flood_fracmax, MASK=flood_fracmax .LT. undef_sechiba)
    END IF

    ! Consider all points a priori
    !
    ALLOCATE(resol_lu(iml,jml,2), STAT=ALLOC_ERR)
    IF (ALLOC_ERR /= 0) CALL ipslerr_p(3,'routing_irrigmap','Pb in allocate for resol_lu','','')

    ALLOCATE(mask(iml,jml), STAT=ALLOC_ERR)
    IF (ALLOC_ERR /= 0) CALL ipslerr_p(3,'routing_irrigmap','Pb in allocate for mask','','')
    mask(:,:) = 0

    DO ip=1,iml
       DO jp=1,jml
          !
          ! Exclude the points where we are close to the missing value.
          !
!MG This condition cannot be applied in floodplains/swamps configuration because
!   the same mask would be used for the interpolation of irrigation, floodplains and swamps maps.
!          IF ( irrigated_frac(ip,jp) < undef_sechiba ) THEN
             mask(ip,jp) = 1
!          ENDIF
          !
          ! Resolution in longitude
          !
          coslat = MAX( COS( latrel(ip,jp) * pi/180. ), mincos )     
          IF ( ip .EQ. 1 ) THEN
             resol_lu(ip,jp,1) = ABS( lonrel(ip+1,jp) - lonrel(ip,jp) ) * pi/180. * R_Earth * coslat
          ELSEIF ( ip .EQ. iml ) THEN
             resol_lu(ip,jp,1) = ABS( lonrel(ip,jp) - lonrel(ip-1,jp) ) * pi/180. * R_Earth * coslat
          ELSE
             resol_lu(ip,jp,1) = ABS( lonrel(ip+1,jp) - lonrel(ip-1,jp) )/2. * pi/180. * R_Earth * coslat
          ENDIF
          !
          ! Resolution in latitude
          !
          IF ( jp .EQ. 1 ) THEN
             resol_lu(ip,jp,2) = ABS( latrel(ip,jp) - latrel(ip,jp+1) ) * pi/180. * R_Earth
          ELSEIF ( jp .EQ. jml ) THEN
             resol_lu(ip,jp,2) = ABS( latrel(ip,jp-1) - latrel(ip,jp) ) * pi/180. * R_Earth
          ELSE
             resol_lu(ip,jp,2) =  ABS( latrel(ip,jp-1) - latrel(ip,jp+1) )/2. * pi/180. * R_Earth
          ENDIF
          !
       ENDDO
    ENDDO
    !
    ! The number of maximum vegetation map points in the GCM grid is estimated.
    ! Some lmargin is taken.
    !
    callsign = 'Irrigation map'
    ok_interpol = .FALSE.
    IF (is_root_prc) THEN
       nix=INT(MAXVAL(resolution_g(:,1))/MAXVAL(resol_lu(:,:,1)))+2
       njx=INT(MAXVAL(resolution_g(:,2))/MAXVAL(resol_lu(:,:,2)))+2
       nbpmax = nix*njx*2
       IF (printlev>=1) THEN
          WRITE(numout,*) "Projection arrays for ",callsign," : "
          WRITE(numout,*) "nbpmax = ",nbpmax, nix, njx
       END IF
    ENDIF
    CALL bcast(nbpmax)

    ALLOCATE(irrsub_index(nbpt, nbpmax, 2), STAT=ALLOC_ERR)
    IF (ALLOC_ERR /= 0) CALL ipslerr_p(3,'routing_irrigmap','Pb in allocate for irrsub_index','','')
    irrsub_index(:,:,:)=0

    ALLOCATE(irrsub_area(nbpt, nbpmax), STAT=ALLOC_ERR)
    IF (ALLOC_ERR /= 0) CALL ipslerr_p(3,'routing_irrigmap','Pb in allocate for irrsub_area','','')
    irrsub_area(:,:)=zero

    CALL aggregate_p(nbpt, lalo, neighbours, resolution, contfrac, &
         &                iml, jml, lonrel, latrel, mask, callsign, &
         &                nbpmax, irrsub_index, irrsub_area, ok_interpol)
    !
    !
    WHERE (irrsub_area < 0) irrsub_area=zero
    !  
    ! Test here if not all sub_area are larger than 0 if so, then we need to increase nbpmax
    !
    DO ib=1,nbpt
       !
       area_irrig = 0.0
       area_flood = 0.0
       !
       DO fopt=1,COUNT(irrsub_area(ib,:) > zero)
          !
          ip = irrsub_index(ib, fopt, 1)
          jp = irrsub_index(ib, fopt, 2)
          !
          IF (irrigated_frac(ip,jp) .LT. undef_sechiba-1.) THEN
             area_irrig = area_irrig + irrsub_area(ib,fopt)*irrigated_frac(ip,jp)
          ENDIF
          !
          DO itype=1,ntype
             IF (flood_fracmax(ip,jp,itype) .LT. undef_sechiba-1.) THEN
                area_flood(itype) = area_flood(itype) + irrsub_area(ib,fopt)*flood_fracmax(ip,jp,itype)
             ENDIF
          ENDDO
       ENDDO
       !
       ! Put the total irrigated and flooded areas in the output variables
       !
       IF ( init_irrig ) THEN
          irrigated(ib) = MIN(area_irrig, resolution(ib,1)*resolution(ib,2)*contfrac(ib))
          IF ( irrigated(ib) < 0 ) THEN
             WRITE(numout,*) 'We have a problem here : ', irrigated(ib) 
             WRITE(numout,*) 'resolution :', resolution(ib,1), resolution(ib,2)
             WRITE(numout,*) area_irrig
             CALL ipslerr_p(3,'routing_irrigmap','Problem with irrigated...','','')
          ENDIF
!!$          ! Compute a diagnostic of the map.
!!$          IF(contfrac(ib).GT.zero) THEN
!!$             irrigmap (ib) = irrigated(ib) / ( resolution(ib,1)*resolution(ib,2)*contfrac(ib) )
!!$          ELSE
!!$             irrigmap (ib) = zero
!!$          ENDIF
          !
       ENDIF
       !
       IF ( init_flood ) THEN
          floodplains(ib) = MIN(area_flood(iflood)+area_flood(idam)+area_flood(isal), &
               & resolution(ib,1)*resolution(ib,2)*contfrac(ib))
          IF ( floodplains(ib) < 0 ) THEN
             WRITE(numout,*) 'We have a problem here : ', floodplains(ib) 
             WRITE(numout,*) 'resolution :', resolution(ib,1), resolution(ib,2)
             WRITE(numout,*) area_flood
             CALL ipslerr_p(3,'routing_irrigmap','Problem with floodplains..','','')
          ENDIF
!!$          ! Compute a diagnostic of the map.
!!$          IF(contfrac(ib).GT.zero) THEN
!!$             floodmap(ib) = floodplains(ib) / ( resolution(ib,1)*resolution(ib,2)*contfrac(ib) )
!!$          ELSE
!!$             floodmap(ib) = 0.0
!!$          ENDIF
       ENDIF
       !
       IF ( init_swamp ) THEN
          swamp(ib) = MIN(area_flood(iswamp), resolution(ib,1)*resolution(ib,2)*contfrac(ib))
          IF ( swamp(ib) < 0 ) THEN
             WRITE(numout,*) 'We have a problem here : ', swamp(ib) 
             WRITE(numout,*) 'resolution :', resolution(ib,1), resolution(ib,2)
             WRITE(numout,*) area_flood
             CALL ipslerr_p(3,'routing_irrigmap','Problem with swamp...','','')
          ENDIF
!!$          ! Compute a diagnostic of the map.
!!$          IF(contfrac(ib).GT.zero) THEN
!!$             swampmap(ib) = swamp(ib) / ( resolution(ib,1)*resolution(ib,2)*contfrac(ib) )
!!$          ELSE
!!$             swampmap(ib) = zero
!!$          ENDIF
       ENDIF
       !
       !
    ENDDO
    !
    !
    
    IF (printlev>=1) THEN
       IF ( init_irrig ) WRITE(numout,*) "Diagnostics irrigated :", MINVAL(irrigated), MAXVAL(irrigated)
       IF ( init_flood ) WRITE(numout,*) "Diagnostics floodplains :", MINVAL(floodplains), MAXVAL(floodplains)
       IF ( init_swamp ) WRITE(numout,*) "Diagnostics swamp :", MINVAL(swamp), MAXVAL(swamp)
    END IF

! No compensation is done for overlapping floodplains, swamp and irrig. At least overlapping will not
! happen between floodplains and swamp alone
!    IF ( init_irrig .AND. init_flood ) THEN
!       DO ib = 1, nbpt
!          surp = (floodplains(ib)+swamp(ib)+irrigated(ib)) / (resolution(ib,1)*resolution(ib,2)*contfrac(ib))
!          IF ( surp .GT. un ) THEN
!             floodplains(ib) = floodplains(ib) / surp
!             swamp(ib) = swamp(ib) / surp
!             irrigated(ib) = irrigated(ib) / surp
!          ENDIF
!       ENDDO
!    ENDIF
    !
    DEALLOCATE (irrsub_area)
    DEALLOCATE (irrsub_index)
    !
    DEALLOCATE (mask)
    DEALLOCATE (resol_lu)
    !
    DEALLOCATE (lonrel)
    DEALLOCATE (latrel)
    !
  END SUBROUTINE routing_irrigmap
  !
!! ================================================================================================================================
!! SUBROUTINE   : routing_waterbal
!!
!>\BRIEF         This subroutine checks the water balance in the routing module.
!!
!! DESCRIPTION (definitions, functional, design, flags) : None
!!
!! RECENT CHANGE(S): None
!!
!! MAIN OUTPUT VARIABLE(S):
!!
!! REFERENCES   : None
!!
!! FLOWCHART    : None
!! \n
!_ ================================================================================================================================

SUBROUTINE routing_waterbal(nbpt, reinit, floodout, runoff, drainage, returnflow, &
               & reinfiltration, irrigation, riverflow, coastalflow)
    !
    IMPLICIT NONE
    !
!! INPUT VARIABLES
    INTEGER(i_std), INTENT(in) :: nbpt                 !! Domain size  (unitless)
    LOGICAL, INTENT(in)        :: reinit               !! Controls behaviour (true/false)
    REAL(r_std), INTENT(in)    :: floodout(nbpt)       !! Grid-point flow out of floodplains (kg/m^2/dt)
    REAL(r_std), INTENT(in)    :: runoff(nbpt)         !! Grid-point runoff (kg/m^2/dt)
    REAL(r_std), INTENT(in)    :: drainage(nbpt)       !! Grid-point drainage (kg/m^2/dt)
    REAL(r_std), INTENT(in)    :: returnflow(nbpt)     !! The water flow from lakes and swamps which returns to the grid box.
                                                       !! This water will go back into the hydrol module to allow re-evaporation (kg/m^2/dt)
    REAL(r_std), INTENT(in)    :: reinfiltration(nbpt) !! Water flow from ponds and floodplains which returns to the grid box (kg/m^2/dt)
    REAL(r_std), INTENT(in)    :: irrigation(nbpt)     !! Irrigation flux. This is the water taken from the reservoirs and beeing put into the upper layers of the soil (kg/m^2/dt)
    REAL(r_std), INTENT(in)    :: riverflow(nbpt)      !! Outflow of the major rivers. The flux will be located on the continental grid but this should be a coastal point (kg/dt)
    REAL(r_std), INTENT(in)    :: coastalflow(nbpt)    !! Outflow on coastal points by small basins. This is the water which flows in a disperse way into the ocean (kg/dt)
    !
    ! We sum-up all the water we have in the warious reservoirs
    !
    REAL(r_std), SAVE          :: totw_flood           !! Sum of all the water amount in the floodplains reservoirs (kg)
!$OMP THREADPRIVATE(totw_flood)
    REAL(r_std), SAVE          :: totw_stream          !! Sum of all the water amount in the stream reservoirs (kg)
!$OMP THREADPRIVATE(totw_stream)
    REAL(r_std), SAVE          :: totw_fast            !! Sum of all the water amount in the fast reservoirs (kg)
!$OMP THREADPRIVATE(totw_fast)
    REAL(r_std), SAVE          :: totw_slow            !! Sum of all the water amount in the slow reservoirs (kg)
!$OMP THREADPRIVATE(totw_slow)
    REAL(r_std), SAVE          :: totw_lake            !! Sum of all the water amount in the lake reservoirs (kg)
!$OMP THREADPRIVATE(totw_lake)
    REAL(r_std), SAVE          :: totw_pond            !! Sum of all the water amount in the pond reservoirs (kg)
!$OMP THREADPRIVATE(totw_pond)
    REAL(r_std), SAVE          :: totw_in              !! Sum of the water flow in to the routing scheme
!$OMP THREADPRIVATE(totw_in)
    REAL(r_std), SAVE          :: totw_out             !! Sum of the water flow out to the routing scheme
!$OMP THREADPRIVATE(totw_out)
    REAL(r_std), SAVE          :: totw_return          !! 
!$OMP THREADPRIVATE(totw_return)
    REAL(r_std), SAVE          :: totw_irrig           !! 
!$OMP THREADPRIVATE(totw_irrig)
    REAL(r_std), SAVE          :: totw_river           !! 
!$OMP THREADPRIVATE(totw_river)
    REAL(r_std), SAVE          :: totw_coastal         !! 
!$OMP THREADPRIVATE(totw_coastal)
    REAL(r_std)                :: totarea              !! Total area of basin (m^2)
    REAL(r_std)                :: area                 !! Total area of routing (m^2)
    INTEGER(i_std)             :: ig                   !! 
    !
    ! Just to make sure we do not get too large numbers !
    !
!! PARAMETERS
    REAL(r_std), PARAMETER     :: scaling = 1.0E+6     !!
    REAL(r_std), PARAMETER     :: allowed_err = 50.    !!

!_ ================================================================================================================================
    !
    IF ( reinit ) THEN
       !
       totw_flood = zero
       totw_stream = zero
       totw_fast = zero
       totw_slow = zero
       totw_lake = zero
       totw_pond = zero 
       totw_in = zero
       !
       DO ig=1,nbpt
          !
          totarea = SUM(routing_area(ig,:))
          !
          totw_flood = totw_flood + SUM(flood_reservoir(ig,:)/scaling)
          totw_stream = totw_stream + SUM(stream_reservoir(ig,:)/scaling)
          totw_fast = totw_fast + SUM(fast_reservoir(ig,:)/scaling)
          totw_slow = totw_slow + SUM(slow_reservoir(ig,:)/scaling)
          totw_lake = totw_lake + lake_reservoir(ig)/scaling
          totw_pond = totw_pond + pond_reservoir(ig)/scaling
          !
          totw_in = totw_in + (runoff(ig)*totarea + drainage(ig)*totarea - floodout(ig)*totarea)/scaling
          !
       ENDDO
       !
    ELSE
       !
       totw_out = zero
       totw_return = zero
       totw_irrig = zero
       totw_river = zero
       totw_coastal = zero
       area = zero
       !
       DO ig=1,nbpt
          !
          totarea = SUM(routing_area(ig,:))
          !
          totw_flood = totw_flood - SUM(flood_reservoir(ig,:)/scaling)
          totw_stream = totw_stream - SUM(stream_reservoir(ig,:)/scaling)
          totw_fast = totw_fast - SUM(fast_reservoir(ig,:)/scaling)
          totw_slow = totw_slow - SUM(slow_reservoir(ig,:)/scaling)
          totw_lake = totw_lake - lake_reservoir(ig)/scaling
          totw_pond = totw_pond - pond_reservoir(ig)/scaling
          !
          totw_return = totw_return + (reinfiltration(ig)+returnflow(ig))*totarea/scaling
          totw_irrig = totw_irrig + irrigation(ig)*totarea/scaling
          totw_river = totw_river + riverflow(ig)/scaling
          totw_coastal = totw_coastal + coastalflow(ig)/scaling
          !
          area = area + totarea
          !
       ENDDO
       totw_out = totw_return + totw_irrig + totw_river + totw_coastal
       !
       ! Now we have all the information to balance our water
       !
       IF ( ABS((totw_flood + totw_stream + totw_fast + totw_slow + totw_lake + totw_pond) - &
            & (totw_out - totw_in)) > allowed_err ) THEN
          WRITE(numout,*) 'WARNING : Water not conserved in routing. Limit at ', allowed_err, ' 10^6 kg'
          WRITE(numout,*) '--Water-- change : flood stream fast ', totw_flood, totw_stream, totw_fast
          WRITE(numout,*) '--Water-- change : slow, lake ', totw_slow, totw_lake
          WRITE(numout,*) '--Water>>> change in the routing res. : ', totw_flood + totw_stream + totw_fast + totw_slow + totw_lake
          WRITE(numout,*) '--Water input : ', totw_in
          WRITE(numout,*) '--Water output : ', totw_out
          WRITE(numout,*) '--Water output : return, irrig ', totw_return, totw_irrig
          WRITE(numout,*) '--Water output : river, coastal ',totw_river, totw_coastal
          WRITE(numout,*) '--Water>>> change by fluxes : ', totw_out - totw_in, ' Diff [mm/dt]: ',   &
               & ((totw_flood + totw_stream + totw_fast + totw_slow + totw_lake) - (totw_out - totw_in))/area

          ! Stop the model
          CALL ipslerr_p(3, 'routing_waterbal', 'Water is not conserved in routing.','','')
       ENDIF
       !
    ENDIF
    !
  END SUBROUTINE routing_waterbal
  !
  !
END MODULE routing